R/FamiliarModel.R

In familiar: End-to-End Automated Machine Learning and Model Evaluation

#' @include FamiliarS4Generics.R
#' @include FamiliarS4Classes.R
NULL



# .train (familiarModel, dataObject) -------------------------------------------
setMethod(
  ".train",
  signature(
    object = "familiarModel",
    data = "dataObject"
  ),
  function(
    object,
    data,
    get_additional_info = FALSE,
    is_pre_processed = FALSE,
    trim_model = TRUE,
    timeout = 60000.0,
    approximate = FALSE,
    ...
  ) {
    # Train method for model training

    # Check if the class of object is a subclass of familiarModel.
    if (!is_subclass(class(object)[1L], "familiarModel")) object <- promote_learner(object)
    
    # Process data, if required.
    data <- process_input_data(
      object = object,
      data = data,
      is_pre_processed = is_pre_processed,
      stop_at = "clustering"
    )

    # Work only with data that has known outcomes when training.
    data <- filter_missing_outcome(data = data)

    # Set the training flags
    can_train <- can_train_naive <- TRUE

    # Check if there are any data entries. The familiar model cannot be trained
    # otherwise. We do allow for no features being present.
    if (is_empty(x = data, allow_no_features = TRUE)) {
      can_train <- can_train_naive <- FALSE
      object <- ..update_errors(
        object = object,
        ..error_message_no_training_data_available()
      )
    }

    # Check the number of features in data; if it has no features, a standard
    # familiar model can not be trained. However, it might be possible to train
    # a naive model.
    if (!has_feature_data(x = data)) {
      can_train <- FALSE
      object <- ..update_errors(
        object = object,
        ..error_message_no_features_selected_for_training()
      )
    }

    # Check if the hyperparameters are plausible.
    if (!has_optimised_hyperparameters(object = object)) {
      can_train <- can_train_naive <- FALSE
      object <- ..update_errors(
        object = object,
        ..error_message_no_optimised_hyperparameters_available()
      )
    }

    # Check if a naive model should be trained.
    if (!requires_naive_model(object)) {
      can_train_naive <- FALSE
    }

    # Add outcome distribution data.
    object@outcome_info <- .compute_outcome_distribution_data(
      object = object@outcome_info,
      data = data
    )

    # Train a new model based on data. If a normal model cannot be trained,
    # attempt to train a naive model.
    if (can_train) {
      object <- ..train(
        object = object,
        data = data,
        approximate = approximate,
        ...
      )
      
    } else if (can_train_naive) {
      if (is(object, "familiarNaiveModel")) {
        # Native familiar model (i.e. explicitly requested by the user.)
        object <- ..train_naive(
          object = object,
          data = data,
          check_hyperparameters = FALSE,
          ...
        )
        
      } else {
        # Naive model created because this is the most informative model (
        # which is generally bad news).
        object <- ..train_naive(
          object = object,
          data = data,
          ...
        )
      }
    }

    # Extract information required for assessing model performance, calibration
    # (e.g. baseline survival) etc.
    if (get_additional_info) {
      # Remove duplicate samples from the data prior to obtaining additional
      # data.
      data <- aggregate_data(data = data)

      # Create calibration models and add to the object. Not all models require
      # recalibration.
      if (can_train) {
        object <- ..set_recalibration_model(
          object = object,
          data = data
        )
      }

      # Extract data required for assessing calibration. Not all outcome types
      # require calibration info. Currently calibration information is only
      # retrieved for survival outcomes, in the form of baseline survival
      # curves.
      if (can_train || can_train_naive) {
        object <- ..set_calibration_info(
          object = object,
          data = data
        )
      }

      # Set stratification thresholds. This is currently only done for
      # survival outcomes.
      if (can_train) {
        object <- ..set_risk_stratification_thresholds(
          object = object,
          data = data
        )
      }

      # Add column data
      object <- add_data_column_info(
        object = object,
        data = data
      )
    }

    if (trim_model) object <- trim_model(object = object, timeout = timeout)

    # Empty slots if a model can not be trained.
    if (!can_train) {
      object@required_features <- NULL
      object@model_features <- NULL
      object@novelty_features <- NULL
    }

    return(object)
  }
)


# .train (familiarModel, NULL)--------------------------------------------------
setMethod(
  ".train",
  signature(
    object = "familiarModel",
    data = "NULL"
  ),
  function(
    object,
    data,
    ...
  ) {
    # The model cannot be trained, and is returned directly.
    return(object)
  }
)



