R/model_orientated.R

In vadmbertr/bonski.predict: Predict Where Ski Will Be Good

#' Statistical model used to predict ski conditions evaluations by orientations cluster
#'
#' We noticed that orientation is correlated with the ski condition evaluation. Therefore, we tried to take this into
#' account and classify using nivological observations per orientations cluster.
#'
#' # Create model object
#' model <- OrientatedModel()
#'
#' # Fit model if not already fitted
#' fit(model, classify, scoring) # optionnal run by instructions bellow if needed
#' score <- score(model, ord_score) # optionnal run by instructions bellow if needed
#'
#' # Run predictions
#' y <- predict_fresh(model) # fit first if model has not been loaded from the filesystem
#'
#' # Save model to the filesystem to be reused without fitting again
#' save_model(model)
#'
#' @param name character. Model name
#' @param orientations list. List of orientations vectors
#' @param modelClass func. Model constructor
#'
#' @return OrientatedModel. object
#'
#' @export
OrientatedModel <- function(name = "MINIROCKET",
                            orientations = list(c("N", "NE", "NW"), c("S", "SW", "SE"), "T", "E", "W"),
                            modelClass = MinirocketModel) {
  name <- paste(name, "orientated", sep = "_")
  obj_path <- get_model_path(name)
  if (file.exists(obj_path)) {
    obj <- load_model(name)
  } else {
    obj <- rlang::env(
      name = name,
      orientations = orientations,
      modelClass = modelClass,
      models = vector(mode = "list", length = length(orientations)),
      ski_nivo = NULL, routes_stations = NULL
    )
    names(obj$orientations) <- lapply(orientations, function(orientation) join_orientations(orientation))
    names(obj$models) <- names(obj$orientations)
    class(obj) <- "OrientatedModel"
    create_children(obj)
  }

  obj
}

# -------
# METHODS
# -------

load_ski_nivo.OrientatedModel <- function(obj, past_horizon) {
  if (is.null(obj$ski_nivo)) {
    tmp <- obj$models[[1]]
    if (is.null(tmp)) {
      tmp <- obj$modelClass()
    }
    load_ski_nivo(tmp, past_horizon)
    obj$ski_nivo <- tmp$data$ski_nivo
    obj$routes_stations <- tmp$data$routes_stations
  }
}

pre_save_children <- function(obj, ...) UseMethod("pre_save_children")
pre_save_children.OrientatedModel <- function(obj) {
  lapply(obj$models, function(model) pre_save_model(model))
}

pre_save_model.OrientatedModel <- function(obj) {
  pre_save_children(obj)
  obj$ski_nivo <- NULL
}

#' Save model on the filesystem
#'
#' @param OrientatedModel obj. Model object
#'
#' @export
save_model.OrientatedModel <- function(obj) {
  pre_save_model(obj)
  saveRDS(obj, file = get_model_path(obj$name))
}

post_load_children <- function(obj, ...) UseMethod("post_load_children")
post_load_children.OrientatedModel <- function(obj) {
  obj$models <- lapply(obj$models, function(model) {
    post_load_model(model)
    model
  })
}

post_load_model.OrientatedModel <- function(obj) {
  post_load_children(obj)
}

create_child <- function(obj, ...) UseMethod("create_child")

#' Create a model for the given orientations
#'
#' @param obj OrientatedModel
#' @param orientations vector. Vector of orientations
#'
#' @return Model
create_child.OrientatedModel <- function(obj, orientations, past_horizon) {
  model <- obj$modelClass()
  model$data$past_horizon <- past_horizon
  restrict_orientations(model, orientations, obj$ski_nivo, obj$routes_stations)
  load_Xy(model)
  split_Xy(model)
  model
}

#' Create one model per orientations cluster
#'
#' @param obj OrientatedModel
create_children <- function(obj, ...) UseMethod("create_children")

#' Create one model per orientations cluster
#'
#' @param obj OrientatedModel
create_children.OrientatedModel <- function(obj, past_horizon = 9) {
  load_ski_nivo(obj, past_horizon)
  obj$models <- lapply(obj$orientations, function(orientations) create_child(obj, orientations, past_horizon))
  names(obj$models) <- names(obj$orientations)
}

#' Oriented model fitting
#'
#' @param obj OrientatedModel
#' @param classify logical. use classification or regression?
#' @param scoring character. Scoring method used by the classifier
#'
#' @export
fit.OrientatedModel <- function(obj, classify = TRUE, scoring = NULL) {
  n_cores <- future::availableCores()
  future::plan(future::multicore, workers = n_cores)

  obj$models <- furrr::future_map(obj$models, function(model) {
    fit(model, classify = classify, scoring = scoring)
    model
  }, .options = furrr::furrr_options(seed = TRUE))
}

#' Oriented model score
#'
#' If ord_score is TRUE instead of performing an accuracy score (is the predicted class equals to the true one) we take
#' advantage of the fact that the ski evaluation score is an ordinal variable:
#'
#' @param obj OrientatedModel
#' @param ord_score logical. Whether the score should be computed as ordinal
#'
#' @return list. scores
#'
#' @export
score.OrientatedModel <- function(obj, ord_score = FALSE) {
  scores <- lapply(obj$models, function(model) score(model, ord_score))
  names(scores) <- names(obj$models)
  scores
}

#' Oriented model predict using fresh data
#'
#' @param obj OrientatedModel
#'
#' @return data.frame
#'
#' @export
predict_fresh.OrientatedModel <- function(obj) {
  n_cores <- future::availableCores()
  future::plan(future::multicore, workers = n_cores)

  X_fresh <- fetch_fresh_X(obj$models[[1]]$data)
  furrr::future_map(obj$models, function(model) predict_fresh(model, X_fresh),
                    .options = furrr::furrr_options(seed = NULL)) %>%
    data.table::rbindlist()
}

#' Evaluate an oriented model
#'
#' @param obj OrientatedModel. model to evaluate
#' @param na_replacements vector. NA replacement strategies
#' @param splits vector. training - test splits
#' @param classify list. use classification or regression?
#' @param scorings list. fit scoring strategies
#' @param ord_scores list. score as ordinal?
#'
#' @return data.frame. evaluation
#'
#' @export
evaluate.OrientatedModel <- function(obj, na_replacements, splits, classify, scorings, ord_scores) {
  n_cores <- future::availableCores()
  future::plan(future::multicore, workers = n_cores)

  do_evaluate <- function(orientation) {
    evaluate(obj$models[[orientation]], na_replacements, splits, classify, scorings, ord_scores) %>%
      dplyr::mutate(orientation = orientation)
  }

  furrr::future_map(names(obj$models), do_evaluate, .options = furrr::furrr_options(seed = TRUE)) %>%
    data.table::rbindlist() %>%
    dplyr::group_by(orientation) %>%
    dplyr::summarise_all(mean, na.rm = TRUE)
}

# ---------
# FUNCTIONS
# ---------

join_orientations <- function(orientations) {
  paste(orientations, collapse = "_")
}