R/scorecard_precheck.R

In greatgray/scorecard: GGCM Model Performance Scorecard

#' Check scorecard configuration file before use
#'
#' Determines whether a scorecard YAML file contains expected
#' structure and some content.  Structure includes provision of
#' activate, candidate, deactivated, and retired model groups.
#' Content includes identification of scorecard row entry model
#' configuration file names and whether these files are readable
#' in the \code{models} sub-directory of the current working directory.
#' Scorecard file names missing, non-existent scorecard file, and
#' ill-structured YAML return \code{valid=FALSE} in the resulting
#' list.  Activated models expected to have \code{initeq} initial equity
#' values given.
#' @param scorecard_file the path to the scorecard configuration file (YAML)
#' @return list containing validation checks and final determination
#' @seealso scorecard_update, scorecard_produce
#' @export
scorecard_precheck <- function( scorecard_file=NA ) {

  rv <- list(file=scorecard_file,
             date=lubridate::today(),
             message=NA,
             has_activated=FALSE,
             has_candidate=FALSE,
             has_deactivated=FALSE,
             has_retired=FALSE,
             has_model_files=FALSE,
             has_init_eq=FALSE,
             model_check=c(),
             scorecard=NA,
             valid=FALSE)

  require(yaml)

  # options for many functions
  o1 <- options("stringsAsFactors" = FALSE)
  on.exit(options(o1), add=TRUE)

  if ( is.na(scorecard_file) ) {
    rv$message <- "Scorecard file name not provided"
    return(rv)
  }

  if ( !file.exists(scorecard_file) ) {
    rv$message <- "Scorecard input file does not exist"
    return(rv)
  }


  scorecard <- yaml::yaml.load_file(scorecard_file)

  scorecard$table$activated <- lapply(scorecard$table$activated, function(i){
    i$status <- "activated"
    rv$has_activated <<- TRUE
    return(i)
  })
  scorecard$table$candidate <- lapply(scorecard$table$candidate, function(i){
    i$status <- "candidate"
    rv$has_candidate <<- TRUE
    return(i)
  })
  scorecard$table$deactivated <- lapply(scorecard$table$deactivated, function(i){
    i$status <- "deactivated"
    rv$has_deactivated <<- TRUE
    return(i)
  })
  scorecard$table$retired <- lapply(scorecard$table$retired, function(i){
    i$status <- "retired"
    rv$has_retired <<- TRUE
    return(i)
  })

  scorecard_table <- c(
    scorecard$table$activated,
    scorecard$table$candidate,
    scorecard$table$deactivated,
    scorecard$table$retired
  )

  rv$model_files <-
    unlist(lapply(scorecard_table, function(x)
      return(x$config)))

  rv$has_model_files <- TRUE
  rv$model_check <- lapply(scorecard_table, function( scorecard_row ) {
    if ( scorecard_row$status %in% c('activated', 'candidate') ) {
      fp <- file.path("models", scorecard_row$config)
      fa <- file.access( fp, mode=4 )
      if ( fa != 0 ) {
        rv$has_model_files <<- FALSE
      }
      return( list(path=fp, readable=as.numeric( fa )) )
    }
    return ( list() )
  })

  rv$has_init_eq <- TRUE
  rv$initeq_check <- lapply(scorecard_table, function( scorecard_row ) {
    if ( scorecard_row$status == 'activated' ) {
      has_init_eq <- "initeq" %in% names(scorecard_row)
      if ( has_init_eq == FALSE  ) {
        rv$has_init_eq <- FALSE
      }
      return( list(id = scorecard_row$id, has_init_eq = has_init_eq ))
    }
    return( list() )
  })

  # final validation of structure and content
  rv$valid <- all(rv$has_activated,
                  rv$has_candidate,
                  rv$has_deactivated,
                  rv$has_retired,
                  rv$has_init_eq,
                  rv$has_model_files)

  rv$message <- ifelse(rv$valid,
                       "Scorecard file validated",
                       "Scorecard file invalid")

  rv$scorecard <- scorecard_table
  return(rv)
}