# show (model) -----------------------------------------------------------------
setMethod(
  "show",
  signature(object = "familiarModel"),
  function(object) {
    # Make sure the model object is updated.
    object <- update_object(object = object)

    if (!model_is_trained(object)) {
      cat(paste0(
        "A ", object@learner, " model (class: ", class(object)[1L],
        ") that was not successfully trained (", 
        .familiar_version_string(object), ").\n"
      ))

      if (length(object@messages$warning) > 0L) {
        condition_messages <- condition_summary(object@messages$warning)
        cat(paste0(
          "\nThe following ",
          ifelse(length(condition_messages) == 1L, "warning was", "warnings were"),
          " generated while trying to train the model:\n",
          paste0(condition_messages, collapse = "\n"),
          "\n"
        ))
      }

      if (length(object@messages$error) > 0L) {
        condition_messages <- condition_summary(object@messages$error)
        cat(paste0(
          "\nThe following ",
          ifelse(length(condition_messages) == 1L, "error was", "errors were"),
          " encountered while trying to train the model:\n",
          paste0(condition_messages, collapse = "\n"),
          "\n"
        ))
      }
      
      return(invisible(NULL))
    }
    
    # Describe the learner and the version of familiar.
    message_str <- paste0(
      "A ", object@learner, " model (class: ", class(object)[1L],
      "; ", .familiar_version_string(object), ")"
    )
    
    # Describe the package(s), if any
    if (!is.null(object@package)) {
      message_str <- c(
        message_str,
        paste0(" trained using "),
        paste_s(mapply(
          ..message_package_version,
          x = object@package,
          version = object@package_version
        )),
        ifelse(length(object@package) > 1L, " packages", " package"
        )
      )
    }
    
    # Complete message and write.
    message_str <- paste0(c(message_str, ".\n"), collapse = "")
    cat(message_str)
    
    cat(paste0("\n--------------- Model details ---------------\n"))
    
    # Model details
    if (object@is_trimmed) {
      cat(object@trimmed_function$show, sep = "\n")
    } else {
      show(object@model)
    }
    
    cat(paste0("\n---------------------------------------------\n"))
    
    # Outcome details
    cat("\nThe following outcome was modelled:\n")
    show(object@outcome_info)
    
    # Details concerning hyperparameters.
    cat("\nThe model was trained using the following hyperparameters:\n")
    invisible(lapply(
      names(object@hyperparameters),
      function(x, object) {
        cat(paste0("  ", x, ": ", object@hyperparameters[[x]], "\n"))
      },
      object = object
    ))
    
    # Details concerning variable importance.
    cat(paste0(
      "\nVariable importance was determined using the ",
      object@vimp_method, " variable importance method.\n"
    ))
    vimp_data <- aggregate_vimp_table(
      object@vimp_table,
      aggregation_method = object@vimp_aggregation_method,
      rank_threshold = object@vimp_rank_threshold
    )
    if (!is.null(vimp_data)) {
      cat(show(get_vimp_table(vimp_data)[order(rank)]))
      cat("\n")
    }
    rm(vimp_data)
    
    # Details concerning model features:
    cat("\nThe following features were used in the model:\n")
    lapply(
      object@model_features,
      function(x, object) show(object@feature_info[[x]]),
      object = object
    )
    
    # Details concerning novelty features:
    if (!model_is_trained(object@novelty_detector)) {
      cat("\nNo novelty detector was trained.\n")
      
    } else if (setequal(object@model_features, object@novelty_features)) {
      cat("\nA novelty detector was trained using the model features.\n")
      
    } else {
      cat("\nA novelty detector was trained using the model features above, and additionally:\n\n")
      
      # Identify novelty features that were set in addition to model
      # features.
      novelty_features <- setdiff(object@novelty_features, object@model_features)
      
      lapply(
        novelty_features, 
        function(x, object) show(object@feature_info[[x]]), 
        object = object
      )
    }
    
    if (length(object@messages$warning) > 0L || length(object@messages$error) > 0L) {
      cat(paste0("\n------------ Warnings and errors ------------\n"))
      
      if (length(object@messages$warning) > 0L) {
        condition_messages <- condition_summary(object@messages$warning)
        cat(paste0(
          "\nThe following ",
          ifelse(length(condition_messages) == 1L, "warning was", "warnings were"),
          " generated while training the model:\n",
          paste0(condition_messages, collapse = "\n")
        ))
      }
      
      if (length(object@messages$error) > 0L) {
        condition_messages <- condition_summary(object@messages$error)
        cat(paste0(
          "\nThe following ",
          ifelse(length(condition_messages) == 1L, "error was", "errors were"),
          " encountered while training the model:\n",
          paste0(condition_messages, collapse = "\n")
        ))
      }
    }
    
    # Check package version.
    check_package_version(object)
  }
)


#' Model summaries
#'
#' `summary` produces model summaries.
#'
#' @param object a familiarModel object
#' @param ... additional arguments passed to `summary` methods for the underlying
#'   model, when available.
#'
#' @details This method extends the `summary` S3 method. For some models
#'   `summary` requires information that is trimmed from the model. In this case
#'   a copy of summary data is stored with the model, and returned.
#'
#' @return Depends on underlying model. See the documentation for the particular
#'   models.
#'
#' @exportMethod summary
#' @rdname summary-methods
#' @md
setGeneric("summary")

# summary-----------------------------------------------------------------------

#' @rdname summary-methods
setMethod(
  "summary",
  signature(object = "familiarModel"),
  function(object, ...) {
    # Make sure the model object is updated.
    object <- update_object(object = object)

    if (!model_is_trained(object)) {
      message("The model was not trained. A summary is not available.")
      return(invisible(NULL))
    }

    # Attempt to retrieve the summary from the model.
    if (object@is_trimmed) {
      if (!is.null(object@trimmed_function$summary)) {
        return(object@trimmed_function$summary)
      }
    }

    # Attempt to capture the summary directly.
    h <- tryCatch(
      summary(object@model, ...),
      error = identity
    )

    # If an error is generated, create a message and return an invisible NULL.
    if (inherits(h, "error")) {
      message("No summary is available for this model.")
      return(invisible(NULL))
    }

    # If the summary is a default one, create a message and return an invisible
    # NULL.
    if (inherits(h, "summaryDefault")) {
      message("No summary is available for this model.")
      return(invisible(NULL))
    }

    return(h)
  }
)



#' Extract model coefficients
#'
#' @param object a familiarModel object
#' @param ... additional arguments passed to `coef` methods for the underlying
#'   model, when available.
#'
#' @details This method extends the `coef` S3 method. For some models `coef`
#'   requires information that is trimmed from the model. In this case a copy of
#'   the model coefficient is stored with the model, and returned.
#'
#' @return Coefficients extracted from the model in the familiarModel object, if
#'   any.
#' @export
#' @rdname coef-methods
#' @md
setGeneric("coef")

# coef -------------------------------------------------------------------------

#' @rdname coef-methods
setMethod(
  "coef",
  signature(object = "familiarModel"),
  function(object, ...) {
    # Make sure the model object is updated.
    object <- update_object(object = object)

    # No training, no coefficients.
    if (!model_is_trained(object)) return(NULL)

    # Attempt to retrieve the coefficients from the model.
    if (object@is_trimmed) {
      if (!is.null(object@trimmed_function$coef)) {
        return(object@trimmed_function$coef)
      }
    }

    # Attempt to capture the coefficients directly.
    feature_coefficients <- tryCatch(
      coef(object@model, ...),
      error = identity
    )

    # If an error is generated by coef, return a NULL.
    if (inherits(feature_coefficients, "error")) return(NULL)
    
    return(feature_coefficients)
  }
)



#' Calculate variance-covariance matrix for a model
#'
#' @param object a familiarModel object
#' @param ... additional arguments passed to `vcov` methods for the underlying
#'   model, when available.
#'
#' @details This method extends the `vcov` S3 method. For some models `vcov`
#'   requires information that is trimmed from the model. In this case a copy of
#'   the variance-covariance matrix is stored with the model, and returned.
#'
#' @return Variance-covariance matrix of the model in the familiarModel object,
#'   if any.
#' @export
#' @rdname vcov-methods
#' @md
setGeneric("vcov")

# vcov -------------------------------------------------------------------------

#' @rdname vcov-methods
setMethod(
  "vcov", signature(object = "familiarModel"),
  function(object, ...) {
    # Make sure the model object is updated.
    object <- update_object(object = object)

    # No training, no variance-covariance matrix
    if (!model_is_trained(object)) return(NULL)

    # Attempt to retrieve the variance-covariance matrix from the model.
    if (object@is_trimmed) {
      if (!is.null(object@trimmed_function$vcov)) {
        return(object@trimmed_function$vcov)
      }
    }

    # Attempt to capture the variance-covariance matrix directly.
    variance_covariance_matrix <- tryCatch(
      vcov(object@model, ...),
      error = identity
    )

    # If an error is generated by vcov, return a NULL.
    if (inherits(variance_covariance_matrix, "error")) return(NULL)

    return(variance_covariance_matrix)
  }
)



# require_package (model) ------------------------------------------------------
setMethod(
  "require_package",
  signature(x = "familiarModel"),
  function(x, purpose = NULL, message_type = "error", ...) {
    # Skip if no package is required.
    if (is_empty(x@package)) return(invisible(TRUE))

    # Set standard purposes for common uses.
    if (!is.null(purpose)) {
      if (purpose %in% c("train", "vimp", "predict", "show", "distribution")) {
        purpose <- switch(purpose,
          "train" = "to train a model",
          "vimp" = "to determine variable importance",
          "predict" = "to create model predictions",
          "show" = "to capture output",
          "distribution" = "to set the model distribution"
        )
      }
    }

    return(invisible(.require_package(
      x = x@package,
      purpose = purpose,
      message_type = message_type
    )))
  }
)



# set_package_version (model) --------------------------------------------------
setMethod(
  "set_package_version",
  signature(object = "familiarModel"),
  function(object) {
    # Do not add package versions if there are no packages.
    if (is_empty(object@package)) return(object)

    # Obtain package versions.
    object@package_version <- sapply(
      object@package,
      function(x) (as.character(utils::packageVersion(x)))
    )

    return(object)
  }
)



# check_package_version (model) ------------------------------------------------
setMethod(
  "check_package_version",
  signature(object = "familiarModel"),
  function(object) {
    .check_package_version(
      name = object@package,
      version = object@package_version,
      when = "at model creation"
    )
  }
)



# save (model) -----------------------------------------------------------------
setMethod(
  "save",
  signature(
    list = "familiarModel",
    file = "character"
  ),
  function(list, file) {
    .save(object = list, dir_path = file)
  }
)



# add_model_name (ANY, familiarModel)-------------------------------------------
setMethod(
  "add_model_name",
  signature(
    data = "ANY",
    object = "familiarModel"
  ),
  function(data, object) {
    if (is_empty(data)) return(NULL)

    ..error_reached_unreachable_code(
      "add_model_name,any,familiarModel: no method for non-empty data."
    )
  }
)



# add_model_name (familiarDataElement, familiarModel)---------------------------
setMethod(
  "add_model_name",
  signature(
    data = "familiarDataElement",
    object = "familiarModel"
  ),
  function(data, object) {
    # Determine the model name
    if (length(object@name) == 0L) {
      model_name <- get_object_name(object = object, abbreviated = TRUE)
    } else {
      model_name <- object@name
    }

    if (is.null(data@identifiers)) {
      data@identifiers <- list("model_name" = model_name)
    } else {
      data@identifiers[["model_name"]] <- model_name
    }

    return(data)
  }
)



# add_model_name (familiarDataElement, character) ------------------------------
setMethod(
  "add_model_name",
  signature(
    data = "familiarDataElement",
    object = "character"
  ),
  function(data, object) {
    # Load object.
    object <- load_familiar_object(object)

    return(do.call(
      add_model_name,
      args = list(
        "data" = data,
        "object" = object
      )
    ))
  }
)



# set_object_name (familiarModel) ----------------------------------------------

#' @title Set the name of a `familiarModel` object.
#'
#' @description Set the `name` slot using the object name.
#'
#' @param x A `familiarModel` object.
#'
#' @return A `familiarModel` object with a generated or a provided name.
#' @md
#' @keywords internal
setMethod(
  "set_object_name",
  signature(x = "familiarModel"),
  function(x, new = NULL) {
    
    if (is.null(x@project_id) && is.null(new)) {
      # Generate a random object name. A project_id of 0 means that the objects
      # was auto-generated (i.e. through object conversion). We randomly
      # generate characters and add a time stamp, so that collision is
      # practically impossible.
      slot(object = x, name = "name") <- paste0(
        as.character(as.numeric(format(Sys.time(), "%H%M%S"))),
        "_", rstring(n = 20L)
      )
      
    } else if (is.null(new)) {
      # Generate a sensible object name.
      slot(object = x, name = "name") <- get_object_name(object = x)
      
    } else {
      slot(object = x, name = "name") <- new
    }

    return(x)
  }
)



# get_object_name (model) ------------------------------------------------------
setMethod(
  "get_object_name",
  signature(object = "familiarModel"),
  function(object, abbreviated = FALSE) {
    
    if (abbreviated) {
      # Create an abbreviated name
      model_name <- paste0("model.", object@data_id, ".", object@run_id)
      
    } else {
      # Create the full name of the model
      model_name <- get_object_file_name(
        learner = object@learner,
        vimp_method = object@vimp_method,
        project_id = object@project_id,
        data_id = object@data_id,
        run_id = object@run_id,
        object_type = "familiarModel",
        with_extension = FALSE
      )
    }

    return(model_name)
  }
)



# model_is_trained (familiarModel) ---------------------------------------------
setMethod(
  "model_is_trained",
  signature(object = "familiarModel"),
  function(object) {
    # Check if a model was trained
    if (is.null(object@model)) {
      # If no model is attached to the object, assume that no model was
      # trained.
      return(FALSE)
      
    } else {
      # If the the model is not NULL, assume that it is present.
      return(TRUE)
    }
  }
)



# model_is_trained (character) -------------------------------------------------
setMethod(
  "model_is_trained",
  signature(object = "character"),
  function(object) {
    # Load object.
    object <- load_familiar_object(object)

    return(do.call(
      model_is_trained,
      args = c(list("object" = object))
    ))
  }
)



# model_is_trained (NULL) ------------------------------------------------------
setMethod(
  "model_is_trained",
  signature(object = "NULL"),
  function(object) {
    return(FALSE)
  }
)



# add_package_version (familiarModel) ------------------------------------------
setMethod(
  "add_package_version",
  signature(object = "familiarModel"),
  function(object) {
    # Set version of familiar
    return(.add_package_version(object = object))
  }
)



# add_data_column_info (familiarModel) -----------------------------------------
setMethod(
  "add_data_column_info",
  signature(object = "familiarModel"),
  function(
    object, 
    data = NULL, 
    sample_id_column = NULL, 
    batch_id_column = NULL, 
    series_id_column = NULL
  ) {
    # Don't determine new column information if this information is already
    # present.
    if (!is.null(object@data_column_info)) return(object)

    # Don't determine new column information if this information can be
    # inherited from a dataObject.
    if (is(data, "dataObject")) {
      if (!is_empty(data@data_column_info)) {
        object@data_column_info <- data@data_column_info

        return(object)
      }
    }

    # Load settings to find identifier columns
    settings <- get_settings()

    # Read from settings. If not set, these will be NULL.
    if (is.null(sample_id_column)) sample_id_column <- settings$data$sample_col
    if (is.null(batch_id_column)) batch_id_column <- settings$data$batch_col
    if (is.null(series_id_column)) series_id_column <- settings$data$series_col

    # Replace any missing.
    if (is.null(sample_id_column)) sample_id_column <- NA_character_
    if (is.null(batch_id_column)) batch_id_column <- NA_character_
    if (is.null(series_id_column)) series_id_column <- NA_character_

    # Repetition column ids are only internal.
    repetition_id_column <- NA_character_

    # Create table
    data_info_table <- data.table::data.table(
      "type" = c("batch_id_column", "sample_id_column", "series_id_column", "repetition_id_column"),
      "internal" = get_id_columns(),
      "external" = c(batch_id_column, sample_id_column, series_id_column, repetition_id_column)
    )

    if (object@outcome_type %in% c("survival", "competing_risk")) {
      # Find internal and external outcome column names.
      internal_outcome_columns <- get_outcome_columns(object@outcome_type)
      external_outcome_columns <- object@outcome_info@outcome_column

      # Add to table
      outcome_info_table <- data.table::data.table(
        "type" = c("outcome_column", "outcome_column"),
        "internal" = internal_outcome_columns,
        "external" = external_outcome_columns
      )
      
    } else if (object@outcome_type %in% c("binomial", "multinomial", "continuous")) {
      # Find internal and external outcome column names.
      internal_outcome_columns <- get_outcome_columns(object@outcome_type)
      external_outcome_columns <- object@outcome_info@outcome_column

      # Add to table
      outcome_info_table <- data.table::data.table(
        "type" = "outcome_column",
        "internal" = internal_outcome_columns,
        "external" = external_outcome_columns
      )
      
    } else {
      ..error_no_known_outcome_type(outcome_type = object@outcome_type)
    }

    # Combine into one table and add to object
    object@data_column_info <- rbind(data_info_table, outcome_info_table)

    return(object)
  }
)



# is_available -----------------------------------------------------------------
setMethod(
  "is_available",
  signature(object = "familiarModel"),
  function(object, ...) {
    return(FALSE)
  }
)



# get_default_hyperparameters --------------------------------------------------
setMethod(
  "get_default_hyperparameters",
  signature(object = "familiarModel"),
  function(object, ...) {
    return(list())
  }
)



# ..train (familiarModel, dataObject) ------------------------------------------
setMethod(
  "..train",
  signature(
    object = "familiarModel",
    data = "dataObject"
  ),
  function(object, data, ...) {
    # Set a NULL model
    object@model <- NULL

    return(object)
  }
)



# ..train (familiarModel, NULL) ------------------------------------------------
setMethod(
  "..train",
  signature(
    object = "familiarModel",
    data = "NULL"
  ),
  function(object, data, ...) {
    # Set a NULL model
    object@model <- NULL

    return(object)
  }
)



# ..train_naive (familiarModel, dataObject) ------------------------------------
setMethod(
  "..train_naive",
  signature(
    object = "familiarModel",
    data = "dataObject"
  ),
  function(object, data, ...) {
    # Set a NULL model
    object@model <- NULL

    return(object)
  }
)



#### ..train_naive (familiarModel, NULL) ---------------------------------------
setMethod(
  "..train_naive",
  signature(
    object = "familiarModel",
    data = "NULL"
  ),
  function(object, data, ...) {
    # Set a NULL model.
    object@model <- NULL

    return(object)
  }
)



# ..predict (familiarModel, dataObject) ----------------------------------------
setMethod(
  "..predict",
  signature(
    object = "familiarModel",
    data = "dataObject"
  ),
  function(object, data, type = "default", time = NULL, ...) {
    # Fallback method for missing or failing predictions.
    
    # Find the type of prediction table that should be created.
    prediction_table_type <- ..get_prediction_table_type(
      object = object,
      type = type
    )
    
    return(as_prediction_table(
      x = NULL,
      type = prediction_table_type,
      data = data,
      time = time,
      model_object = object
    ))
  }
)



# ..predict (character, dataObject) --------------------------------------------
setMethod(
  "..predict",
  signature(
    object = "character",
    data = "dataObject"
  ),
  function(object, data, ...) {
    # Load object.
    object <- load_familiar_object(object)

    return(do.call(
      ..predict,
      args = c(list(
        "object" = object,
        "data" = data
      ))
    ))
  }
)



# ..get_prediction_table_type (familiarModel) ----------------------------------
setMethod(
  "..get_prediction_table_type",
  signature(object = "familiarModel"),
  function(object, type, ...) {
    # This is the default option for familiar models. Learners that require more
    # specialised prediction table types should specify these types in their own
    # methods before calling this default method.
    prediction_table_type <- NULL
    if (type == "default") {
      if (object@outcome_type %in% c("binomial", "multinomial")) {
        prediction_table_type <- "classification"
        
      } else if (object@outcome_type %in% c("continuous")) {
        prediction_table_type <- "regression"
        
      } else if (object@outcome_type %in% c("survival")) {
        prediction_table_type <- "hazard_ratio"
        
      } else {
        ..error_outcome_type_not_implemented(object@outcome_type)
      }
      
    } else if (type == "survival_probability" && object@outcome_type == "survival") {
      prediction_table_type <- "survival_probability"
      
    } else {
      ..error_no_predictions_possible(object, type)
    }
    
    return(prediction_table_type)
  }
)




# ..set_calibration_info -------------------------------------------------------
setMethod(
  "..set_calibration_info",
  signature(object = "familiarModel"),
  function(object, data) {
    # This is a fall-back option.
    if (is.null(object@calibration_info)) object@calibration_info <- NULL

    return(object)
  }
)



# ..set_recalibration_model ----------------------------------------------------
setMethod(
  "..set_recalibration_model",
  signature(
    object = "familiarModel",
    data = "dataObject"
  ),
  function(object, data) {
    # This is a fall-back option.
    object@calibration_model <- NULL

    return(object)
  }
)



# ..set_risk_stratification_thresholds -----------------------------------------
setMethod(
  "..set_risk_stratification_thresholds",
  signature(
    object = "familiarModel",
    data = "dataObject"
  ),
  function(object, data) {
    
    if (
      object@outcome_type %in% c("survival", "competing_risk") &&
      model_is_trained(object)
    ) {
      
      object@km_info <- .find_survival_grouping_thresholds(
        object = object,
        data = data
      )
      
    } else {
      object@km_info <- NULL
    }

    return(object)
  }
)



# ..set_vimp_parameters --------------------------------------------------------
setMethod(
  "..set_vimp_parameters",
  signature(object = "familiarModel"),
  function(object, ...) {
    # This is a fall-back option.
    return(object)
  }
)



# ..vimp -----------------------------------------------------------------------
setMethod(
  "..vimp",
  signature(object = "familiarModel"),
  function(object, ...) {
    # This is a fall-back option.
    return(get_placeholder_vimp_table(
      vimp_method = object@learner,
      run_table = object@run_table
    ))
  }
)



# trim_model (familiarModel)----------------------------------------------------
setMethod(
  "trim_model",
  signature(object = "familiarModel"),
  function(object, timeout = 60000.0, ...) {
    # Do not trim the model if there is nothing to trim.
    if (!model_is_trained(object)) return(object)

    # Trim the model.
    trimmed_object <- .trim_model(object = object)

    # Skip further processing if the model object was not trimmed.
    if (!trimmed_object@is_trimmed) return(object)

    # Go over different functions.
    trimmed_object <- .replace_broken_functions(
      object = object,
      trimmed_object = trimmed_object,
      timeout = timeout
    )

    return(trimmed_object)
  }
)



# .trim_model (familiarModel)---------------------------------------------------
setMethod(
  ".trim_model",
  signature(object = "familiarModel"),
  function(object, ...) {
    # Default method for models that lack a more specific method.
    return(object)
  }
)



# requires_naive_model ---------------------------------------------------------
setMethod(
  "requires_naive_model",
  signature(object = "familiarModel"),
  function(object, ...) {
    # Determine if the model hyperparameters specify that a naive model should
    # be trained. This obviously does not work if there no hyperparameters to
    # speak of.
    if (!has_optimised_hyperparameters(object = object)) return(FALSE)
    
    # Check if the signature size hyperparameter exists.
    if (is.null(object@hyperparameters$sign_size)) return(FALSE)

    # Check if the no-features variable importance.
    if (object@vimp_method %in% .get_available_no_features_vimp_methods()) return(TRUE)

    # Check if the signature size is 0.
    return(all(object@hyperparameters$sign_size == 0L))
  }
)



# ..update_warnings-------------------------------------------------------------
setMethod(
  "..update_warnings",
  signature(object = "familiarModel"),
  function(object, messages) {
    # Update warnings attached to the object.
    object@messages$warning <- c(
      object@messages$warning,
      messages
    )

    return(object)
  }
)


# ..update_errors---------------------------------------------------------------
setMethod(
  "..update_errors",
  signature(object = "familiarModel"),
  function(object, messages) {
    # Update error attached to the object.
    object@messages$error <- c(
      object@messages$error,
      messages
    )

    return(object)
  }
)


# has_calibration_info ---------------------------------------------------------
setMethod(
  "has_calibration_info",
  signature(object = "familiarModel"),
  function(object) {
    return(!is.null(object@calibration_info))
  }
)



# set_model_features (familiarModel)--------------------------------------------
setMethod(
  "set_model_features",
  signature(object = "familiarModel"),
  function(
    object,
    minimise_footprint = FALSE,
    ...
  ) {
    # Get signature features. This is a list features after clustering.
    signature_features <- get_signature_features(object = object)

    # Find important features, i.e. those that constitute the signature either
    # individually or as part of a cluster. The resulting list of features are
    # features prior to clustering.
    model_features <- get_model_features(
      x = signature_features,
      is_clustered = TRUE,
      feature_info_list = object@feature_info
    )
    
    # Find novelty features. The resulting list of features are features prior
    # to clustering.
    novelty_features <- find_novelty_features(
      model_features = model_features,
      feature_info_list = object@feature_info
    )

    if (minimise_footprint) {
      # Find only features that are required for running the model.
      required_features <- union(model_features, novelty_features)
      
    } else {
      # Find features that are required for processing the data.
      required_features <- get_required_features(
        x = union(model_features, novelty_features),
        is_clustered = FALSE,
        feature_info_list = object@feature_info
      )
    }

    # Select only necessary feature info objects.
    available_feature_info <- names(object@feature_info) %in% required_features
    object@feature_info <- object@feature_info[available_feature_info]

    # Set feature-related attribute slots
    object@required_features <- required_features
    object@model_features <- model_features
    object@novelty_features <- novelty_features

    return(object)
  }
)



# get_signature_features (familiarModel)----------------------------------------
setMethod(
  "get_signature_features",
  signature(object = "familiarModel"),
  function(
    object
  ) {
    # Attempt to get signature directly from the object.
    if (!is_empty(object@model_features)) {
      # If model features have been set (i.e. using set_model_features), 
      # return those features instead. Since the model_features attribute stores
      # feature names prior to clustering, make sure to update these.
      return(features_after_clustering(
        features = object@model_features,
        feature_info_list = object@feature_info
      ))
    }

    # Get signature based on the stored feature information.
    return(.get_signature_features(object))
  }
)



.get_signature_features <- function(object) {
  # Suppress NOTES due to non-standard evaluation in data.table
  name <- rank <- NULL
  
  if (!(is(object, "familiarModel") || is(object, "familiarNoveltyDetector"))) {
    ..error_reached_unreachable_code(paste0("invalid object class: ", class(object)))
  }
  
  # Get signature size. This derives directly from the "sign_size"
  # hyperparameter. If absent, set signature size to infinite.
  signature_size <- object@hyperparameters$sign_size
  if (is_empty(signature_size)) signature_size <- Inf
  
  # Determine which features are pre-assigned to the signature.
  signature_features <- names(object@feature_info)[sapply(object@feature_info, is_in_signature)]
  
  if (object@vimp_method %in% .get_available_signature_only_vimp_methods()) {
    # Only select signature.
    if (length(signature_features) == 0L) {
      ..error(
        "No signature was provided.",
        error_class = "input_argument_error"
      )
    }
    
    selected_features <- signature_features
    
  } else if (object@vimp_method %in% .get_available_none_vimp_methods()) {
    # Select all features.
    selected_features <- features_after_clustering(
      features = get_available_features(feature_info_list = object@feature_info),
      feature_info_list = object@feature_info
    )
    
    # Order randomly so that there is no accidental dependency on order.
    selected_features <- fam_sample(
      x = selected_features,
      size = length(selected_features),
      replace = FALSE
    )
    
  } else if (object@vimp_method %in% .get_available_random_vimp_methods()) {
    # Select all features.
    selected_features <- features_after_clustering(
      features = get_available_features(feature_info_list = object@feature_info),
      feature_info_list = object@feature_info
    )
    
    # Shrink signature sizes that are too large.
    if (signature_size > length(selected_features)) {
      signature_size <- length(selected_features)
    }
    
    # Randomly pick the signature.
    selected_features <- fam_sample(
      x = selected_features,
      size = signature_size,
      replace = FALSE
    )
    
  } else if (object@vimp_method %in% .get_available_no_features_vimp_methods()) {
    # No features are selected.
    selected_features <- NULL
    
  } else {
    # Select signature and any additional features according to rank.
    selected_features <- signature_features
    
    # Get number remaining available features
    n_allowed_features <- signature_size - length(signature_features)
    
    # Check that features may be added, and the rank table is not empty.
    if (n_allowed_features > 0L && !is_empty(object@vimp_table)) {
      # Get available features.
      features <- features_after_clustering(
        features = get_available_features(feature_info_list = object@feature_info),
        feature_info_list = object@feature_info
      )
      
      # Remove signature features, if any, to prevent duplicates.
      features <- setdiff(features, signature_features)
      
      # Extract aggregated rank table. First, ensure that the associated cluster
      # table is correct.
      vimp_table <- update_vimp_table_to_reference(
        x = object@vimp_table,
        reference_cluster_table = .create_clustering_table(
          feature_info_list = object@feature_info
        )
      )
    
      # Recluster the data according to the clustering table corresponding to the
      # model. This ensures that the variable importance table has the features
      # that are seen by the model.
      vimp_table <- recluster_vimp_table(vimp_table)
      
      # Get aggregate variable importances
      vimp_table <- aggregate_vimp_table(
        vimp_table,
        aggregation_method = object@vimp_aggregation_method,
        rank_threshold = object@vimp_rank_threshold
      )
      
      if (is_empty(vimp_table)) return(signature_features)
      
      # Keep only feature ranks of feature corresponding to available
      # features, and order by rank.
      rank_table <- get_vimp_table(vimp_table)[name %in% features, ][order(rank)]
      
      # Add good features (low rank) to the selection
      selected_features <- c(
        signature_features,
        head(x = rank_table, n = n_allowed_features)$name
      )
    }
  }
  
  return(selected_features)
}



.get_available_risklike_prediction_types <- function() {
  return(c("hazard_ratio", "cumulative_hazard", "survival_probability"))
}