diff --git a/.Rbuildignore b/.Rbuildignore index 88526d9a..decfd80b 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,5 @@ ^tests/testthat/Rplots\.pdf$ ^tests/old_experiments$ ^Rplots\.pdf$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index 98fbb26c..e4aa4023 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ tests/testthat/Rplots.pdf /Meta/ tests/old_experiments/_experiment Rplots.pdf +.positai diff --git a/.lintr b/.lintr index 251a5dc3..49799997 100644 --- a/.lintr +++ b/.lintr @@ -1,7 +1,28 @@ linters: linters_with_defaults( + any_duplicated_linter(), + any_is_na_linter(), + boolean_arithmetic_linter(), + class_equals_linter(), + commented_code_linter = NULL, + duplicate_argument_linter(), + empty_assignment_linter(), + for_loop_index_linter(), + function_left_parentheses_linter(), + function_return_linter(), + implicit_assignment_linter(), + implicit_integer_linter(), + length_levels_linter(), + length_test_linter(), + lengths_linter(), line_length_linter(120), + missing_argument_linter(), + numeric_leading_zero_linter(), object_length_linter = NULL, - trailing_whitespace_linter = NULL, - cyclocomp_linter = NULL + object_name_linter = NULL, + outer_negation_linter(), + paste_linter(), + return_linter = NULL, + todo_comment_linter(), + trailing_whitespace_linter = NULL ) encoding: "UTF-8" diff --git a/DESCRIPTION b/DESCRIPTION index 6d5a8194..e32dbc29 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,18 +1,14 @@ Package: familiar Title: End-to-End Automated Machine Learning and Model Evaluation -Version: 1.5.0 +Version: 2.0.0 Authors@R: c( person("Alex", "Zwanenburg", email = "alexander.zwanenburg@nct-dresden.de", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-0342-9545")), person("Steffen", "Löck", role="aut"), - person("Stefan", "Leger", role="ctb"), - person("Iram", "Shahzadi", role="ctb"), - person("Asier", "Rabasco Meneghetti", role="ctb"), - person("Sebastian", "Starke", role="ctb"), - person("Technische Universität Dresden", role="cph"), - person("German Cancer Research Center (DKFZ)", role="cph")) + person("German Cancer Research Center (DKFZ)", role="cph"), + person("Technische Universität Dresden", role="cph")) Description: Single unified interface for end-to-end modelling of regression, categorical and time-to-event (survival) outcomes. Models created using familiar are self-containing, and their use does not require additional @@ -24,19 +20,19 @@ Description: Single unified interface for end-to-end modelling of regression, tabular format and plotted, and may also be computed manually using export and plot functions. Where possible, metrics and values obtained during the evaluation process come with confidence intervals. -URL: https://github.com/alexzwanenburg/familiar -BugReports: https://github.com/alexzwanenburg/familiar/issues +URL: https://github.com/oncoray/familiar +BugReports: https://github.com/oncoray/familiar/issues Depends: R (>= 4.0.0) License: EUPL Encoding: UTF-8 LazyData: true -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Roxygen: list(markdown = TRUE) VignetteBuilder: knitr Imports: data.table, methods, - rlang (>= 0.3.4), + rlang (>= 1.0.0), rstream, survival Suggests: @@ -47,35 +43,30 @@ Suggests: coro, dynamicTreeCut, e1071 (>= 1.7.5), - Ecdat, fastcluster, fastglm, - ggplot2 (>= 3.0.0), + ggplot2 (>= 4.0.0), glmnet, gtable, harmonicmeanp, - isotree (>= 0.3.0), + isotree (>= 0.6.0), knitr, labeling, laGP, - MASS, maxstat, - mboost (>= 2.9.0), microbenchmark, nnet, - partykit, + paletteer, power.transform, praznik, proxy, - qvalue, randomForestSRC, ranger, rmarkdown, scales, testthat (>= 3.0.0), xml2, - VGAM, - xgboost + xgboost (>= 3.0.0) Collate: 'FamiliarS4Classes.R' 'FamiliarS4Generics.R' @@ -97,7 +88,6 @@ Collate: 'DataProcessing.R' 'DataServerBackend.R' 'ErrorMessages.R' - 'Evaluation.R' 'ExperimentData.R' 'ExperimentSetup.R' 'Familiar.R' @@ -105,6 +95,8 @@ Collate: 'FamiliarCollectionExport.R' 'FamiliarData.R' 'FamiliarDataComputation.R' + 'FamiliarDataComputationPredictionData.R' + 'PredictionTable.R' 'FamiliarDataComputationAUCCurves.R' 'FamiliarDataComputationCalibrationData.R' 'FamiliarDataComputationCalibrationInfo.R' @@ -116,11 +108,12 @@ Collate: 'FamiliarDataComputationICE.R' 'FamiliarDataComputationModelPerformance.R' 'FamiliarDataComputationPermutationVimp.R' - 'FamiliarDataComputationPredictionData.R' 'FamiliarDataComputationRiskStratificationData.R' 'FamiliarDataComputationRiskStratificationInfo.R' + 'FamiliarDataComputationSHAP.R' 'FamiliarDataComputationSampleSimilarity.R' 'FamiliarDataComputationUnivariateAnalysis.R' + 'FamiliarDataComputationUtilities.R' 'FamiliarDataComputationVimp.R' 'FamiliarDataElement.R' 'FamiliarEnsemble.R' @@ -134,7 +127,6 @@ Collate: 'FamiliarVimpMethod.R' 'FeatureInfo.R' 'FeatureInfoParameters.R' - 'FeatureSelection.R' 'FunctionWrapperUtilities.R' 'HyperparameterOptimisation.R' 'HyperparameterOptimisationMetaLearners.R' @@ -147,6 +139,7 @@ Collate: 'Iterations.R' 'LearnerMain.R' 'LearnerRecalibration.R' + 'LearnerRiskStratification.R' 'LearnerS4Cox.R' 'LearnerS4GLM.R' 'LearnerS4GLMnet.R' @@ -158,7 +151,6 @@ Collate: 'LearnerS4SVM.R' 'LearnerS4SurvivalRegression.R' 'LearnerS4XGBoost.R' - 'LearnerSurvivalGrouping.R' 'LearnerSurvivalProbability.R' 'Logger.R' 'MetricS4.R' @@ -167,9 +159,8 @@ Collate: 'MetricS4ConcordanceIndex.R' 'MetricS4ConfusionMatrixMetrics.R' 'MetricS4Regression.R' - 'ModelBuilding.R' - 'NoveltyDetectorS4IsolationTree.R' 'NoveltyDetectorMain.R' + 'NoveltyDetectorS4IsolationTree.R' 'NoveltyDetectorS4NoneNoveltyDetector.R' 'OutcomeInfo.R' 'PairwiseSimilarity.R' @@ -182,6 +173,7 @@ Collate: 'PlotColours.R' 'PlotConfusionMatrix.R' 'PlotDecisionCurves.R' + 'PlotFamiliarPlot.R' 'PlotFeatureRanking.R' 'PlotFeatureSimilarity.R' 'PlotGTable.R' @@ -191,21 +183,36 @@ Collate: 'PlotModelPerformance.R' 'PlotPermutationVariableImportance.R' 'PlotSampleClustering.R' + 'PlotShapDependence.R' + 'PlotShapForce.R' + 'PlotShapSummary.R' + 'PlotShapWaterfall.R' 'PlotUnivariateImportance.R' 'PlotUtilities.R' 'PredictS4Methods.R' 'ProcessTimeUtilities.R' 'Random.R' - 'RandomGrouping.R' 'RankBordaAggregation.R' 'RankMain.R' 'RankSimpleAggregation.R' 'RankStabilityAggregation.R' 'SocketServer.R' 'StringUtilities.R' + 'TaskEvaluate.R' + 'TaskFeatureInfo.R' + 'TaskLearn.R' + 'TaskLearnerHyperparameters.R' + 'TaskMain.R' + 'TaskNoveltyDetector.R' + 'TaskNoveltyDetectorHyperparameters.R' + 'TaskVimp.R' + 'TaskVimpHyperparameters.R' 'TestDataCreators.R' + 'TestFeatureInfo.R' 'TestFunctions.R' - 'TrainS4Methods.R' + 'TestTrain.R' + 'TestTrainNovelty.R' + 'TestVimp.R' 'TrimUtilities.R' 'Utilities.R' 'UtilitiesS4.R' diff --git a/NAMESPACE b/NAMESPACE index ec094a7b..ef302870 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +export(as_prediction_table) export(coef) export(get_xml_config) export(plot_feature_selection_occurrence) @@ -56,9 +57,9 @@ exportMethods(export_univariate_analysis_data) exportMethods(get_class_names) exportMethods(get_data_set_names) exportMethods(get_feature_names) -exportMethods(get_fs_method_names) exportMethods(get_learner_names) exportMethods(get_risk_group_names) +exportMethods(get_vimp_method_names) exportMethods(get_vimp_table) exportMethods(plot_auc_precision_recall_curve) exportMethods(plot_auc_roc_curve) @@ -71,21 +72,26 @@ exportMethods(plot_kaplan_meier) exportMethods(plot_model_performance) exportMethods(plot_permutation_variable_importance) exportMethods(plot_sample_clustering) +exportMethods(plot_shap_dependence) +exportMethods(plot_shap_force) +exportMethods(plot_shap_summary) +exportMethods(plot_shap_waterfall) exportMethods(plot_univariate_importance) exportMethods(plot_variable_importance) exportMethods(predict) exportMethods(set_class_names) exportMethods(set_data_set_names) exportMethods(set_feature_names) -exportMethods(set_fs_method_names) exportMethods(set_learner_names) exportMethods(set_risk_group_names) +exportMethods(set_vimp_method_names) exportMethods(summary) exportMethods(update_model_dir_path) exportMethods(update_object) import(data.table) import(methods) importClassesFrom(rstream,rstream.runif) +importFrom(rlang,"%<~%") importFrom(rlang,enquo) importFrom(rlang,enquos) importFrom(rlang,ensym) diff --git a/NEWS.md b/NEWS.md index 9bb13af1..d4dbd5b2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,162 @@ +# Version 2.0.0 (Astonishing Anteater) + +## Breaking changes + +- Naming and on-disk location of variable importance tables, models, evaluated + datasets and collections, have changed. These are no longer nested to reduce + path lengths and avoid issues due to long path lengths, particularly on + Windows OS. + +- Ensembles are now no longer explicitly stored, but are formed at run-time. + +- Models now have and use new attributes related to variable importance that + cannot be obtained from models trained prior to version 2.0.0. Models trained + with version 1 cannot be assessed. You will need to reinstall version 1.5.0 of + familiar. + +## Major changes + +- SHAP values can now be computed with familiar. SHAP values can be directly + exported using the `export_shap` method. Moreover, familiar now supports four + types of SHAP plots: + + - Summary plots (`plot_shap_summary`) provide a global overview of the + relationship of feature values and SHAP-values. More impactful features + tend to have a wider range of SHAP-values. + + - Force plots (`plot_shap_force`) shows how positive and negative SHAP + values impact the predicted value. Specific features can be isolated. + + - Waterfall plots (`plot_shap_waterfall`) provide a detailed, local + overview of how each SHAP value contributes to the predicted value for each + sample. + + - SHAP dependence plots (`plot_shap_dependence`) show how the SHAP values + depend on values of a feature. Interactions with other features can be shown + as well. + +- Some functionality was deprecated because of redundancy and stability issues: + + - The `count` outcome type has been deprecated. `count` is a subset of + `continuous` outcomes. Its previous implementation did not provide any + benefits over `continuous`. + + - Gradient boosting using the `mboost` package was deprecated. Use `xgboost` + instead. + + - The `qvalue` package for computing q-values was deprecated. + + - The `VGAM` package, which has been soft-deprecated since version 1.3.0, has + now fully been deprecated. + + - The variable hunting feature selection method for random forests was removed + due to stability issues in unit tests. + + - The minimum depth feature selection method for random forests was removed + due to deprecation of the underlying function in `RandomForestSRC`. + +- Many evaluation steps that only require model predictions can now be called + externally by providing a `familiarDataElementPredictionTable` object that + contains model prediction data. Such objects can be created using the + `as_prediction_table` function. + +- Several configuration parameters were renamed to better reflect their actual use: + + - `fs_method` was renamed to `vimp_method`. + + - `fs_method_parameter` was renamed to `vimp_method_parameter`. + + - `parallel_feature_selection` was renamed to `parallel_vimp`. + +- It is now possible to build models without explicitly defining a variable + importance (feature selection) step. For example, + `experimental_design = mb + ev` is now valid and will result in training of a + single model on the development dataset with subsequent evaluation on an + external dataset. This is realised by using variable importance data obtained + during hyperparameter optimisation. + +## Minor changes + +- The `iteration_seed` configuration parameter was added to provide a fixed seed + for the sampling algorithms that create e.g. bootstraps, cross-validation, for + the experiment. Providing a seed allows for reproducing the sample division + across different experiments. + +- The `evaluation_elements` configuration parameter was added to allow for + specifying which evaluation steps should be performed. + +- Concordance variable importance for categorical outcomes now relies on the + internal implementation for the area under the receiver operating + characteristic curve instead of the Gini measure from the `corelearn` package. + +- Palettes from the `paletteer` package can now be used to customise plots. + +- The default palette was updated to use more vivid colours, particularly for + divergent and sequential palettes. The central part of the divergent palette, + and the starting grey for sequential palettes, are now darker for better + contrast with a white background. + +- Plausibility of datasets is now checked more thoroughly to detect common + issues: + + - The presence of duplicate rows with the same feature values and outcome. + + - The presence of one-to-one predictors of the outcome. This might be + outcome-related columns that have been left in the data accidentally. + + - The presence of invariant predictors. + +- Statistical tests now assess differences between batches if batch + normalisation is performed, and warns if the outcome in any batch is + significantly different from others. + +- The `n_important_features` parameter was introduced to limit the number of + features that are assessed during, e.g., permutation variable importance. + By default, this is limited to the 20 most important features. + +- The `ensemble` method is now used as `detail_level` for evaluating models if + the number of samples assessed for model is 10 or lower. This avoids an issue + where the `hybrid` method used as a default in several evaluation steps would + lead to too few samples to allow for assessment. This affected + Leave-One-Out-Cross-Validation (LOOCV) schemes in particular. + +- Added support for `ggplot2` version 4.0. Due to changes in how legends are + handled, the minimum `ggplot2` version is now `4.0.0`. + +- Some plot functions now have a `limit_n_features` argument, which limits the + number of features that appear in a plot. + +- Concordance index metrics for survival endpoints are now computed using + `survival::concordance` for improved performance. + +- `show` for familiar models now shows an (aggregated) variable importance table. + +- Checks on installed packages and their versions are now much more efficient. + Repeated look-up was expensive, and results are now cached instead. + +## Fixes + +- Fixed errors when creating feature or similarity plots caused by sample or + feature names matching internal column names. + +- The `sample_similarity` evaluation element is now mentioned in the documentation. + +- Variable importance methods and outcome information objects were missing a + familiar version attribute, which has now been added to ensure future + compatibility. + +- Some vignettes referred to `experiment_design` where `experimental_design` was + intended. + +- Fixed an error where naive models would yield an incorrect number of predicted + values when samples appear multiple times (e.g. in bootstraps). + +- Fixed an error when trying to identify features prior to clustering using + `features_before_clustering`. + +- Fixed an issue where the confidence intervals for Kaplan-Meier curves were + not shown correctly when using `conf_int_style = "step"`. + # Version 1.5.0 (Whole Whale) ## Major changes @@ -26,7 +185,7 @@ ## Bug fixes -- Adapted tests to work when packages are missing. +- Adapted tests to work when suggested packages are missing (addresses CRAN noSuggests check). - Fixed an issue that prevented hyperparameter optimisation of `xgboost` models for survival tasks. @@ -40,7 +199,7 @@ - Plot margins are now correctly set in the default familiar plotting theme. - Plot elements of composite plots are now correctly set. - + - Fixed an incorrect data.table merge when computing survival predictions from random forests. # Version 1.4.6 (Talented Toad) diff --git a/R/BatchNormalisation.R b/R/BatchNormalisation.R index 5faac16b..1b9f0dc7 100644 --- a/R/BatchNormalisation.R +++ b/R/BatchNormalisation.R @@ -3,7 +3,7 @@ NULL - +# batch normalisation container ------------------------------------------------ setClass( "featureInfoParametersBatchNormalisationContainer", contains = "featureInfoParameters", @@ -11,12 +11,15 @@ setClass( "method" = "character", "batch_parameters" = "ANY", "type" = "character", - "available" = "logical"), + "available" = "logical" + ), prototype = list( "method" = NA_character_, "batch_parameters" = NULL, "type" = NA_character_, - "available" = NA)) + "available" = NA + ) +) .get_available_batch_normalisation_methods <- function(type = "all") { @@ -27,13 +30,15 @@ setClass( if (type %in% c("combat", "combat_non_parametric", "all")) { available_methods <- c( available_methods, - .get_available_combat_parametric_normalisation_methods()) + .get_available_combat_parametric_normalisation_methods() + ) } if (type %in% c("combat", "combat_parametric", "all")) { available_methods <- c( available_methods, - .get_available_combat_non_parametric_normalisation_methods()) + .get_available_combat_non_parametric_normalisation_methods() + ) } return(available_methods) @@ -45,7 +50,8 @@ create_batch_normalisation_parameter_skeleton <- function( feature_info_list, feature_names = NULL, normalisation_method, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Creates a skeleton for the provided batch normalisation method. @@ -53,9 +59,7 @@ create_batch_normalisation_parameter_skeleton <- function( if (is.null(feature_names)) feature_names <- names(feature_info_list) # Select only features that appear in the feature info list. - feature_names <- intersect( - names(feature_info_list), - feature_names) + feature_names <- intersect(names(feature_info_list), feature_names) # Skip step if no feature info objects are updated. if (is_empty(feature_names)) return(feature_info_list) @@ -64,14 +68,16 @@ create_batch_normalisation_parameter_skeleton <- function( .check_parameter_value_is_valid( x = normalisation_method, var_name = "normalisation_method", - values = .get_available_batch_normalisation_methods()) + values = .get_available_batch_normalisation_methods() + ) # Update familiar info objects with a feature normalisation skeleton. updated_feature_info <- fam_lapply( X = feature_info_list[feature_names], FUN = .create_batch_normalisation_parameter_skeleton, method = normalisation_method, - .override_existing = .override_existing) + .override_existing = .override_existing + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -87,7 +93,8 @@ create_batch_normalisation_parameter_skeleton <- function( .create_batch_normalisation_parameter_skeleton <- function( feature_info, method, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Check if normalisation data was already completed, and does not require # being determined anew. @@ -100,7 +107,8 @@ create_batch_normalisation_parameter_skeleton <- function( feature_name = feature_info@name, feature_type = feature_info@feature_type, method = method, - available = is_available(feature_info)) + available = is_available(feature_info) + ) # Update normalisation_parameters slot. feature_info@batch_normalisation_parameters <- object @@ -114,7 +122,8 @@ create_batch_normalisation_parameter_skeleton <- function( method, feature_name, feature_type = "numeric", - available = TRUE) { + available = TRUE +) { # This is the lowest level function for creating batch normalisation parameter # skeletons. @@ -127,7 +136,8 @@ create_batch_normalisation_parameter_skeleton <- function( "featureInfoParametersBatchNormalisationContainer", "method" = method, "type" = feature_type, - "available" = available) + "available" = available + ) # Set the name of the object. object@name <- feature_name @@ -144,7 +154,8 @@ add_batch_normalisation_parameters <- function( cl = NULL, feature_info_list, data, - verbose = FALSE) { + verbose = FALSE +) { # Determine normalisation parameters and add them to the feature_info_list. # Find feature columns. @@ -154,13 +165,15 @@ add_batch_normalisation_parameters <- function( if (!(setequal(feature_names, get_available_features(feature_info_list = feature_info_list)))) { ..error_reached_unreachable_code(paste0( "add_transformation_parameters: features in data and in the feature_info_list are ", - "expected to be the same, but were not.")) + "expected to be the same, but were not." + )) } # Identify methods specified by the containers for different features. container_batch_methods <- sapply( feature_info_list[feature_names], - function(x) (x@batch_normalisation_parameters@method)) + function(x) (x@batch_normalisation_parameters@method) + ) # Iterate over methods. The names of features that are assessed using the same # batch normalisation method are dispatched to ensure computation within that @@ -177,21 +190,24 @@ add_batch_normalisation_parameters <- function( # over and over again. z <- .compute_combat_batch_normalisation_z_matrix( data = data@data, - feature_names = batch_method_feature_names) + feature_names = batch_method_feature_names + ) if (container_batch_method %in% .get_available_batch_normalisation_methods(type = "combat_parametric")) { # Obtain ComBat data using the parametric solver. batch_parameter_data <- .combat_iterative_parametric_bayes_solver( z = z, cl = cl, - progress_bar = FALSE) + progress_bar = FALSE + ) } else { # Obtain ComBat data using the non-parametric solver. batch_parameter_data <- .combat_iterative_parametric_bayes_solver( z = z, cl = cl, - progress_bar = FALSE) + progress_bar = FALSE + ) } } else { @@ -206,10 +222,11 @@ add_batch_normalisation_parameters <- function( data = data@data[, mget(batch_method_feature_names)], MoreArgs = list( "batch_column_data" = data@data[[get_id_columns("batch", single_column = TRUE)]], - "batch_parameter_data" = batch_parameter_data), + "batch_parameter_data" = batch_parameter_data + ), progress_bar = verbose, - chopchop = TRUE) - + chopchop = TRUE + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- batch_method_feature_names @@ -227,28 +244,15 @@ add_batch_normalisation_parameters <- function( feature_info, data, batch_column_data, - batch_parameter_data = NULL) { - - # Combine data and batch column data into a data.table again. The primary - # reason for splitting is to prevent dispatching the full dataset to each - # node. - data <- data.table::data.table( - "batch_column_id" = batch_column_data, - "feature_value" = data) - - # Rename columns to original names. - data.table::setnames( - data, - old = c("batch_column_id", "feature_value"), - new = c( - get_id_columns("batch", single_column = TRUE), - feature_info@batch_normalisation_parameters@name)) - + batch_parameter_data = NULL +) { # Pass to underlying function that adds the feature info. object <- add_feature_info_parameters( object = feature_info@batch_normalisation_parameters, data = data, - batch_parameter_data = batch_parameter_data) + batch_column_data = batch_column_data, + batch_parameter_data = batch_parameter_data + ) # Update normalisation_parameters slot. feature_info@batch_normalisation_parameters <- object @@ -258,36 +262,20 @@ add_batch_normalisation_parameters <- function( -# add_feature_info_parameters (container, data object) ------------------------- +# add_feature_info_parameters (container, numeric) ----------------------------- setMethod( "add_feature_info_parameters", - signature(object = "featureInfoParametersBatchNormalisationContainer", data = "dataObject"), + signature(object = "featureInfoParametersBatchNormalisationContainer", data = "numeric"), function( object, data, - ...) { - # Pass to method with signature data=data.table. - return(add_feature_info_parameters( - object = object, - data = data@data, - ...)) - } -) - - -# add_feature_info_parameters (container, data.table) -------------------------- -setMethod( - "add_feature_info_parameters", - signature(object = "featureInfoParametersBatchNormalisationContainer", data = "data.table"), - function( - object, - data, - ...) { - + batch_column_data, + ... + ) { ## Populate container with batch parameter objects ------------------------- # Find the batch identifiers in the data. - batch_ids <- unique(data[[get_id_columns(id_depth = "batch")]]) + batch_ids <- unique(batch_column_data) # Determine which normalisation objects already exist. visited_batch <- names(object@batch_parameters) @@ -295,7 +283,7 @@ setMethod( # Remove batches that were already created. batch <- setdiff(batch_ids, visited_batch) - if (length(batch) > 0) { + if (length(batch) > 0L) { # Create batch objects. normalisation_objects <- fam_mapply( FUN = ..create_normalisation_parameter_skeleton, @@ -304,7 +292,9 @@ setMethod( "feature_name" = object@name, "feature_type" = object@type, "available" = object@available, - "method" = object@method)) + "method" = object@method + ) + ) # Set names. names(normalisation_objects) <- batch @@ -312,7 +302,8 @@ setMethod( # Append to the batch parameters. object@batch_parameters <- c( object@batch_parameters, - normalisation_objects) + normalisation_objects + ) } ## Determine batch parameters ---------------------------------------------- @@ -320,15 +311,17 @@ setMethod( # Select normalisation objects that have not been completed. batch_to_update <- intersect( names(object@batch_parameters)[!sapply(object@batch_parameters, feature_info_complete)], - batch_ids) + batch_ids + ) - if (length(batch_to_update) > 0) { + if (length(batch_to_update) > 0L) { # Determine normalisation parameters within each batch. normalisation_objects <- fam_mapply( FUN = add_feature_info_parameters, object = object@batch_parameters[batch_to_update], - data = split(data, by = get_id_columns(id_depth = "batch"))[batch_to_update], - MoreArgs = c(list(...))) + data = split(data, f = batch_column_data)[batch_to_update], + MoreArgs = list(...) + ) # Set names names(normalisation_objects) <- batch_to_update @@ -344,32 +337,34 @@ setMethod( # small batches, attempt to replace them by an average object. batch_to_check <- intersect(batch, batch_to_update) - if (length(batch_to_check) > 0 && object@method != "none") { + if (length(batch_to_check) > 0L && object@method != "none") { # Generate a new object. replacement_normalisation_object <- ...collect_and_aggregate_normalisation_info( object_list = object@batch_parameters, instance_mask = rep_len(TRUE, length(object@batch_parameters)), - feature_name = object@name)$parameters + feature_name = object@name + )$parameters # Identify which new objects are none objects. batch_to_check <- batch_to_check[sapply( object@batch_parameters[batch_to_check], is, - class2 = "featureInfoParametersNormalisationNone")] + class2 = "featureInfoParametersNormalisationNone" + )] - if (length(batch_to_check) > 0) { + if (length(batch_to_check) > 0L) { # Add batch attribute to normalisation objects. normalisation_objects <- lapply( batch_to_check, function(x, object) { - # Add batch name object@batch <- x return(object) }, - object = replacement_normalisation_object) + object = replacement_normalisation_object + ) # Update names. names(normalisation_objects) <- batch_to_check @@ -383,7 +378,8 @@ setMethod( if (!all(sapply(object@batch_parameters, feature_info_complete))) { ..error_reached_unreachable_code(paste0( "add_feature_info_parameters,featureInfoParametersBatchNormalisationContainer, data.table: ", - "all normalisation objects in the container should be complete, but some were not.")) + "all normalisation objects in the container should be complete, but some were not." + )) } # Mark complete. @@ -394,6 +390,7 @@ setMethod( ) + # apply_feature_info_parameters (container, ANY) ------------------------------- setMethod( "apply_feature_info_parameters", @@ -401,20 +398,25 @@ setMethod( function( object, data, - ...) { + batch_data, + ... + ) { + + if (object@method == "none") return(data) # Suppress NOTES due to non-standard evaluation in data.table batch_normalisation_ordering_id <- NULL # Find the batch identifiers in the data. - batch_ids <- unique(data[[get_id_columns(id_depth = "batch")]]) + batch_ids <- unique(batch_data) # Sanity check: batch normalisation objects are available for all # batch identifiers. if (!all(batch_ids %in% names(object@batch_parameters))) { ..error_reached_unreachable_code(paste0( "apply_feature_info_parameters,featureInfoParametersBatchNormalisationContainer,ANY: ", - "Batch normalisation objects are missing for one or more batches.")) + "Batch normalisation objects are missing for one or more batches." + )) } # Sanity check: all relevant batch normalisation objects are @@ -422,11 +424,18 @@ setMethod( if (!all(sapply(object@batch_parameters[batch_ids], feature_info_complete))) { ..error_reached_unreachable_code(paste0( "apply_feature_info_parameters,featureInfoParametersBatchNormalisationContainer,ANY: ", - "One or more batch normalisation objects are incomplete and may be missing parameters.")) + "One or more batch normalisation objects are incomplete and may be missing parameters." + )) } # Avoid updating by reference. - data <- data.table::copy(data) + data <- data.table::data.table( + "feature" = data, + "batch_id" = batch_data + ) + + # Set feature name. + data.table::setnames(data, old = "feature", new = object@name) # Insert ordering variable. data[, "batch_normalisation_ordering_id" := .I] @@ -435,8 +444,9 @@ setMethod( data <- fam_mapply( FUN = apply_feature_info_parameters, object = object@batch_parameters[batch_ids], - data = split(data, by = get_id_columns(id_depth = "batch"))[batch_ids], - MoreArgs = list(...)) + data = split(data, by = "batch_id")[batch_ids], + MoreArgs = list(...) + ) # Combine into a single data.table. data <- data.table::rbindlist(data, use.names = TRUE) @@ -454,7 +464,8 @@ setMethod( ..collect_and_aggregate_batch_normalisation_info <- function( feature_info_list, instance_mask, - feature_name) { + feature_name +) { # Aggregate batch normalisation parameters. This function exists so that it # can be tested as part of a unit test. @@ -462,12 +473,12 @@ setMethod( batch_ids <- unique(unlist(lapply( feature_info_list, function(x) { - # Return NULL if parameters are missing. if (is.null(x@batch_normalisation_parameters)) return(NULL) return(names(x@batch_normalisation_parameters@batch_parameters)) - }))) + } + ))) # Main batch method main_batch_method <- unique(unlist(lapply( @@ -477,12 +488,14 @@ setMethod( if (is.null(x@batch_normalisation_parameters)) return(NULL) return(x@batch_normalisation_parameters@method) - }))) + } + ))) # Create parameter container batch_parameter_container <- ..create_batch_normalisation_parameter_skeleton( - method = main_batch_method[1], - feature_name = feature_name) + method = main_batch_method[1L], + feature_name = feature_name + ) if (!any(instance_mask)) { # Create placeholder objects. @@ -492,9 +505,11 @@ setMethod( ..create_normalisation_parameter_skeleton( feature_name = feature_name, method = "none", - batch = batch) + batch = batch + ) }, - feature_name = feature_name) + feature_name = feature_name + ) # Add names. names(batch_normalisation_objects) <- batch_ids @@ -504,7 +519,8 @@ setMethod( return(list( "parameters" = batch_parameter_container, - "instance_mask" = instance_mask)) + "instance_mask" = instance_mask + )) } # Initialise list of objects. @@ -523,13 +539,15 @@ setMethod( # Return parameters for the specific batch. return(x@batch_normalisation_parameters@batch_parameters[[batch_id]]) }, - batch_id = batch_id) + batch_id = batch_id + ) # Collect aggregate object. batch_normalision_object_list[[batch_id]] <- ...collect_and_aggregate_normalisation_info( object_list = batch_normalisation_objects, instance_mask = rep_len(TRUE, length(batch_normalisation_objects)), - feature_name = feature_name)$parameters + feature_name = feature_name + )$parameters # Set batch name. batch_normalision_object_list[[batch_id]]@batch <- batch_id @@ -540,5 +558,102 @@ setMethod( return(list( "parameters" = batch_parameter_container, - "instance_mask" = instance_mask)) + "instance_mask" = instance_mask + )) +} + + + +.check_batch_normalisation_assumptions <- function( + data, + normalisation_method +) { + # Check that batches do not differ in outcome data. We can use the following + # tests: + # + # * Continuous: Kruskal-Wallis-test. + # * Binomial / multinomial: Chi-squared test. + # * Survival: Log-rank test. + + if (all(normalisation_method == "none")) return(invisible(TRUE)) + + x <- data@data[, mget(get_outcome_columns(data))] + g <- data@data[[get_id_columns("batch", single_column = TRUE)]] + + # Determine the number of batches. + n_groups <- data.table::uniqueN(g) + # Check that 2 (or more groups) are present. + if (n_groups < 2L) return(invisible(TRUE)) + + if (data@outcome_type == "continuous") { + h <- tryCatch( + stats::kruskal.test( + x = x[[1L]], + g = g, + na.action = "na.omit" + ), + error = identity + ) + + # Check if the test statistic could be computed. + if (inherits(h, "error")) return(invisible(TRUE)) + p_value <- h$p.value + + } else if (data@outcome_type %in% c("binomial", "multinomial")) { + h <- tryCatch( + stats::chisq.test(x = x, y = g), + error = identity + ) + + # Check if the test statistic could be computed. + if (inherits(h, "error")) return(invisible(TRUE)) + p_value <- h$p.value + + } else if (data@outcome_type == "survival") { + + # Determine chi-square of log-rank test + chi_sq <- tryCatch( + survival::survdiff( + survival::Surv(time = outcome_time, event = outcome_event) ~ group, + data = data.table::data.table( + outcome_time = x$outcome_time, + outcome_event = x$outcome_event, + group = g + ), + subset = NULL, + na.action = "na.omit" + )$chisq, + error = identity + ) + + # Check if the test statistic could be computed. Causes could be lack of + # events, no events beyond the first time point, etc. + if (inherits(chi_sq, "error")) return(invisible(TRUE)) + + # Derive p-value + p_value <- stats::pchisq( + q = chi_sq, + df = n_groups - 1L, + lower.tail = FALSE + ) + + } else { + ..error_outcome_type_not_implemented(data@outcome_type) + } + + if (p_value < 0.05) { + logger_warning( + paste0( + "One or more batches have a statistically significant (p < 0.05) different outcome ", + "compared to other batches. Note: a statistically significant outcome does ", + "not mean that the difference is actually relevant. However, please assert ", + "that batch normalisation does not remove important differences between batches." + ), + warn_class = "familiar_batch_outcome_difference" + ) + return(invisible(FALSE)) + } + + + return(invisible(TRUE)) } diff --git a/R/BootstrapConfidenceInterval.R b/R/BootstrapConfidenceInterval.R index efba7029..c8d8bb5e 100644 --- a/R/BootstrapConfidenceInterval.R +++ b/R/BootstrapConfidenceInterval.R @@ -10,36 +10,51 @@ confidence_level = NULL, percentiles = NULL, bootstrap_ci_method = "percentile", - ...) { + ... +) { # Test confidence level if (!is.null(confidence_level)) { if (confidence_level >= 1.0) { - stop("A 100% confidence interval does not exist.") + ..error( + "A 100% confidence interval does not exist.", + error_class = "input_argument_error" + ) } else if (confidence_level <= 0.0) { - stop("The confidence interval cannot be smaller than 0.") + ..error( + "The confidence interval cannot be smaller than 0.", + error_class = "input_argument_error" + ) } # Compute percentiles from confidence level, and add the median. percentiles <- c( 0.5, (1.0 - confidence_level) / 2.0, - 1.0 - (1.0 - confidence_level) / 2.0) + 1.0 - (1.0 - confidence_level) / 2.0 + ) } if (!is.null(percentiles)) { if (any(percentiles > 1.0)) { - stop("Percentiles cannot be greater than 1.") + ..error( + "Percentiles cannot be greater than 1.", + error_class = "input_argument_error" + ) } else if (any(percentiles < 0.0)) { - stop("Percentiles cannot be smaller than 0.") + ..error( + "Percentiles cannot be smaller than 0.", + error_class = "input_argument_error" + ) } } if (is.null(confidence_level) && is.null(percentiles)) { ..error_reached_unreachable_code( - "..bootstrap_ic: confidence_interval and percentiles arguments cannot both be NULL.") + "..bootstrap_ic: confidence_interval and percentiles arguments cannot both be NULL." + ) } # For values that are not numeric, return mode. Note that the name "median" is @@ -59,12 +74,13 @@ # percentiles. Determine the number of decimal digits that should be used to # parse the numbers (minimum 2). percentile_names_digits <- nchar(sub(".*\\.", "", percentiles)) - percentile_names_digits <- max(c(percentile_names_digits, 2)) + percentile_names_digits <- max(c(percentile_names_digits, 2L)) # Set percentile names by passing them through the column name # checker. percentile_names <- .replace_illegal_column_name( - paste0("q_", format(percentiles, nsmall = percentile_names_digits))) + paste0("q_", format(percentiles, nsmall = percentile_names_digits)) + ) } # Create an empty list. @@ -74,10 +90,10 @@ # Select finite values. x <- x[is.finite(x)] - if (length(x) == 0) return(empty_list) + if (length(x) == 0L) return(empty_list) # If no x_0 is provided, the percentile method should be used. - if (length(x_0) == 0) bootstrap_ci_method <- "percentile" + if (length(x_0) == 0L) bootstrap_ci_method <- "percentile" if (bootstrap_ci_method == "percentile") { # Follows the percentile method of Efron, B. & Hastie, T. Computer Age @@ -87,7 +103,8 @@ percentile_values <- stats::quantile( x, probs = percentiles, - names = FALSE) + names = FALSE + ) # Generate a summary list summary_list <- as.list(percentile_values) @@ -96,8 +113,10 @@ } else if (bootstrap_ci_method == "bc") { # Follows the bias-corrected (BC) method of Efron, B. & Hastie, T. Computer # Age Statistical Inference. (Cambridge University Press, 2016). - if (length(x_0) > 1) { - stop(paste0("The full-data estimate should have length 1. Found: length ", length(x_0), ".")) + if (length(x_0) > 1L) { + ..error( + "The full-data point estimate should have length 1. Found: length ", length(x_0), "." + ) } if (!is.finite(x_0)) return(empty_list) @@ -114,7 +133,8 @@ x_0 = x_0, confidence_level = confidence_level, percentiles = percentiles, - bootstrap_ci_method = "percentile") + bootstrap_ci_method = "percentile" + ) return(summary_list) } @@ -129,7 +149,8 @@ percentile_values <- stats::quantile( x, probs = bc_percentiles, - names = FALSE) + names = FALSE + ) # Generate a summary list summary_list <- as.list(percentile_values) @@ -148,7 +169,7 @@ # Select finite values. x <- x[is.finite(x)] - if (length(x) == 0) return(empty_list) + if (length(x) == 0L) return(empty_list) # Compute the median value over the bootstraps. if (is.numeric(x)) { @@ -158,20 +179,19 @@ # Determine the mean average risk group. This requires discretisation # as rounding toward the nearest group would overinflate center groups. x_levels <- levels(x) - n <- length(x) + n <- nlevels(x) # Discretise bins floor((mu - 1) / ((n-1) / n)) + 1. See fixed bin size # discretisation. - x_num <- floor(n * (mean(as.numeric(x), na.rm = TRUE) - 1) / (n - 1)) + 1 + x_num <- floor(n * (mean(as.numeric(x), na.rm = TRUE) - 1.0) / (n - 1.0)) + 1.0 # Check if the x_num still falls within the range. x_num <- ifelse(x_num > n, n, x_num) # Re-encode and add to list. - summary_list <- list("median" = factor( - x_levels[x_num], - levels = x_levels, - ordered = TRUE)) + summary_list <- list( + "median" = factor(x_levels[x_num], levels = x_levels, ordered = TRUE) + ) } else { summary_list <- list("median" = get_mode(x)) diff --git a/R/CheckArguments.R b/R/CheckArguments.R index 615938ed..d2842eb3 100644 --- a/R/CheckArguments.R +++ b/R/CheckArguments.R @@ -1,15 +1,20 @@ -.check_dots_is_parameter <- function(dots) { +.check_dots_is_parameter <- function(dots, call = rlang::caller_env()) { - if (length(dots) > 0) { + if (length(dots) > 0L) { # Find unmatched arguments. unmatched_args <- setdiff(dots, .get_all_parameter_names()) - if (length(unmatched_args) > 0) { - stop(paste0( - "Configuration: one or more function arguments could not be matched ", - "to arguments passed by summon_familiar as configuration parameters: ", - paste_s(unmatched_args), - "\nThese arguments may have been misspelled, or were deprecated or renamed.")) + if (length(unmatched_args) > 0L) { + ..error( + paste0( + "Configuration: one or more function arguments could not be matched ", + "to arguments passed by summon_familiar as configuration parameters: ", + paste_s(unmatched_args), + "\nThese arguments may have been misspelled, or were deprecated or renamed." + ), + error_class = "input_argument_error", + call = call + ) } } @@ -18,7 +23,7 @@ -.check_configuration_tag_is_parameter <- function(config) { +.check_configuration_tag_is_parameter <- function(config, call = rlang::caller_env()) { if (!is.null(config)) { # Find names of parent nodes. @@ -27,30 +32,38 @@ # Find nodes that are specified differently by the user. unmatched_node_names <- setdiff( config_node_names, - .get_all_configuration_parent_node_names()) + .get_all_configuration_parent_node_names() + ) - if (length(unmatched_node_names) > 0) { - stop(paste0( - "Configuration: one or more parent nodes in the configuration file could not be matched ", - "to node names used by summon_familiar to group configuration parameters: ", - paste_s(unmatched_node_names), - "\nThese node names may have been misspelled, or were deprecated or renamed.")) + if (length(unmatched_node_names) > 0L) { + ..error( + paste0( + "Configuration: one or more parent nodes in the configuration file could not be matched ", + "to node names used by summon_familiar to group configuration parameters: ", + paste_s(unmatched_node_names), + "\nThese node names may have been misspelled, or were deprecated or renamed." + ), + error_class = "input_argument_error", + call = call + ) } # Find names of configuration arguments. config_args <- unique(unlist(sapply(config, names))) # Find unmatched arguments. - unmatched_args <- setdiff( - config_args, - .get_all_parameter_names()) + unmatched_args <- setdiff(config_args, .get_all_parameter_names()) - if (length(unmatched_args) > 0) { - stop(paste0( + if (length(unmatched_args) > 0L) { + ..error(paste0( "Configuration: one or more parameters set in the configuration file could not be matched ", "to arguments passed by summon_familiar as configuration parameters: ", paste_s(unmatched_args), - "\nThese parameters may have been misspelled, or were deprecated or renamed.")) + "\nThese parameters may have been misspelled, or were deprecated or renamed." + ), + error_class = "input_argument_error", + call = call + ) } } @@ -59,31 +72,90 @@ +.check_is_numeric <- function( + x, + var_name, + call = rlang::caller_env() +) { + if (!is.numeric(x)) { + ..error_type_not_valid( + x = x, + var_name = var_name, + valid_type = "numeric", + call = call + ) + } + + return(x) +} + + + +.check_is_integer <- function( + x, + var_name, + call = rlang::caller_env() +) { + if (!is.integer(x)) { + ..error_type_not_valid( + x = x, + var_name = var_name, + valid_type = "integer", + call = call + ) + } +} + + + +.check_is_integerish <- function( + x, + var_name, + call = rlang::caller_env() +) { + # Less strict than .check_is_integer, i.e. the check would return pass for + # 2.0, but fail for 2.5 or anything not numeric. + if (!rlang::is_integerish(x)) { + ..error_type_not_valid( + x = x, + var_name = var_name, + valid_type = "integer or numeric castable to integer (e.g. 3.0)", + call = call + ) + } +} + + + .check_number_in_valid_range <- function( x, var_name, range, - closed = c(TRUE, TRUE)) { + closed = c(TRUE, TRUE), + call = rlang::caller_env() +) { # Interpret single input range value as range containing only one value. - if (length(range) == 1) range <- c(range, range) + if (length(range) == 1L) range <- c(range, range) # Set lower limit to -Inf - if (is.na(range[1])) range[1] <- -Inf + if (is.na(range[1L])) range[1L] <- -Inf # Set upper limit to Inf - if (is.na(range[2])) range[2] <- Inf + if (is.na(range[2L])) range[2L] <- Inf # Some internal checks that should never be triggered. - if (length(x) != 1) { + if (length(x) != 1L) { ..error_reached_unreachable_code(paste0( - ".check_number_in_valid_range: x does not have length 1.")) + ".check_number_in_valid_range: x does not have length 1." + )) } # Another internal checks that should never be triggered. - if (range[2] - range[1] < 0.0) { + if (range[2L] - range[1L] < 0.0) { ..error_reached_unreachable_code(paste0( - ".check_number_in_valid_range: the range is inverted")) + ".check_number_in_valid_range: the range is inverted" + )) } # Check that x is numeric or NA. @@ -91,11 +163,21 @@ ..error_type_not_valid( x = x, var_name = var_name, - valid_type = "numeric") + valid_type = "numeric", + call = call + ) } if (!is.na(x)) { - is_outside_range <- ifelse(closed[1], x < range[1], x <= range[1]) || ifelse(closed[2], x > range[2], x >= range[2]) + is_outside_range <- ifelse( + closed[1L], + x < range[1L], + x <= range[1L] + ) || ifelse( + closed[2L], + x > range[2L], + x >= range[2L] + ) } else { # NA-values are outside the valid range. @@ -106,7 +188,9 @@ ..error_value_outside_allowed_range( x = x, var_name = var_name, - range = range) + range = range, + call = call + ) } return(invisible(TRUE)) @@ -118,17 +202,21 @@ x, y, var_name_x, - var_name_y) { + var_name_y, + call = rlang::caller_env() +) { # If either or both are NULL, return NULL if (is.null(x) || is.null(y)) return(NULL) overlap_values <- intersect(x, y) - if (length(overlap_values) > 0) { + if (length(overlap_values) > 0L) { ..error_value_shared_between_variables( x = x, y = y, var_name_x = var_name_x, - var_name_y = var_name_y) + var_name_y = var_name_y, + call = call + ) } return(invisible(TRUE)) @@ -139,19 +227,25 @@ .check_argument_length <- function( x, var_name, - min = 0, - max = Inf) { + min = 0L, + max = Inf, + call = rlang::caller_env() +) { if (length(x) < min) { ..error_variable_has_too_few_values( x = x, var_name = var_name, - req_length = c(min, max)) + req_length = c(min, max), + call = call + ) } else if (length(x) > max) { ..error_variable_has_too_many_values( x = x, var_name = var_name, - req_length = c(min, max)) + req_length = c(min, max), + call = call + ) } return(invisible(TRUE)) @@ -162,17 +256,19 @@ .check_parameter_value_is_valid <- function( x, var_name, - values) { + values, + call = rlang::caller_env() +) { # Check if NULL is an allowed value - null_allowed <- ifelse(any(is.null(values)), TRUE, FALSE) + null_allowed <- any(is.null(values)) - if (length(x) == 1) { + if (length(x) == 1L) { # Check if x is NULL if (is.null(x) && null_allowed) { # If x is NULL and this is allowed, return to parent function - return(NULL) + return(invisible(TRUE)) } } @@ -181,7 +277,9 @@ ..error_value_not_allowed( x = x, var_name = var_name, - values = values) + values = values, + call = call + ) } if (!all(x %in% values)) { @@ -189,7 +287,9 @@ ..error_value_not_allowed( x = x, var_name = var_name, - values = values) + values = values, + call = call + ) } return(invisible(TRUE)) @@ -202,7 +302,8 @@ to_type, var_name, req_length, - allow_more = FALSE) { + allow_more = FALSE +) { # Specify conversion functions if (to_type %in% c("character", "factor")) { @@ -222,27 +323,30 @@ } else { ..error_reached_unreachable_code(paste0( - ".perform_type_conversion: the to_type argument was not recognised: ", to_type)) + ".perform_type_conversion: the to_type argument was not recognised: ", to_type + )) } # Attempt conversion x <- tryCatch( conv_function(x), warning = function(war) { - ..error_type_conversion_not_possible( - x = x, - to_type = to_type, - var_name = var_name, - req_length = req_length, - allow_more = allow_more) + ..error_type_conversion_not_possible( + x = x, + to_type = to_type, + var_name = var_name, + req_length = req_length, + allow_more = allow_more + ) }, error = function(err) { - ..error_type_conversion_not_possible( - x = x, - to_type = to_type, - var_name = var_name, - req_length = req_length, - allow_more = allow_more) + ..error_type_conversion_not_possible( + x = x, + to_type = to_type, + var_name = var_name, + req_length = req_length, + allow_more = allow_more + ) } ) @@ -252,14 +356,16 @@ x = x, var_name = var_name, req_length = req_length, - allow_more = allow_more) + allow_more = allow_more + ) } else if (length(x) > req_length && !allow_more) { ..error_variable_has_too_many_values( x = x, var_name = var_name, req_length = req_length, - allow_fewer = FALSE) + allow_fewer = FALSE + ) } return(x) @@ -273,7 +379,8 @@ var_name, type, optional = FALSE, - default = NULL) { + default = NULL +) { # There are two options for parsing a value: # 1. Using a configuration file (through x_config) @@ -291,19 +398,21 @@ x <- x_config # Trim whitespace and split variables - if (type %in% c("character_list", "numeric_list", "integer_list", "logical_list") && length(x) > 0) { + if (type %in% c("character_list", "numeric_list", "integer_list", "logical_list") && length(x) > 0L) { # Divide by comma x <- strsplit_all( x = x, split = ",", - fixed = TRUE)[[1]] + fixed = TRUE + )[[1L]] # Remove whitespace x <- gsub( x = x, pattern = " ", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } } else if (optional) { @@ -315,23 +424,26 @@ # Required, but no default. ..error_input_missing_without_default( var_name = var_name, - allow_config = TRUE) + allow_config = TRUE + ) } # This point in the code can only be reached if the user provided a value. # Check for presence of values - if (length(x) == 0 && optional == FALSE) { + if (length(x) == 0L && optional == FALSE) { # Throw an error as entry is required ..error_input_missing_without_default( var_name = var_name, - allow_config = TRUE) + allow_config = TRUE + ) } else if (isTRUE(all.equal("", x)) && optional == FALSE) { ..error_input_missing_without_default( var_name = var_name, - allow_config = TRUE) + allow_config = TRUE + ) - } else if (length(x) == 0 || isTRUE(all.equal("", x))) { + } else if (length(x) == 0L || isTRUE(all.equal("", x))) { # Return the default value if no value is provided return(default) } @@ -349,8 +461,9 @@ x = x, to_type = type, var_name = var_name, - req_length = 0, - allow_more = TRUE) + req_length = 0L, + allow_more = TRUE + ) } else if (type %in% c("character", "numeric", "integer", "logical")) { # Convert to type @@ -358,8 +471,9 @@ x = x, to_type = type, var_name = var_name, - req_length = 1, - allow_more = FALSE) + req_length = 1L, + allow_more = FALSE + ) } else if (type %in% c("character_list", "numeric_list", "integer_list", "logical_list")) { # Find basic type string. @@ -367,28 +481,32 @@ x = type, pattern = "_list", replacement = "", - fixed = TRUE) + fixed = TRUE + ) # Convert to type x <- .perform_type_conversion( x = x, to_type = list_type, var_name = var_name, - req_length = 1, - allow_more = TRUE) + req_length = 1L, + allow_more = TRUE + ) # Check for duplicates if (anyDuplicated(x)) { ..error_input_not_unique( x = x, var_name = var_name, - allow_config = TRUE) + allow_config = TRUE + ) } } else { # By design unreachable ..error_reached_unreachable_code( - paste0(".parse_arg: the type argument was not recognised: ", type)) + paste0(".parse_arg: the type argument was not recognised: ", type) + ) } return(x) diff --git a/R/CheckHyperparameters.R b/R/CheckHyperparameters.R index cebc5ea3..559a7c02 100644 --- a/R/CheckHyperparameters.R +++ b/R/CheckHyperparameters.R @@ -6,20 +6,21 @@ NULL data, parameter_list, outcome_type, - fs_method = NULL, + vimp_method = NULL, learner = NULL, - detector = NULL) { + detector = NULL +) { # Check if any hyperparameters have been set - if (length(parameter_list) == 0) return(parameter_list) + if (length(parameter_list) == 0L) return(parameter_list) - if (is.null(fs_method) && is.null(learner) && is.null(detector)) { - ..error_reached_unreachable_code(".parse_hyperparameters: one of fs_method, learner, detector should not be NULL") + if (is.null(vimp_method) && is.null(learner) && is.null(detector)) { + ..error_reached_unreachable_code(".parse_hyperparameters: one of vimp_method, learner, detector should not be NULL") } - if (!is.null(fs_method)) { - all_functions <- fs_method - type <- "feature selection methods" + if (!is.null(vimp_method)) { + all_functions <- vimp_method + type <- "variable importance methods" } else if (!is.null(learner)) { all_functions <- learner @@ -34,18 +35,24 @@ NULL user_function_names <- names(parameter_list) # Check whether all names in the hyperparameter list correspond to a - # fs_method, learner or detector. + # vimp_method, learner or detector. unknown_function <- setdiff(user_function_names, all_functions) - if (length(unknown_function) > 0) { - stop(paste0( - "Could not match all entries in the parameter list to ", type, ".\n", - "Failed to match: ", paste_s(unknown_function))) + if (length(unknown_function) > 0L) { + ..error( + paste0( + "Could not match all entries in the parameter list to ", type, ".\n", + "Failed to match: ", paste_s(unknown_function) + ), + error_class = "input_argument_error" + ) } # Check for duplicates. if (anyDuplicated(user_function_names)) { - stop(paste0( - "Parameters for one or more of the ", type, " are defined more than once.")) + ..error( + "Parameters for one or more of the ", type, " are defined more than once.", + error_class = "input_argument_error" + ) } # Package data into a data object. @@ -53,7 +60,8 @@ NULL "dataObject", data = data, preprocessing_level = "none", - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Iterate over the feature selection methods or learners to parse and check the hyperparameters out_list <- lapply( @@ -61,9 +69,10 @@ NULL .check_hyperparameters, in_list = parameter_list, data = data, - fs_method = fs_method, + vimp_method = vimp_method, learner = learner, - detector = detector) + detector = detector + ) # Set names of the input parameters names(out_list) <- user_function_names @@ -77,27 +86,30 @@ NULL user_function_name, in_list, data, - fs_method = NULL, + vimp_method = NULL, learner = NULL, - detector = NULL) { + detector = NULL +) { # Select current parameter list in_list <- in_list[[user_function_name]] # Obtain preset values for hyperparameters. - if (!is.null(fs_method)) { + if (!is.null(vimp_method)) { preset_list <- .get_preset_hyperparameters( data = data, - fs_method = user_function_name, - names_only = FALSE) + vimp_method = user_function_name, + names_only = FALSE + ) - type <- "feature selection method" + type <- "variable importance method" } else if (!is.null(learner)) { preset_list <- .get_preset_hyperparameters( data = data, learner = user_function_name, - names_only = FALSE) + names_only = FALSE + ) type <- "learner" @@ -105,7 +117,8 @@ NULL preset_list <- .get_preset_hyperparameters( data = data, detector = user_function_name, - names_only = FALSE) + names_only = FALSE + ) type <- "novelty detector" } @@ -114,41 +127,55 @@ NULL user_function_name <- paste(user_function_name, type) # Check if the desired function actually has parameters. - if (length(preset_list) == 0) { - stop(paste0("The ", user_function_name, " has no associated parameters.")) + if (length(preset_list) == 0L) { + ..error( + "The ", user_function_name, " has no associated parameters.", + error_class = "input_argument_error" + ) } # Check if there are any parameters in the user-provided list that do not appear in the preset list unknown_parameter <- setdiff(names(in_list), names(preset_list)) - if (length(unknown_parameter) > 0) { - stop(paste0( - "Could not match all parameters provided for the ", - user_function_name, - " to a valid parameter. Failed to match: ", - paste_s(unknown_parameter))) + if (length(unknown_parameter) > 0L) { + ..error( + paste0( + "Could not match all parameters provided for the ", + user_function_name, + " to a valid parameter. Failed to match: ", + paste_s(unknown_parameter) + ), + error_class = "input_argument_error" + ) } # Check if there are any duplicate parameters if (anyDuplicated(names(in_list))) { - stop(paste0( - "One or more parameters provided for the ", - user_function_name, - " appear more than once.")) + ..error( + paste0( + "One or more parameters provided for the ", + user_function_name, + " appear more than once: ", + names(in_list)[duplicated(names(in_list))] + ), + error_class = "input_argument_error" + ) } # Iterate over the individual parameters and parse/check individual parameters out_list <- lapply( names(in_list), function(parameter_name, in_list, user_function_name, preset_list) { - .check_single_hyperparameter( - parameter_name, - user_function_name = user_function_name, - x = in_list[[parameter_name]], - preset_list = preset_list[[parameter_name]]) + .check_single_hyperparameter( + parameter_name, + user_function_name = user_function_name, + x = in_list[[parameter_name]], + preset_list = preset_list[[parameter_name]] + ) }, user_function_name = user_function_name, in_list = in_list, - preset_list = preset_list) + preset_list = preset_list + ) # Set names of the out_list names(out_list) <- names(in_list) @@ -162,9 +189,10 @@ NULL parameter_name, user_function_name, x, - preset_list) { + preset_list +) { - if (is.list(x) && length(x) == 1) { + if (is.list(x) && length(x) == 1L) { # Unlist list. This happens when the hyperparameter settings come from a # configuration file. x <- unlist(x) @@ -175,14 +203,16 @@ NULL x <- strsplit( x = x, split = ",", - fixed = TRUE)[[1]] + fixed = TRUE + )[[1L]] # Remove whitespace x <- gsub( x = x, pattern = " ", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } # Update the parameter_name for passing into error warnings @@ -194,7 +224,8 @@ NULL to_type = preset_list$type, var_name = parameter_name, req_length = 1L, - allow_more = TRUE) + allow_more = TRUE + ) # Check if the parameter has the allowed values if (!is.null(preset_list$valid_range)) { @@ -209,13 +240,15 @@ NULL x, .check_number_in_valid_range, var_name = parameter_name, - range = valid_range) + range = valid_range + ) } else { .check_parameter_value_is_valid( x = x, var_name = parameter_name, - values = valid_range) + values = valid_range + ) } return(x) @@ -225,15 +258,17 @@ NULL .get_preset_hyperparameters <- function( data = NULL, - fs_method = NULL, + vimp_method = NULL, learner = NULL, detector = NULL, outcome_type = NULL, - names_only = FALSE) { + names_only = FALSE +) { - if (is.null(fs_method) && is.null(learner) && is.null(detector)) { + if (is.null(vimp_method) && is.null(learner) && is.null(detector)) { ..error_reached_unreachable_code( - ".get_preset_hyperparameters: one of fs_method, learner, detector should not be NULL") + ".get_preset_hyperparameters: one of vimp_method, learner, detector should not be NULL" + ) } # Internal error checks. We should be able to obtain the outcome_type. @@ -249,29 +284,33 @@ NULL } # Find the parameter list - if (!is.null(fs_method)) { + if (!is.null(vimp_method)) { preset_list <- .get_vimp_hyperparameters( data = data, - method = fs_method, + method = vimp_method, outcome_type = outcome_type, - names_only = names_only) + names_only = names_only + ) } else if (!is.null(learner)) { preset_list <- .get_learner_hyperparameters( data = data, learner = learner, outcome_type = outcome_type, - names_only = names_only) + names_only = names_only + ) } else if (!is.null(detector)) { preset_list <- .get_detector_hyperparameters( data = data, detector = detector, - names_only = names_only) + names_only = names_only + ) } else { ..error_reached_unreachable_code( - ".get_preset_hyperparameters: one of fs_method, learner, detector should not be NULL") + ".get_preset_hyperparameters: one of vimp_method, learner, detector should not be NULL" + ) } return(preset_list) @@ -282,10 +321,11 @@ NULL .update_hyperparameters <- function( parameter_list, user_list = NULL, - n_features = NULL) { + n_features = NULL +) { # Check if any parameters are provided - if (length(parameter_list) == 0) return(parameter_list) + if (length(parameter_list) == 0L) return(parameter_list) for (parameter_name in names(parameter_list)) { @@ -304,22 +344,23 @@ NULL user_values[user_values > n_features] <- n_features } - if (length(user_values) == 1) { + if (length(user_values) == 1L) { # User provides one value for a parameter parameter_list[[parameter_name]]$init_config <- user_values parameter_list[[parameter_name]]$randomise <- FALSE - } else if (length(user_values) > 1) { + } else if (length(user_values) > 1L) { if (parameter_list[[parameter_name]]$type %in% c("numeric", "integer")) { - if (length(user_values) == 2) { + if (length(user_values) == 2L) { # Find initial values from the default and from the user-provided # range. Only values within the latter range are used. initial_values <- sort(unique(c( parameter_list[[parameter_name]]$init_config, - user_values))) - initial_values <- initial_values[initial_values >= user_values[1] & initial_values <= user_values[2]] + user_values + ))) + initial_values <- initial_values[initial_values >= user_values[1L] & initial_values <= user_values[2L]] } else { # For more than 2 values, copy the user values directly. @@ -341,14 +382,15 @@ NULL # This code should never be reached as such cases should be captures by # .parse_hyperparameters earlier in the workflow. ..error_reached_unreachable_code(paste0( - ".update_hyperparameters: at least one user_values is expected.")) + ".update_hyperparameters: at least one user_values is expected." + )) } } # Identify parameters that only allow for a single value. - if (length(unique(parameter_list[[parameter_name]]$range)) == 1) { - parameter_list[[parameter_name]]$init_config <- parameter_list[[parameter_name]]$range[1] - parameter_list[[parameter_name]]$range <- parameter_list[[parameter_name]]$range[1] + if (length(unique(parameter_list[[parameter_name]]$range)) == 1L) { + parameter_list[[parameter_name]]$init_config <- parameter_list[[parameter_name]]$range[1L] + parameter_list[[parameter_name]]$range <- parameter_list[[parameter_name]]$range[1L] parameter_list[[parameter_name]]$randomise <- FALSE } @@ -358,21 +400,24 @@ NULL parameter_list[[parameter_name]]$init_config, .check_number_in_valid_range, var_name = parameter_name, - range = parameter_list[[parameter_name]]$valid_range) + range = parameter_list[[parameter_name]]$valid_range + ) } else { sapply( parameter_list[[parameter_name]]$init_config, .check_parameter_value_is_valid, var_name = parameter_name, - values = parameter_list[[parameter_name]]$valid_range) + values = parameter_list[[parameter_name]]$valid_range + ) } if (!parameter_list[[parameter_name]]$randomise) { - if (length(parameter_list[[parameter_name]]$init_config) > 1) { + if (length(parameter_list[[parameter_name]]$init_config) > 1L) { ..error_reached_unreachable_code(paste0( ".update_hyperparameters: non-randomised hyperparameter (", - parameter_name, ") contains more than one initial value.")) + parameter_name, ") contains more than one initial value." + )) } } } @@ -390,15 +435,16 @@ NULL # function is used to check whether there are any randomisable # hyper-parameters. - if (length(parameter_list) == 0) return(FALSE) + if (length(parameter_list) == 0L) return(FALSE) # Determine if any parameters require randomisation requires_randomisation <- sapply( parameter_list, - function(list_entry) (list_entry$randomise)) + function(list_entry) (list_entry$randomise) + ) # Return FALSE if no feature is randomised, and TRUE if any feature is randomised. - return(sum(requires_randomisation) > 0) + return(sum(requires_randomisation) > 0L) } @@ -408,7 +454,8 @@ NULL range, valid_range = NULL, randomise = FALSE, - distribution = NULL) { + distribution = NULL +) { # Initialise list hyperparameter <- list() @@ -422,7 +469,8 @@ NULL # Check for accidental typos in type. if (!type %in% c("numeric", "integer", "factor", "logical")) { ..error_reached_unreachable_code(paste0( - ".set_hyperparameter: type does not match one of the expected types: ", type)) + ".set_hyperparameter: type does not match one of the expected types: ", type + )) } # Set range. @@ -446,7 +494,8 @@ NULL if (!distribution %in% c("log")) { ..error_reached_unreachable_code(paste0( ".set_hyperparameter: distribution does not match one of the expected distributions: ", - distribution)) + distribution + )) } } diff --git a/R/CheckPackages.R b/R/CheckPackages.R index 8579d09d..3da7f7f8 100644 --- a/R/CheckPackages.R +++ b/R/CheckPackages.R @@ -10,13 +10,15 @@ setMethod( x, purpose = NULL, message_type = "error", - ...) { + ... + ) { # Pass to .require_package return(invisible(.require_package( x = x, purpose = purpose, - message_type = message_type))) + message_type = message_type + ))) } ) @@ -36,7 +38,9 @@ setMethod( x, purpose = NULL, message_type = "error", - ...) { + call = rlang::caller_env(), + ... +) { if (message_type %in% c("error", "warning")) { # Attempt to load required packages. @@ -57,27 +61,33 @@ setMethod( # Throw an error. ..error_package_not_installed( x = missing_packages, - purpose = purpose) + purpose = purpose, + call = call + ) } else if (message_type == "warning") { # Raise a warning ..warning_package_not_installed( x = missing_packages, - purpose = purpose) + purpose = purpose, + call = call + ) } else if (message_type == "backend_error") { # Add message to backend. ..message_package_not_installed_to_backend( x = missing_packages, purpose = purpose, - message_type = "error") + message_type = "error" + ) } else if (message_type == "backend_warning") { # Add message to backend. ..message_package_not_installed_to_backend( x = missing_packages, purpose = purpose, - message_type = "warning") + message_type = "warning" + ) } return(FALSE) @@ -89,7 +99,8 @@ setMethod( .check_package_version <- function( name, version, - when = NULL) { + when = NULL +) { # Do not check if package versions are missing completely. if (is_empty(version)) return(invisible(NULL)) @@ -98,13 +109,15 @@ setMethod( package_outdated <- mapply( is_package_outdated, name = name, - version = version) + version = version + ) # Check for newer packages. package_newer <- mapply( is_package_newer, name = name, - version = version) + version = version + ) # Skip if no packages are outdated. if (!any(package_outdated) && !any(package_newer)) return(invisible(NULL)) @@ -119,7 +132,8 @@ setMethod( when_str <- ifelse( multiple_packages, paste0(" from those ", when), - paste0(" from that ", when)) + paste0(" from that ", when) + ) } else { when_str <- NULL @@ -131,8 +145,9 @@ setMethod( ifelse( multiple_packages, paste0("s have versions that differ", when_str, ":"), - paste0(" has a version that differs", when_str, ":"))) - + paste0(" has a version that differs", when_str, ":") + ) + ) for (ii in seq_along(name)) { @@ -148,11 +163,13 @@ setMethod( as.character(utils::packageVersion(name[ii])), ifelse(package_outdated[ii], " < ", " > "), as.character(version[ii]), - ifelse(package_outdated[ii], " (outdated)", " (newer)"))) + ifelse(package_outdated[ii], " (outdated)", " (newer)") + ) + ) } # Show as warning. - warning(paste(message_str, sep = "\n")) + ..warning(paste(message_str, sep = "\n")) return(invisible(TRUE)) } @@ -161,15 +178,16 @@ setMethod( is_package_installed <- function(name) { - if (length(name) == 0) return(TRUE) + if (length(name) == 0L) return(TRUE) - # Try to obtain the package version. This perhaps the cleanest way to check - # whether a package exists. require and requireNameSpace attach and load - # packages, which is not required here. The find.package documentation - # actively discourages its use to identify whether a package is installed. - installed_version <- tryCatch( - utils::packageVersion(name), - error = identity) + # Attempt to get the installed version of the package. If it fails, the + # package is not installed. + # + # This perhaps the cleanest way to check whether a package exists. require and + # requireNameSpace attach and load packages, which is not required here. The + # find.package documentation actively discourages its use to identify whether + # a package is installed. + installed_version <- .get_installed_package_version(name) return(!inherits(installed_version, "error")) } @@ -178,12 +196,10 @@ is_package_installed <- function(name) { is_package_outdated <- function(name, version) { - if (length(name) == 0) return(TRUE) + if (length(name) == 0L) return(TRUE) # Obtain the installed version of the package. - installed_version <- tryCatch( - utils::packageVersion(name), - error = identity) + installed_version <- .get_installed_package_version(name) if (inherits(installed_version, "error")) { ..error_package_not_installed(name) @@ -199,12 +215,10 @@ is_package_outdated <- function(name, version) { is_package_newer <- function(name, version) { - if (length(name) == 0) return(TRUE) + if (length(name) == 0L) return(TRUE) # Obtain the installed version of the package. - installed_version <- tryCatch( - utils::packageVersion(name), - error = identity) + installed_version <- .get_installed_package_version(name) if (inherits(installed_version, "error")) { ..error_package_not_installed(name) @@ -218,8 +232,25 @@ is_package_newer <- function(name, version) { +.get_installed_package_version <- function(name) { + # Lookup version of the package using utils::packageVersion. The result is + # cached to reduce lookup times. + installed_version <- rlang::env_cache( + familiar_global_env, + paste0(name, "_version"), + default = tryCatch( + utils::packageVersion(name), + error = identity + ) + ) + + return(installed_version) +} + + + .bioconductor_packages <- function() { - return("qvalue") + return(NULL) } @@ -227,12 +258,14 @@ is_package_newer <- function(name, version) { ..message_package_not_installed_to_backend <- function( x, purpose, - message_type) { + message_type +) { # Generate message string. message_str <- ..message_missing_package( x = x, - purpose = purpose) + purpose = purpose + ) missing_packages <- NULL @@ -240,7 +273,8 @@ is_package_newer <- function(name, version) { if (exists("missing_packages", where = familiar_global_env)) { missing_packages <- get( "missing_packages", - envir = familiar_global_env) + envir = familiar_global_env + ) } # Append missing packages. @@ -250,7 +284,8 @@ is_package_newer <- function(name, version) { assign( "missing_packages", value = missing_packages, - envir = familiar_global_env) + envir = familiar_global_env + ) missing_package_messages <- NULL @@ -260,7 +295,8 @@ is_package_newer <- function(name, version) { missing_package_messages <- get( "missing_package_messages", - envir = familiar_global_env) + envir = familiar_global_env + ) } # Append package messages. @@ -270,7 +306,8 @@ is_package_newer <- function(name, version) { assign( "missing_package_messages", value = missing_package_messages, - envir = familiar_global_env) + envir = familiar_global_env + ) missing_package_message_type <- NULL @@ -278,7 +315,8 @@ is_package_newer <- function(name, version) { if (exists("missing_package_message_type", where = familiar_global_env)) { missing_package_message_type <- get( "missing_package_message_type", - envir = familiar_global_env) + envir = familiar_global_env + ) } # Append missing packages. @@ -288,7 +326,8 @@ is_package_newer <- function(name, version) { assign( "missing_package_message_type", value = missing_package_message_type, - envir = familiar_global_env) + envir = familiar_global_env + ) return(invisible(TRUE)) } @@ -302,50 +341,46 @@ is_package_newer <- function(name, version) { if (!exists("missing_package_messages", where = familiar_global_env)) return() # Get all missing packages. - x <- get( - "missing_packages", - envir = familiar_global_env) + x <- get("missing_packages", envir = familiar_global_env) # Only unique packages. x <- unique(x) # Retrieve package messages. - err_message <- get( - "missing_package_messages", - envir = familiar_global_env) + err_message <- get("missing_package_messages", envir = familiar_global_env) # Determine number of messages. n_messages <- length(err_message) # Combine error messages. - if (n_messages > 1) err_message <- paste0(err_message, collapse = "\n") + if (n_messages > 1L) err_message <- paste0(err_message, collapse = "\n") # Add basic message to install packages. - if (n_messages > 1) err_message <- c( - err_message, "\n", - ..message_missing_package(x = x)) + if (n_messages > 1L) { + err_message <- c(err_message, "\n", ..message_missing_package(x = x)) + } # Instructions for CRAN packages. - err_message <- c( - err_message, - ..message_install_from_cran(x = x)) + err_message <- c(err_message, ..message_install_from_cran(x = x)) # Instructions for Bioconductor packages. - err_message <- c( - err_message, - ..message_install_from_bioconductor(x = x)) + err_message <- c(err_message, ..message_install_from_bioconductor(x = x)) # Obtain message types. - message_type <- get( - "missing_package_message_type", - envir = familiar_global_env) + message_type <- get("missing_package_message_type", envir = familiar_global_env) # Throw error or warning. if (any(message_type == "error")) { - stop(paste0(err_message, collapse = "")) + ..error( + paste0(err_message, collapse = ""), + error_class = "package_missing" + ) } else { - warning(paste0(err_message, collapse = "")) + ..warning( + paste0(err_message, collapse = ""), + warning_class = "package_missing" + ) } # Clean up @@ -353,7 +388,8 @@ is_package_newer <- function(name, version) { "missing_packages", "missing_package_message_type", "missing_package_messages", - envir = familiar_global_env) + envir = familiar_global_env + ) return(invisible(TRUE)) } @@ -366,23 +402,25 @@ is_package_newer <- function(name, version) { x <- unique(x) # Check whether packages are not actually installed. - all_missing <- all(!sapply(x, is_package_installed)) + all_missing <- !any(sapply(x, is_package_installed)) if (all_missing) { message_str <- paste0( "The following package", - ifelse(length(x) > 1, "s have", " has"), + ifelse(length(x) > 1L, "s have", " has"), " to be installed", ifelse(is.null(purpose), ": ", paste0(" ", purpose, ": ")), - paste_s(x), ".") + paste_s(x), "." + ) } else { message_str <- paste0( "The following package", - ifelse(length(x) > 1, "s have", " has"), + ifelse(length(x) > 1L, "s have", " has"), " to be installed, or installed again to update dependencies", ifelse(is.null(purpose), ": ", paste0(" ", purpose, ": ")), - paste_s(x), ".") + paste_s(x), "." + ) } return(message_str) @@ -398,11 +436,12 @@ is_package_newer <- function(name, version) { x <- unique(x) x_cran <- setdiff(x, .bioconductor_packages()) - if (length(x_cran) > 0) { + if (length(x_cran) > 0L) { message_str <- paste0( "\n\nInstall from CRAN: ", "\n\n\tinstall.packages(c(", - paste0("\"", x_cran, "\"", collapse = ", "), "))") + paste0("\"", x_cran, "\"", collapse = ", "), "))" + ) } return(message_str) @@ -418,12 +457,13 @@ is_package_newer <- function(name, version) { x <- unique(x) x_bioc <- intersect(x, .bioconductor_packages()) - if (length(x_bioc) > 0) { + if (length(x_bioc) > 0L) { message_str <- paste0( "\n\nInstall from Bioconductor: ", ifelse(is_package_installed("BiocManager"), "", "\n\n\tinstall.packages(\"BiocManager\")"), "\n\tBiocManager::install(c(", - paste0("\"", x_bioc, "\"", collapse = ", "), "))") + paste0("\"", x_bioc, "\"", collapse = ", "), "))" + ) } return(message_str) diff --git a/R/ClassBalance.R b/R/ClassBalance.R index 2b5e5e6f..01682bef 100644 --- a/R/ClassBalance.R +++ b/R/ClassBalance.R @@ -16,7 +16,8 @@ setMethod( data = data@data, method = method, outcome_type = outcome_type, - ...)) + ... + )) } ) @@ -42,7 +43,8 @@ setMethod( outcome_type, method = NULL, normalisation = "none", - ...) { + ... + ) { # Check that an outcome-type is provided. if (is.null(outcome_type)) { @@ -76,7 +78,8 @@ setMethod( } else { # Unknown method. ..error_reached_unreachable_code(paste0( - "create_instance_weights: unknown class weighting method. Found: ", method)) + "create_instance_weights: unknown class weighting method. Found: ", method + )) } # Normalisation. @@ -92,7 +95,8 @@ setMethod( } else { # Unknown normalisation method. ..error_reached_unreachable_code(paste0( - "create_instance_weights: unknown normalisation method. Found: ", normalisation)) + "create_instance_weights: unknown normalisation method. Found: ", normalisation + )) } return(weights) @@ -149,7 +153,8 @@ setMethod( # Check that the number is negative. if (x >= 0.0) { ..error_reached_unreachable_code(paste0( - "..compute_effective_number_of_samples_beta: parameter should be negative. Found: ", x)) + "..compute_effective_number_of_samples_beta: parameter should be negative. Found: ", x + )) } return(1.0 - 10.0^x) @@ -163,14 +168,16 @@ setMethod( default_method <- ifelse( outcome_type %in% c("binomial", "multinomial"), "inverse_number_of_samples", - "none") + "none" + ) # Set hyperparameter. return(.set_hyperparameter( default = default_method, type = "factor", range = c("inverse_number_of_samples", "effective_number_of_samples", "none"), - randomise = FALSE)) + randomise = FALSE + )) } @@ -178,17 +185,20 @@ setMethod( .get_default_sample_weighting_beta <- function(method, outcome_type) { # Default values. - if ("effective_number_of_samples" %in% method && - outcome_type %in% c("binomial", "multinomial")) { - default_values <- c(-4, -3, -2, -1) + if ( + "effective_number_of_samples" %in% method && + outcome_type %in% c("binomial", "multinomial") + ) { + default_values <- c(-4L, -3L, -2L, -1L) } else { - default_values <- -2 + default_values <- -2L } return(.set_hyperparameter( default = default_values, type = "integer", - range = c(-6, -1), - randomise = length(default_values) > 1)) + range = c(-6L, -1L), + randomise = length(default_values) > 1L + )) } diff --git a/R/ClusterRepresentation.R b/R/ClusterRepresentation.R index 46f3685e..234d4800 100644 --- a/R/ClusterRepresentation.R +++ b/R/ClusterRepresentation.R @@ -11,17 +11,20 @@ setMethod( "add_feature_info_parameters", signature( object = "singularClusteringObject", - data = "dataObject"), + data = "dataObject" + ), function( object, data, - ...) { + ... + ) { # Sanity check: the cluster is singular. - if (length(object@cluster_features) != 1) { + if (length(object@cluster_features) != 1L) { ..error_reached_unreachable_code(paste0( "add_feature_info_parameters,singularClusteringObject,dataObject: ", - "the number of features is expected to be 1. Found: ", length(object@cluster_features))) + "the number of features is expected to be 1. Found: ", length(object@cluster_features) + )) } # Create representation object for a singular cluster. @@ -33,7 +36,8 @@ setMethod( "cluster_name" = object@cluster_features, "cluster_size" = 1L, "cluster_features" = object@cluster_features, - "required_features" = object@cluster_features) + "required_features" = object@cluster_features + ) # Set as list. representation_object_list <- list(representation_object) @@ -41,7 +45,8 @@ setMethod( # Add name to list elements. names(representation_object_list) <- sapply( representation_object_list, - function(x) (x@name)) + function(x) (x@name) + ) return(representation_object_list) } @@ -54,13 +59,15 @@ setMethod( "add_feature_info_parameters", signature( object = "clusteringObject", - data = "dataObject"), + data = "dataObject" + ), function( object, data, feature_info_list, cluster_method_object, - ...) { + ... + ) { if (object@representation_method == "none") { # Form singular clusters @@ -70,13 +77,15 @@ setMethod( # Represent clusters by the most central feature. representation_object_list <- .cluster_representation_by_medioid( object = object, - cluster_object = cluster_method_object) + cluster_object = cluster_method_object + ) } else if (object@representation_method == "best_predictor") { # Represent clusters by the best predictor. representation_object_list <- .cluster_representation_by_best_predictor( object = object, - data = data) + data = data + ) } else if (object@representation_method == "mean") { # Represent cluster as a meta-feature. @@ -84,7 +93,8 @@ setMethod( object = object, data = data, feature_info_list = feature_info_list, - cluster_object = cluster_method_object) + cluster_object = cluster_method_object + ) } else if (object@representation_method == "concordance") { # TODO implement. @@ -92,13 +102,15 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "add_feature_info_parameters,clusteringObject,dataObject: ", - "encountered an unknown representation method: ", object@representation_method)) + "encountered an unknown representation method: ", object@representation_method + )) } # Add name to list elements. names(representation_object_list) <- sapply( representation_object_list, - function(x) (x@name)) + function(x) (x@name) + ) return(representation_object_list) } @@ -113,7 +125,6 @@ setMethod( representation_object_list <- lapply( object@cluster_features, function(current_feature) { - # Create representation object for a singular cluster. representation_object <- methods::new( "clusterRepresentationObject", @@ -123,10 +134,12 @@ setMethod( "cluster_name" = current_feature, "cluster_size" = 1L, "cluster_features" = current_feature, - "required_features" = current_feature) + "required_features" = current_feature + ) return(representation_object) - }) + } + ) return(representation_object_list) } @@ -136,7 +149,8 @@ setMethod( .cluster_representation_by_medioid <- function( object, cluster_object, - ...) { + ... +) { # Represent clusters by their medioid feature. # Suppress NOTES due to non-standard evaluation in data.table @@ -145,55 +159,60 @@ setMethod( # Get distance table. distance_table <- get_distance_table( object = cluster_object@similarity_table, - include_diagonal = FALSE) + include_diagonal = FALSE + ) # Determine whether the similarity table is for features (columns) or samples # (rows). element_names <- .get_cluster_data_type_element_name( - data_type = cluster_object@data_type) + data_type = cluster_object@data_type + ) # Change names in similarity table to a generic name. data.table::setnames( x = distance_table, old = element_names, - new = c("element_1", "element_2")) + new = c("element_1", "element_2") + ) # Limit distance table to only features in the cluster. distance_table <- distance_table[ - element_1 %in% object@cluster_features & element_2 %in% object@cluster_features] + element_1 %in% object@cluster_features & element_2 %in% object@cluster_features + ] # Find mean distance for each feature. - distance_table <- distance_table[, list( - "average_distance" = mean(value)), - by = "element_1"] + distance_table <- distance_table[ + , + list("average_distance" = mean(value)), + by = "element_1" + ] # Find the feature to be used as the representative feature. representative_feature <- distance_table[ - average_distance == min(average_distance)]$element_1[1] + average_distance == min(average_distance) + ]$element_1[1L] # Iterate over features to form representation objects. representation_object_list <- lapply( object@cluster_features, - function( - current_feature, - cluster_features, - representative_feature) { - - # Create representation object for a singular cluster. - representation_object <- methods::new( - "clusterRepresentationObject", - "name" = current_feature, - "weight" = ifelse(current_feature == representative_feature, 1.0, 0.0), - "invert" = FALSE, - "cluster_name" = paste0(representative_feature, "_cluster"), - "cluster_size" = length(cluster_features), - "cluster_features" = cluster_features, - "required_features" = representative_feature) - - return(representation_object) - }, - cluster_features = object@cluster_features, - representative_feature = representative_feature) + function(current_feature, cluster_features, representative_feature) { + # Create representation object for a singular cluster. + representation_object <- methods::new( + "clusterRepresentationObject", + "name" = current_feature, + "weight" = ifelse(current_feature == representative_feature, 1.0, 0.0), + "invert" = FALSE, + "cluster_name" = paste0(representative_feature, "_cluster"), + "cluster_size" = length(cluster_features), + "cluster_features" = cluster_features, + "required_features" = representative_feature + ) + + return(representation_object) + }, + cluster_features = object@cluster_features, + representative_feature = representative_feature + ) return(representation_object_list) } @@ -203,7 +222,8 @@ setMethod( .cluster_representation_by_best_predictor <- function( object, data, - ...) { + ... +) { # Represent clusters by the most predictive feature. # Suppress NOTES due to non-standard evaluation in data.table @@ -212,7 +232,8 @@ setMethod( # Select features data <- select_features( data = data, - features = object@cluster_features) + features = object@cluster_features + ) # Aggregate data data <- aggregate_data(data = data) @@ -220,18 +241,20 @@ setMethod( # Calculate p-values of the features in the clusters feature_p_values <- compute_univariable_p_values( data_obj = data, - feature_columns = object@cluster_features) + feature_columns = object@cluster_features + ) # Integrate in a data.table predictor_data <- data.table::data.table( "name" = names(feature_p_values), - "p_value" = feature_p_values) + "p_value" = feature_p_values + ) # Replace non-finite p-values. predictor_data[!is.finite(p_value), "p_value" := 1.0] # Find the feature to be used as the representative feature. - representative_feature <- predictor_data[p_value == min(p_value)]$name[1] + representative_feature <- predictor_data[p_value == min(p_value)]$name[1L] # Iterate over features to form representation objects. representation_object_list <- lapply( @@ -239,8 +262,8 @@ setMethod( function( current_feature, cluster_features, - representative_feature) { - + representative_feature + ) { # Create representation object for a singular cluster. representation_object <- methods::new( "clusterRepresentationObject", @@ -250,12 +273,14 @@ setMethod( "cluster_name" = paste0(representative_feature, "_cluster"), "cluster_size" = length(cluster_features), "cluster_features" = cluster_features, - "required_features" = representative_feature) + "required_features" = representative_feature + ) return(representation_object) }, cluster_features = object@cluster_features, - representative_feature = representative_feature) + representative_feature = representative_feature + ) return(representation_object_list) } @@ -266,23 +291,31 @@ setMethod( object, data, feature_info_list, - ...) { + ... +) { # Represent clusters by the mean # Check if any of the features is categorical - for these "mean" clusters can # not be realistically created. - if (any(sapply( - feature_info_list[object@cluster_features], - function(x) (x@feature_type)) == "factor")) { + if ( + any( + sapply( + feature_info_list[object@cluster_features], + function(x) (x@feature_type) + ) == "factor" + ) + ) { return(.cluster_representation_by_medioid( object = object, - ...)) + ... + )) } ..cluster_representation_as_mean_feature <- function( current_feature, feature_correlation, - cluster_features) { + cluster_features + ) { # Create representation object for a cluster meta-feature. representation_object <- methods::new( @@ -290,36 +323,36 @@ setMethod( "name" = current_feature, "weight" = 1.0 / length(cluster_features), "invert" = feature_correlation < 0.0, - "cluster_name" = paste0(cluster_features[1], "_meta_cluster"), + "cluster_name" = paste0(cluster_features[1L], "_meta_cluster"), "cluster_size" = length(cluster_features), "cluster_features" = cluster_features, - "required_features" = cluster_features) + "required_features" = cluster_features + ) return(representation_object) } # Select features - data <- select_features( - data = data, - features = object@cluster_features) + data <- select_features(data = data, features = object@cluster_features) # Compute Spearman correlation between the first feature and the other # features. feature_correlation <- sapply( data@data[, mget(object@cluster_features)], stats::cor, - y = data@data[[object@cluster_features[1]]], + y = data@data[[object@cluster_features[1L]]], use = "na.or.complete", - method = "spearman") + method = "spearman" + ) # Iterate over features to form representation objects. representation_object_list <- mapply( ..cluster_representation_as_mean_feature, current_feature = object@cluster_features, feature_correlation = feature_correlation, - MoreArgs = list( - "cluster_features" = object@cluster_features), - SIMPLIFY = FALSE) + MoreArgs = list("cluster_features" = object@cluster_features), + SIMPLIFY = FALSE + ) return(representation_object_list) } diff --git a/R/Clustering.R b/R/Clustering.R index 4cd258bf..394ae9d9 100644 --- a/R/Clustering.R +++ b/R/Clustering.R @@ -14,7 +14,8 @@ setClass( "cluster_name" = "character", "cluster_size" = "integer", "cluster_features" = "character", - "required_features" = "ANY"), + "required_features" = "ANY" + ), prototype = list( "type" = NA_character_, "method" = NULL, @@ -23,7 +24,9 @@ setClass( "cluster_name" = NA_character_, "cluster_size" = NA_integer_, "cluster_features" = NA_character_, - "required_features" = NULL)) + "required_features" = NULL + ) +) # Representation object -------------------------------------------------------- @@ -36,14 +39,17 @@ setClass( "cluster_name" = "character", "cluster_size" = "integer", "cluster_features" = "character", - "required_features" = "ANY"), + "required_features" = "ANY" + ), prototype = list( "weight" = NA_real_, "invert" = NA, "cluster_name" = NA_character_, "cluster_size" = NA_integer_, "cluster_features" = NA_character_, - "required_features" = NULL)) + "required_features" = NULL + ) +) @@ -56,16 +62,15 @@ create_cluster_parameter_skeleton <- function( cluster_similarity_threshold = NULL, cluster_similarity_metric = NULL, cluster_representation_method = NULL, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Creates a skeleton for the provided cluster method. # Determine feature names from the feature info list, if provided. if (is.null(feature_names)) feature_names <- names(feature_info_list) # Select only features that appear in the feature info list. - feature_names <- intersect( - names(feature_info_list), - feature_names) + feature_names <- intersect(names(feature_info_list), feature_names) # Skip step if no feature info objects are updated. if (is_empty(feature_names)) return(feature_info_list) @@ -74,7 +79,8 @@ create_cluster_parameter_skeleton <- function( .check_parameter_value_is_valid( x = cluster_method, var_name = "cluster_method", - values = .get_available_cluster_methods()) + values = .get_available_cluster_methods() + ) # Update familiar info objects with a feature clustering skeleton. updated_feature_info <- fam_lapply( @@ -86,7 +92,8 @@ create_cluster_parameter_skeleton <- function( cluster_similarity_threshold = cluster_similarity_threshold, cluster_similarity_metric = cluster_similarity_metric, cluster_representation_method = cluster_representation_method, - .override_existing = .override_existing) + .override_existing = .override_existing + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -103,17 +110,17 @@ create_cluster_parameter_skeleton <- function( feature_info, method, ..., - .override_existing = FALSE) { + .override_existing = FALSE +) { # Check if clustering data was already completed, and does not require being # determined anew. - if (feature_info_complete(feature_info@cluster_parameters) && - !.override_existing) return(feature_info) + if (feature_info_complete(feature_info@cluster_parameters) && !.override_existing) { + return(feature_info) + } # Create cluster parameter object. - object <- methods::new( - "featureInfoParametersCluster", - method = method) + object <- methods::new("featureInfoParametersCluster", method = method) # Set feature name object@name <- feature_info@name @@ -131,7 +138,8 @@ create_cluster_parameter_skeleton <- function( object@method <- create_cluster_method_object( cluster_method = method, data_type = "cluster", - ...) + ... + ) # Update imputation_parameters slot. feature_info@cluster_parameters <- object @@ -146,7 +154,8 @@ add_cluster_info <- function( feature_info_list, data, message_indent = 0L, - verbose = FALSE) { + verbose = FALSE +) { # Find feature columns. feature_names <- get_feature_columns(x = data) @@ -155,7 +164,8 @@ add_cluster_info <- function( if (!(setequal(feature_names, get_available_features(feature_info_list = feature_info_list)))) { ..error_reached_unreachable_code(paste0( "add_cluster_info: features in data and the feature info list are expected ", - "to be the same, but were not.")) + "to be the same, but were not." + )) } # Skeletons should be present. Now we need to identify which features can be @@ -168,11 +178,12 @@ add_cluster_info <- function( # Eliminate features that are already complete. feature_names <- feature_names[!sapply( feature_info_list[feature_names], - function(x) (feature_info_complete(x@cluster_parameters)))] + function(x) (feature_info_complete(x@cluster_parameters)) + )] # Skip any further processing if all parameter information has already been # completed. - if (length(feature_names) == 0) return(feature_info_list) + if (length(feature_names) == 0L) return(feature_info_list) # Set unassigned features. unassigned_features <- feature_names @@ -180,7 +191,7 @@ add_cluster_info <- function( # Iterate to eliminate any groups that would be smaller than 2. while (TRUE) { # Break once all features have been assigned. - if (length(unassigned_features) == 0) break + if (length(unassigned_features) == 0L) break # Get the cluster method object of the first feature that still needs to be # sorted. @@ -192,7 +203,8 @@ add_cluster_info <- function( function(x, y) { return(identical(x@cluster_parameters@method, y)) }, - y = cluster_method_object)] + y = cluster_method_object + )] # Perform 2 checks: # @@ -201,10 +213,11 @@ add_cluster_info <- function( # # 2, Check that there are at least 5 instances present. We cannot form # clusters when similarity is difficult to assess. - if (length(same_method_features) < 2 || get_n_samples(data, id_depth = "repetition") < 5L) { + if (length(same_method_features) < 2L || get_n_samples(data, id_depth = "repetition") < 5L) { feature_info_list[same_method_features] <- create_cluster_parameter_skeleton( feature_info_list[same_method_features], - cluster_method = "none") + cluster_method = "none" + ) } # Update the number of features that have not been assigned. @@ -217,7 +230,7 @@ add_cluster_info <- function( # Iterate to create feature groups and add feature information. while (TRUE) { # Break once all features have been assigned. - if (length(unassigned_features) == 0) break() + if (length(unassigned_features) == 0L) break() # Get the cluster method object of the first feature that still needs to be # sorted. @@ -229,16 +242,20 @@ add_cluster_info <- function( function(x, y) { return(identical(x@cluster_parameters@method, y)) }, - y = cluster_method_object)] + y = cluster_method_object + )] # Message that computations are starting. if (cluster_method_object@method != "none") { - logger_message(paste0( - "Computing similarity between ", length(same_method_features), " features ", - "using the ", cluster_method_object@similarity_metric, " metric ", - "for clustering using the ", cluster_method_object@method, " method."), + logger_message( + paste0( + "Computing similarity between ", length(same_method_features), " features ", + "using the ", cluster_method_object@similarity_metric, " metric ", + "for clustering using the ", cluster_method_object@method, " method." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } # Compute similarity. @@ -246,10 +263,12 @@ add_cluster_info <- function( object = cluster_method_object, data = filter_features( data = data, - available_features = same_method_features), + available_features = same_method_features + ), feature_info_list = feature_info_list[same_method_features], cl = cl, - verbose = verbose) + verbose = verbose + ) # Create clustering objects. These are used to update the # feature_info_lists. @@ -263,12 +282,12 @@ add_cluster_info <- function( cluster_method_object = cluster_method_object, feature_info_list = feature_info_list, data = data, - progress_bar = FALSE) + chopchop = TRUE, + progress_bar = FALSE + ) # Flatten lists with feature info. - updated_feature_info <- unlist( - updated_feature_info, - recursive = FALSE) + updated_feature_info <- unlist(updated_feature_info, recursive = FALSE) # Replace list elements without reordering. feature_info_list[same_method_features] <- updated_feature_info[same_method_features] @@ -286,25 +305,29 @@ add_cluster_info <- function( clustering_object, cluster_method_object, feature_info_list, - data) { + data +) { # Limit feature info list and data to the features in the cluster data <- filter_features( data = data, - available_features = clustering_object@cluster_features) + available_features = clustering_object@cluster_features + ) # Find representation. representation_objects <- add_feature_info_parameters( object = clustering_object, data = data, feature_info = feature_info_list[clustering_object@cluster_features], - cluster_method_object = cluster_method_object) + cluster_method_object = cluster_method_object + ) # Update cluster_parameters attribute in the feature info objects. updated_feature_info <- fam_mapply( FUN = ..add_cluster_info, feature_info = feature_info_list[clustering_object@cluster_features], - representation_object = representation_objects[clustering_object@cluster_features]) + representation_object = representation_objects[clustering_object@cluster_features] + ) # Update names. names(updated_feature_info) <- sapply(updated_feature_info, function(x) (x@name)) @@ -322,7 +345,8 @@ add_cluster_info <- function( # object in cluster_parameters. object <- add_feature_info_parameters( object = feature_info@cluster_parameters, - data = representation_object) + data = representation_object + ) # Attach updated information object. feature_info@cluster_parameters <- object @@ -337,7 +361,8 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersCluster", - data = "clusterRepresentationObject"), + data = "clusterRepresentationObject" + ), function(object, data, ...) { # Sanity check: check that names are correct. @@ -345,7 +370,8 @@ setMethod( ..error_reached_unreachable_code(paste0( "add_feature_info_parameters,featureInfoParametersCluster,clusterRepresentationObject: ", "the cluster information object and representation object were not specified for ", - "the same feature: ", object@name, " (info) and ", data@name, " (representation)")) + "the same feature: ", object@name, " (info) and ", data@name, " (representation)" + )) } # Copy contents @@ -370,7 +396,8 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersCluster", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Determine if the current feature is required, and skip if not. @@ -408,30 +435,38 @@ setMethod( cluster_table <- lapply( feature_info_list, function(x, show_weights) { - # If cluster parameters are not set, skip. - if (is.null(x@cluster_parameters)) return(NULL) - if (show_weights) { - return(data.table::data.table( - "cluster_name" = x@cluster_parameters@cluster_name, - "feature_name" = x@cluster_parameters@cluster_features, - "feature_required" = x@cluster_parameters@cluster_features %in% x@cluster_parameters@required_features, - "weight" = x@cluster_parameters@weight)) + if (is.null(x@cluster_parameters)) { + # If cluster parameters are not set (e.g. for familiarEnsemble objects), + # treat features as singular. + cluster_data <- list( + "cluster_name" = x@name, + "feature_name" = x@name, + "feature_required" = TRUE + ) + + if (show_weights) cluster_data <- c(cluster_data, list("weight" = 1.0)) } else { - return(data.table::data.table( + cluster_data <- list( "cluster_name" = x@cluster_parameters@cluster_name, "feature_name" = x@cluster_parameters@cluster_features, - "feature_required" = x@cluster_parameters@cluster_features %in% x@cluster_parameters@required_features)) + "feature_required" = x@cluster_parameters@cluster_features %in% x@cluster_parameters@required_features + ) + + if (show_weights) cluster_data <- c(cluster_data, list("weight" = x@cluster_parameters@weight)) } + return(cluster_data) }, - show_weights = show_weights) + show_weights = show_weights + ) # Remove duplicate entries. cluster_table <- unique(data.table::rbindlist( cluster_table, - use.names = TRUE)) + use.names = TRUE + )) return(cluster_table) } @@ -442,7 +477,8 @@ features_before_clustering <- function( features, cluster_table = NULL, feature_info_list = NULL, - representative_only = FALSE) { + representative_only = FALSE +) { # Convert input features to original features # Suppress NOTES due to non-standard evaluation in data.table @@ -452,22 +488,29 @@ features_before_clustering <- function( if (is.null(cluster_table) && is.null(feature_info_list)) { ..error_reached_unreachable_code(paste0( "features_before_clustering: if no cluster_table is provided, ", - "feature_info_list cannot be empty.")) + "feature_info_list cannot be empty." + )) } else if (is.null(cluster_table)) { + # Expressly set selected_features to NULL: selected_features is used to + # create a subset of the feature_info_list, which leads to missing data for + # features that are clustered. cluster_table <- .create_clustering_table( feature_info_list = feature_info_list, - selected_features = features) + selected_features = NULL + ) } # Find original features. if (representative_only) { original_features <- unique( - cluster_table[cluster_name %in% features & feature_required == TRUE]$feature_name) + cluster_table[cluster_name %in% features & feature_required == TRUE]$feature_name + ) } else { original_features <- unique( - cluster_table[cluster_name %in% features]$feature_name) + cluster_table[cluster_name %in% features]$feature_name + ) } # Return original features. @@ -479,12 +522,10 @@ features_before_clustering <- function( features_after_clustering <- function( features, cluster_table = NULL, - feature_info_list = NULL) { + feature_info_list = NULL +) { # Convert input features to features after clustering - # Suppress NOTES due to non-standard evaluation in data.table - feature_name <- NULL - # Check if features are set. if (is_empty(features)) return(NULL) @@ -492,16 +533,18 @@ features_after_clustering <- function( if (is.null(cluster_table) && is.null(feature_info_list)) { ..error_reached_unreachable_code(paste0( "features_after_clustering: if no cluster_table is provided, ", - "feature_info_list may be empty.")) + "feature_info_list may be empty." + )) } else if (is.null(cluster_table)) { cluster_table <- .create_clustering_table( feature_info_list = feature_info_list, - selected_features = features) + selected_features = features + ) } # Find and return feature names after clustering. - return(unique(cluster_table[feature_name %in% features]$cluster_name)) + return(unique(cluster_table$cluster_name[cluster_table$feature_name %in% features])) } @@ -509,17 +552,20 @@ features_after_clustering <- function( set_clustered_data <- function( cluster_table, data, - feature_info_list) { + feature_info_list +) { # Suppress NOTES due to non-standard evaluation in data.table feature_required <- NULL # Only use required data. - cluster_table <- cluster_table[feature_required == TRUE] + if (!all(cluster_table$feature_required)){ + cluster_table <- cluster_table[feature_required == TRUE] + } # For singular clusters or clusters represented by a single feature, simply # return the data in the respective column. - if (nrow(cluster_table) == 1) return(data@data[[cluster_table$feature_name]]) + if (nrow(cluster_table) == 1L) return(data@data[[cluster_table$feature_name]]) # Add weighted. Instantiate with 0s. feature_values <- numeric(nrow(data@data)) @@ -528,7 +574,8 @@ set_clustered_data <- function( for (current_feature in cluster_table$feature_name) { feature_values <- feature_values + apply_feature_info_parameters( object = feature_info_list[[current_feature]]@cluster_parameters, - data = data) + data = data + ) } return(feature_values) @@ -572,7 +619,8 @@ set_clustered_data <- function( } else { ..error_reached_unreachable_code(paste0( ".get_available_cluster_cut_methods: encountered unknown cluster method: ", - cluster_method)) + cluster_method + )) } return(cut_methods) @@ -598,7 +646,8 @@ set_clustered_data <- function( ..error_reached_unreachable_code(paste0( ".get_available_cluster_representation_methods: ", "encountered unknown cluster representation method: ", - cluster_method)) + cluster_method + )) } return(representation_methods) diff --git a/R/ClusteringMethod.R b/R/ClusteringMethod.R index a3050b7b..e04e9ac2 100644 --- a/R/ClusteringMethod.R +++ b/R/ClusteringMethod.R @@ -11,14 +11,17 @@ setClass( "cluster_cut_method" = "character", "representation_method" = "character", "similarity_table" = "ANY", - "object" = "ANY"), + "object" = "ANY" + ), prototype = list( "method" = NA_character_, "data_type" = NA_character_, "cluster_cut_method" = "none", "representation_method" = "none", "similarity_table" = NULL, - "object" = NULL)) + "object" = NULL + ) +) ## clusterMethodHierarchical --------------------------------------------------- setClass( @@ -26,41 +29,49 @@ setClass( contains = "clusterMethod", slots = list( "similarity_metric" = "character", - "similarity_threshold" = "numeric"), + "similarity_threshold" = "numeric" + ), prototype = list( "similarity_metric" = NA_character_, - "similarity_threshold" = NA_real_)) + "similarity_threshold" = NA_real_ + ) +) ## clusterMethodHClust --------------------------------------------------------- setClass( "clusterMethodHClust", contains = "clusterMethodHierarchical", slots = list("linkage_method" = "character"), - prototype = list("linkage_method" = NA_character_)) + prototype = list("linkage_method" = NA_character_) +) ## clusterMethodAgnes ---------------------------------------------------------- setClass( "clusterMethodAgnes", contains = "clusterMethodHierarchical", slots = list("linkage_method" = "character"), - prototype = list("linkage_method" = NA_character_)) + prototype = list("linkage_method" = NA_character_) +) ## clusterMethodDiana ---------------------------------------------------------- setClass( "clusterMethodDiana", - contains = "clusterMethodHierarchical") + contains = "clusterMethodHierarchical" +) ## clusterMethodPAM ------------------------------------------------------------ setClass( "clusterMethodPAM", contains = "clusterMethod", slots = list("similarity_metric" = "character"), - prototype = list("similarity_metric" = "character")) + prototype = list("similarity_metric" = "character") +) ## clusterMethodNone ----------------------------------------------------------- setClass( "clusterMethodNone", - contains = "clusterMethod") + contains = "clusterMethod" +) @@ -72,21 +83,27 @@ setClass( slots = list( "data" = "ANY", "similarity_metric" = "character", - "data_type" = "character"), + "data_type" = "character" + ), prototype = list( "data" = NULL, "similarity_metric" = NA_character_, - "data_type" = NA_character_)) + "data_type" = NA_character_ + ) +) ## noSimilarityTable ----------------------------------------------------------- setClass( "noSimilarityTable", slots = list( "data" = "ANY", - "data_type" = "character"), + "data_type" = "character" + ), prototype = list( "data" = NULL, - "data_type" = NA_character_)) + "data_type" = NA_character_ + ) +) @@ -97,16 +114,20 @@ setClass( "clusteringObject", slots = list( "representation_method" = "character", - "cluster_features" = "character"), + "cluster_features" = "character" + ), prototype = list( "representation_method" = "none", - "cluster_features" = NA_character_)) + "cluster_features" = NA_character_ + ) +) ## singularClusteringObject ---------------------------------------------------- setClass( "singularClusteringObject", slots = list("cluster_features" = "character"), - prototype = list("cluster_features" = NA_character_)) + prototype = list("cluster_features" = NA_character_) +) @@ -132,13 +153,15 @@ setMethod( object, cluster_cut_method = NULL, cluster_representation_method = NULL, - ...) { + ... + ) { # Check that data type is set correctly. This is used for many # checks. if (!object@data_type %in% c("feature", "sample", "cluster")) { ..error_reached_unreachable_code(paste0( - "set_object_parameters,clusterMethod: the data_type attribute was not correctly set.")) + "set_object_parameters,clusterMethod: the data_type attribute was not correctly set." + )) } # Cut methods are optional, and default to "none". @@ -150,8 +173,10 @@ setMethod( var_name = ifelse( object@data_type == "cluster", "cluster_cut_method", - paste0(object@data_type, "_cluster_cut_method")), - values = .get_available_cluster_cut_methods(object@method)) + paste0(object@data_type, "_cluster_cut_method") + ), + values = .get_available_cluster_cut_methods(object@method) + ) # Set cluster cut method. object@cluster_cut_method <- cluster_cut_method @@ -166,8 +191,10 @@ setMethod( var_name = ifelse( object@data_type == "cluster", "cluster_representation_method", - paste0(object@data_type, "_cluster_representation_method")), - values = .get_available_cluster_representation_methods(object@method)) + paste0(object@data_type, "_cluster_representation_method") + ), + values = .get_available_cluster_representation_methods(object@method) + ) # Set cluster representation method. object@representation_method <- cluster_representation_method @@ -186,7 +213,8 @@ setMethod( function( object, cluster_similarity_metric, - ...) { + ... + ) { # Call the method for the parent class (clusterMethod) first. object <- methods::callNextMethod() @@ -195,7 +223,8 @@ setMethod( .check_parameter_value_is_valid( x = cluster_similarity_metric, var_name = paste0(object@data_type, "_similarity_metric"), - values = .get_available_similarity_metrics(data_type = object@data_type)) + values = .get_available_similarity_metrics(data_type = object@data_type) + ) # Set similarity metric. object@similarity_metric <- cluster_similarity_metric @@ -214,7 +243,8 @@ setMethod( object, cluster_similarity_metric, cluster_similarity_threshold = NULL, - ...) { + ... + ) { # Call the method for the parent class (clusterMethod) first. object <- methods::callNextMethod() @@ -223,7 +253,8 @@ setMethod( .check_parameter_value_is_valid( x = cluster_similarity_metric, var_name = paste0(object@data_type, "_similarity_metric"), - values = .get_available_similarity_metrics(data_type = object@data_type)) + values = .get_available_similarity_metrics(data_type = object@data_type) + ) # Set similarity metric. object@similarity_metric <- cluster_similarity_metric @@ -238,7 +269,9 @@ setMethod( var_name = paste0(object@data_type, "_similarity_threshold"), range = get_similarity_range( similarity_metric = object@similarity_metric, - as_distance = TRUE)) + as_distance = TRUE + ) + ) # Attach to object. object@similarity_threshold <- cluster_similarity_threshold @@ -257,7 +290,8 @@ setMethod( function( object, cluster_linkage_method, - ...) { + ... + ) { # Call next method (clusterMethodHierarchical). This will also call the # method for its parent method (clusterMethod). @@ -267,7 +301,8 @@ setMethod( .check_parameter_value_is_valid( x = cluster_linkage_method, var_name = paste0(object@data_type, "_linkage_method"), - values = .get_available_linkage_methods(cluster_method = object@method)) + values = .get_available_linkage_methods(cluster_method = object@method) + ) # attach to object. object@linkage_method <- cluster_linkage_method @@ -285,7 +320,8 @@ setMethod( function( object, cluster_linkage_method, - ...) { + ... + ) { # Call next method (clusterMethodHierarchical). This will also call the # method for its parent method (clusterMethod). @@ -295,7 +331,8 @@ setMethod( .check_parameter_value_is_valid( x = cluster_linkage_method, var_name = paste0(object@data_type, "_linkage_method"), - values = .get_available_linkage_methods(cluster_method = object@method)) + values = .get_available_linkage_methods(cluster_method = object@method) + ) # attach to object. object@linkage_method <- cluster_linkage_method @@ -328,14 +365,16 @@ setMethod( "set_similarity_table", signature( object = "missing", - data = "dataObject"), + data = "dataObject" + ), function( object, data, feature_info_list, similarity_metric, data_type, - ...) { + ... + ) { # For calls where we just want to create the similarity table, e.g. # in ..extract_feature_similarity. Here we create a generic @@ -343,14 +382,16 @@ setMethod( object <- methods::new( "clusterMethodPAM", data_type = data_type, - similarity_metric = similarity_metric) + similarity_metric = similarity_metric + ) # Pass to set_similarity_table. object <- set_similarity_table( object = object, data = data, feature_info_list = feature_info_list, - ...) + ... + ) # Return the table itself. return(object@similarity_table@data) @@ -364,19 +405,22 @@ setMethod( "set_similarity_table", signature( object = "clusterMethodNone", - data = "dataObject"), + data = "dataObject" + ), function( object, data, feature_info_list, - ...) { + ... + ) { # Try to get similarity table similarity_table <- .set_similarity_table( object = object, data = data, feature_info_list = feature_info_list, - ...) + ... + ) # Set the similarity_table attribute. object@similarity_table <- similarity_table @@ -392,31 +436,36 @@ setMethod( "set_similarity_table", signature( object = "clusterMethod", - data = "dataObject"), + data = "dataObject" + ), function( object, data, feature_info_list, - ...) { + ... + ) { # Try to get similarity table similarity_table <- .set_similarity_table( object = object, data = data, feature_info_list = feature_info_list, - ...) + ... + ) # If setting the similarity table does not work, we cannot create clusters. # Switch to "none" method instead. if (is.null(similarity_table)) { object <- create_cluster_method_object( cluster_method = "none", - data_type = object@data_type) + data_type = object@data_type + ) return(set_similarity_table( object = object, data = data, - feature_info_list = feature_info_list)) + feature_info_list = feature_info_list + )) } # Set the similarity_table attribute. @@ -434,12 +483,14 @@ setMethod( ".set_similarity_table", signature( object = "clusterMethodNone", - data = "dataObject"), + data = "dataObject" + ), function( object, data, feature_info_list, - ...) { + ... + ) { # Specific method for objects that indicate that no clustering should be # performed. @@ -453,7 +504,8 @@ setMethod( if (!(setequal(feature_columns, get_available_features(feature_info_list = feature_info_list)))) { ..error_reached_unreachable_code(paste0( ".set_similarity_table,clusterMethodNone,dataObject: features in data and the ", - "feature info list are expect to be the same, but were not.")) + "feature info list are expect to be the same, but were not." + )) } if (object@data_type %in% c("cluster", "feature")) { @@ -467,14 +519,16 @@ setMethod( ..error_reached_unreachable_code(paste0( ".set_similarity_table,clusterMethodNone,dataObject: ", "encountered an unknown data_type: ", - object@data_type)) + object@data_type + )) } # Create (no) similarity table. similarity_table <- methods::new( "noSimilarityTable", "data" = similarity_data, - "data_type" = object@data_type) + "data_type" = object@data_type + ) return(similarity_table) @@ -488,14 +542,16 @@ setMethod( ".set_similarity_table", signature( object = "clusterMethod", - data = "dataObject"), + data = "dataObject" + ), function( object, data, feature_info_list, cl = NULL, verbose = FALSE, - ...) { + ... + ) { # Check that the data are not empty. if (is_empty(data)) return(NULL) @@ -507,7 +563,8 @@ setMethod( if (!(setequal(feature_columns, get_available_features(feature_info_list = feature_info_list)))) { ..error_reached_unreachable_code(paste0( ".set_similarity_table,clusterMethod,dataObject: features in data and ", - "the feature info list are expect to be the same, but were not.")) + "the feature info list are expect to be the same, but were not." + )) } if (object@data_type %in% c("cluster", "feature")) { @@ -518,7 +575,8 @@ setMethod( similarity_metric = object@similarity_metric, feature_info_list = feature_info_list, cl = cl, - verbose = verbose) + verbose = verbose + ) } else if (object@data_type == "sample") { @@ -528,12 +586,14 @@ setMethod( similarity_metric = object@similarity_metric, feature_info_list = feature_info_list, cl = cl, - verbose = verbose) + verbose = verbose + ) } else { ..error_reached_unreachable_code(paste0( ".set_similarity_table,clusterMethod,dataObject: encountered an unknown data_type: ", - object@data_type)) + object@data_type + )) } # Create similarity table. @@ -541,7 +601,8 @@ setMethod( "similarityTable", "data" = similarity_data, "similarity_metric" = object@similarity_metric, - "data_type" = object@data_type) + "data_type" = object@data_type + ) # Set similarity table, return(similarity_table) @@ -573,20 +634,23 @@ setMethod( if (!is.null(object@data)) { element_names <- unique(c( object@data$feature_name_1, - object@data$feature_name_2)) + object@data$feature_name_2 + )) } } else if (object@data_type == "sample") { if (!is.null(object@data)) { element_names <- unique(c( object@data$sample_1, - object@data$sample_2)) + object@data$sample_2 + )) } } else { ..error_reached_unreachable_code(paste0( "get_similarity_names,similarityTable: encountered an unknown data_type: ", - object@data_type)) + object@data_type + )) } return(element_names) @@ -608,7 +672,8 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "get_similarity_names,noSimilarityTable: encountered an unknown data_type: ", - object@data_type)) + object@data_type + )) } return(element_names) @@ -632,13 +697,13 @@ setMethod( set_similarity_table, args = c( list("object" = object), - list(...))) + list(...) + ) + ) } # Push to get_distance_matrix for similarity tables. - return(get_distance_table( - object = object@similarity_table, - ...)) + return(get_distance_table(object = object@similarity_table, ...)) } ) @@ -651,7 +716,8 @@ setMethod( function( object, include_diagonal = TRUE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table value <- NULL @@ -668,45 +734,45 @@ setMethod( # Find elements from the distance table. elements <- union( - lower_triangle[[element_names[1]]], - lower_triangle[[element_names[2]]]) + lower_triangle[[element_names[1L]]], + lower_triangle[[element_names[2L]]] + ) # Convert similarity to distance. lower_triangle[, "value" := convert_similarity_to_distance( x = value, - similarity_metric = similarity_metric)] + similarity_metric = similarity_metric + )] # Add in other triangle of the table by switching around the columns. upper_triangle <- data.table::copy(lower_triangle) data.table::setnames( upper_triangle, old = element_names, - new = rev(element_names)) + new = rev(element_names) + ) if (include_diagonal) { # Create diagonals that always have distance 0. diagonal_table <- data.table::data.table( "element_1" = elements, "element_2" = elements, - "value" = as.double(0)) + "value" = as.double(0.0) + ) # Add names to the diagonal table. data.table::setnames( diagonal_table, old = c("element_1", "element_2"), - new = element_names) + new = element_names + ) # Combine to single, long, table - distance_table <- rbind( - lower_triangle, - diagonal_table, - upper_triangle) + distance_table <- rbind(lower_triangle, diagonal_table, upper_triangle) } else { # Combine upper and lower triangles. - distance_table <- rbind( - lower_triangle, - upper_triangle) + distance_table <- rbind(lower_triangle, upper_triangle) } return(distance_table) @@ -742,7 +808,9 @@ setMethod( set_similarity_table, args = c( list("object" = object), - list(...))) + list(...) + ) + ) } return(get_distance_matrix(object = object@similarity_table)) @@ -765,22 +833,43 @@ setMethod( # Convert a similarity table to a full distance table first. distance_table <- get_distance_table(object = object) + # Check if the element_names appear as instance names. This will cause an + # error if not handled correctly. + if (length(intersect( + c(distance_table[[element_names[1L]]], distance_table[[element_names[2L]]]), + element_names + )) > 0L) { + # If any sample or feature names match the column name, add a + # low-collision randomly generated string as a prefix to the column names. + random_prefix <- paste0("A", rstring(64L), "_") + + data.table::setnames( + distance_table, + old = element_names, + new = paste0(random_prefix, element_names) + ) + + element_names <- paste0(random_prefix, element_names) + } + # Create n x n table distance_table <- data.table::dcast( distance_table, - stats::as.formula(paste(element_names[1], "~", element_names[2])), - value.var = "value") + stats::as.formula(paste(element_names[1L], "~", element_names[2L])), + value.var = "value" + ) # Ensure that the diagonal is formed by the pairwise distance of the same # feature, i.e. 0.0. data.table::setcolorder( distance_table, - neworder = c(element_names[1], as.character(distance_table[[element_names[1]]]))) + neworder = c(element_names[1L], as.character(distance_table[[element_names[1L]]])) + ) # Convert to dissimilarity matrix by first getting the labels # corresponding to each sample / feature, and then completing the # converted distance table. - element_labels <- as.character(distance_table[[element_names[1]]]) + element_labels <- as.character(distance_table[[element_names[1L]]]) distance_table <- as.matrix(distance_table[, mget(element_labels)]) rownames(distance_table) <- element_labels distance_matrix <- stats::as.dist(distance_table) @@ -828,7 +917,9 @@ setMethod( get_distance_matrix, args = c( list("object" = object), - list(...))) + list(...) + ) + ) # Skip if the distance matrix is NULL. if (is.null(distance_matrix)) return(object) @@ -845,12 +936,14 @@ setMethod( if (is_package_installed("fastcluster")) { object@object <- fastcluster::hclust( d = distance_matrix, - method = linkage_method) + method = linkage_method + ) } else { object@object <- stats::hclust( d = distance_matrix, - method = linkage_method) + method = linkage_method + ) } return(object) @@ -870,14 +963,17 @@ setMethod( get_distance_matrix, args = c( list("object" = object), - list(...))) + list(...) + ) + ) # Skip if the distance matrix is NULL. if (is.null(distance_matrix)) return(object) require_package( x = "cluster", - purpose = "to cluster similar features together") + purpose = "to cluster similar features together" + ) # Compute agglomerative hierarchical clustering of the data set object@object <- stats::as.hclust( @@ -885,7 +981,8 @@ setMethod( x = distance_matrix, method = object@linkage_method, keep.diss = FALSE, - keep.data = FALSE) + keep.data = FALSE + ) ) return(object) @@ -905,21 +1002,25 @@ setMethod( get_distance_matrix, args = c( list("object" = object), - list(...))) + list(...) + ) + ) # Skip if the distance matrix is NULL. if (is.null(distance_matrix)) return(object) require_package( x = "cluster", - purpose = "to cluster similar features together") + purpose = "to cluster similar features together" + ) # Compute DIvisive ANAlysis hierarchical clustering of the data set object@object <- stats::as.hclust( cluster::diana( x = distance_matrix, keep.diss = FALSE, - keep.data = FALSE) + keep.data = FALSE + ) ) return(object) @@ -937,7 +1038,8 @@ setMethod( function( object, as_cluster_objects = TRUE, - ...) { + ... + ) { cluster_table <- NULL if (object@cluster_cut_method == "silhouette") { @@ -969,14 +1071,16 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "create_clusters,clusterMethodHierarchical: encountered an unknown cluster cut method: ", - object@cluster_method)) + object@cluster_method + )) } # Determine how to return the results. if (as_cluster_objects) { return(.convert_cluster_table_to_cluster_objects( cluster_table = cluster_table, - representation_method = object@representation_method)) + representation_method = object@representation_method + )) } else { return(cluster_table) @@ -993,7 +1097,8 @@ setMethod( function( object, as_cluster_objects = TRUE, - ...) { + ... + ) { if (object@cluster_cut_method %in% c("silhouette", "fixed_cut")) { # Silhouette and fixed cut are implemented for the parent class @@ -1018,14 +1123,16 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "create_clusters,clusterMethodHClust: encountered an unknown cluster cut method: ", - object@cluster_method)) + object@cluster_method + )) } # Determine how to return the results. if (as_cluster_objects) { return(.convert_cluster_table_to_cluster_objects( cluster_table = cluster_table, - representation_method = object@representation_method)) + representation_method = object@representation_method + )) } else { return(cluster_table) @@ -1042,7 +1149,8 @@ setMethod( function( object, as_cluster_objects = TRUE, - ...) { + ... + ) { cluster_table <- NULL if (object@cluster_cut_method == "silhouette") { @@ -1063,14 +1171,16 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "create_clusters,clusterMethodPAM: encountered an unknown cluster cut method: ", - object@cluster_method)) + object@cluster_method + )) } # Determine how to return the results. if (as_cluster_objects) { return(.convert_cluster_table_to_cluster_objects( cluster_table = cluster_table, - representation_method = object@representation_method)) + representation_method = object@representation_method + )) } else { return(cluster_table) @@ -1087,7 +1197,8 @@ setMethod( function( object, as_cluster_objects = TRUE, - ...) { + ... + ) { # Add names. Each cluster is singular. cluster_table <- .cluster_by_generic(object = object) @@ -1096,7 +1207,8 @@ setMethod( if (as_cluster_objects) { return(.convert_cluster_table_to_cluster_objects( cluster_table = cluster_table, - representation_method = "none")) + representation_method = "none" + )) } else { return(cluster_table) @@ -1131,14 +1243,16 @@ setMethod( return(data.table::data.table( "name" = element_names, "cluster_id" = seq_along(element_names), - "label_order" = seq_along(element_names))) + "label_order" = seq_along(element_names) + )) } } else { return(data.table::data.table( "name" = object@object$labels[object@object$order], "cluster_id" = seq_along(object@object$labels), - "label_order" = seq_along(object@object$labels))) + "label_order" = seq_along(object@object$labels) + )) } } ) @@ -1160,7 +1274,8 @@ setMethod( return(data.table::data.table( "name" = element_names, "cluster_id" = seq_along(element_names), - "label_order" = seq_along(element_names))) + "label_order" = seq_along(element_names) + )) } ) @@ -1179,19 +1294,23 @@ setMethod( get_distance_matrix, args = c( list("object" = object), - list(...))) + list(...) + ) + ) # Skip if the distance matrix is NULL. if (is.null(distance_matrix)) return(NULL) require_package( x = "cluster", - purpose = "to cluster similar features together") + purpose = "to cluster similar features together" + ) # Determine optimal numbers of clusters based on silhouette n_clusters <- .optimise_cluster_silhouette( object = object, - distance_matrix = distance_matrix) + distance_matrix = distance_matrix + ) # PAM clustering doesn't like it when you n_clusters is equal to the number # of features. @@ -1202,12 +1321,14 @@ setMethod( x = distance_matrix, k = n_clusters, keep.diss = FALSE, - keep.data = FALSE) + keep.data = FALSE + ) return(data.table::data.table( "name" = names(cluster_object$clustering), "cluster_id" = cluster_object$clustering, - "label_order" = seq_along(cluster_object$clustering))) + "label_order" = seq_along(cluster_object$clustering) + )) } ) @@ -1227,7 +1348,9 @@ setMethod( get_distance_matrix, args = c( list("object" = object), - list(...))) + list(...) + ) + ) # Skip if the distance matrix is NULL. if (is.null(distance_matrix)) return(NULL) @@ -1242,12 +1365,14 @@ setMethod( require_package( x = "cluster", - purpose = "to cluster similar features together by silhouette") + purpose = "to cluster similar features together by silhouette" + ) # Determine optimal numbers of clusters based on silhouette n_clusters <- .optimise_cluster_silhouette( object = object, - distance_matrix = distance_matrix) + distance_matrix = distance_matrix + ) # PAM clustering doesn't like it when you n_clusters is equal to the # number of features. @@ -1256,17 +1381,20 @@ setMethod( # Cut the tree for the optimal number of clusters cluster_object <- stats::cutree( tree = stats::as.hclust(object@object), - k = n_clusters) + k = n_clusters + ) # Set initial cluster table. cluster_table <- data.table::data.table( "name" = names(cluster_object), - "cluster_id" = cluster_object) + "cluster_id" = cluster_object + ) # Get an ordering table. order_table <- data.table::data.table( "name" = object@object$labels[object@object$order], - "label_order" = seq_along(object@object$labels)) + "label_order" = seq_along(object@object$labels) + ) # Insert label order into the cluster table. cluster_table <- cluster_table[order_table, on = .NATURAL] @@ -1297,22 +1425,26 @@ setMethod( # Compute the height at which the dendrogram should be cut. cut_height <- convert_similarity_to_distance( x = object@similarity_threshold, - similarity_metric = object@similarity_metric) + similarity_metric = object@similarity_metric + ) # Cut the dendrogram at the given height. cluster_object <- stats::cutree( tree = stats::as.hclust(object@object), - h = cut_height) + h = cut_height + ) # Set initial cluster table. cluster_table <- data.table::data.table( "name" = names(cluster_object), - "cluster_id" = cluster_object) + "cluster_id" = cluster_object + ) # Get an ordering table. order_table <- data.table::data.table( "name" = object@object$labels[object@object$order], - "label_order" = seq_along(object@object$labels)) + "label_order" = seq_along(object@object$labels) + ) # Insert label order into the cluster table. cluster_table <- cluster_table[order_table, on = .NATURAL] @@ -1337,19 +1469,23 @@ setMethod( require_package( x = "dynamicTreeCut", - purpose = "to cluster similar features together through dynamic dendrogram cutting") + purpose = "to cluster similar features together through dynamic dendrogram cutting" + ) # Compute the height at which the dendrogram should be cut anyway. cut_height <- convert_similarity_to_distance( x = object@similarity_threshold, - similarity_metric = object@similarity_metric) + similarity_metric = object@similarity_metric + ) - if (length(get_similarity_names(object@similarity_table)) == 2) { + if (length(get_similarity_names(object@similarity_table)) == 2L) { # For two features, dynamicTreeCut seems to ignore maxTreeHeight. - if (convert_similarity_to_distance( - x = object@similarity_table@data$value, - similarity_metric = object@similarity_metric) <= cut_height) { - + if ( + convert_similarity_to_distance( + x = object@similarity_table@data$value, + similarity_metric = object@similarity_metric + ) <= cut_height + ) { cluster_ids <- c(1L, 1L) } else { @@ -1365,8 +1501,10 @@ setMethod( dendro = object@object, maxTreeHeight = cut_height, deepSplit = TRUE, - minModuleSize = 1), - error = identity) + minModuleSize = 1L + ), + error = identity + ) # Check that dynamic cutting does not produce an error. if (inherits(cluster_ids, "error")) return(.cluster_by_fixed_cut(object, ...)) @@ -1379,7 +1517,8 @@ setMethod( cluster_table <- data.table::data.table( "name" = object@object$labels[object@object$order], "cluster_id" = cluster_ids, - "label_order" = seq_along(object@object$labels)) + "label_order" = seq_along(object@object$labels) + ) return(cluster_table) } @@ -1394,7 +1533,8 @@ create_cluster_method_object <- function( cluster_cut_method = NULL, cluster_similarity_threshold = NULL, cluster_similarity_metric = NULL, - cluster_representation_method = NULL) { + cluster_representation_method = NULL +) { # Check that method is applicable. .check_parameter_value_is_valid( @@ -1402,14 +1542,17 @@ create_cluster_method_object <- function( var_name = ifelse( data_type == "cluster", "cluster_method", - paste0(data_type, "_cluster_method")), - values = .get_available_cluster_methods()) + paste0(data_type, "_cluster_method") + ), + values = .get_available_cluster_methods() + ) # Check that data_type is valid. .check_parameter_value_is_valid( x = data_type, var_name = "data_type", - values = c("feature", "cluster", "sample")) + values = c("feature", "cluster", "sample") + ) if (cluster_method == "none") { object <- methods::new("clusterMethodNone") @@ -1429,7 +1572,8 @@ create_cluster_method_object <- function( } else { ..error_reached_unreachable_code(paste0( "create_cluster_method_object: encountered an unknown cluster method: ", - cluster_method)) + cluster_method + )) } # Cluster method and data type are always set. @@ -1443,7 +1587,8 @@ create_cluster_method_object <- function( cluster_cut_method = cluster_cut_method, cluster_similarity_threshold = cluster_similarity_threshold, cluster_similarity_metric = cluster_similarity_metric, - cluster_representation_method = cluster_representation_method) + cluster_representation_method = cluster_representation_method + ) return(object) } @@ -1452,7 +1597,8 @@ create_cluster_method_object <- function( .convert_cluster_table_to_cluster_objects <- function( cluster_table, - representation_method) { + representation_method +) { # Check that the cluster table is not empty. if (is_empty(cluster_table)) return(NULL) @@ -1461,33 +1607,38 @@ create_cluster_method_object <- function( if (!(all(c("name", "cluster_id") %in% colnames(cluster_table)))) { ..error_reached_unreachable_code(paste0( ".convert_cluster_table_to_cluster_objects: expected name and ", - "cluster_id columns were not found.")) + "cluster_id columns were not found." + )) } return(lapply( split(cluster_table, by = "cluster_id"), ..convert_cluster_table_to_cluster_objects, - representation_method = representation_method)) + representation_method = representation_method + )) } ..convert_cluster_table_to_cluster_objects <- function( cluster_table, - representation_method) { + representation_method +) { - if (nrow(cluster_table) == 1) { + if (nrow(cluster_table) == 1L) { # Create singular cluster object. object <- methods::new( "singularClusteringObject", - cluster_features = cluster_table$name) + cluster_features = cluster_table$name + ) } else { # Create cluster object with multiple features or instances. object <- methods::new( "clusteringObject", cluster_features = cluster_table$name, - representation_method = representation_method) + representation_method = representation_method + ) } return(object) @@ -1498,20 +1649,22 @@ create_cluster_method_object <- function( .optimise_cluster_silhouette <- function( object, distance_matrix, - tol = 0.01) { + tol = 0.01 +) { # Determine the number of features. n_features <- length(get_similarity_names(object@similarity_table)) highly_similar_distance <- convert_similarity_to_distance( x = get_high_similarity_threshold(similarity_metric = object@similarity_metric), - similarity_metric = object@similarity_metric) + similarity_metric = object@similarity_metric + ) # Check problematic values. - if (n_features == 1) { + if (n_features == 1L) { return(1L) - } else if (n_features == 2) { + } else if (n_features == 2L) { if (all(distance_matrix <= highly_similar_distance)) { # Zero distance can be safely imputed as being identical. @@ -1528,26 +1681,27 @@ create_cluster_method_object <- function( # The optimiser doesn't like a singular interval, which occurs for n_features # == 3. - if (n_features == 3) return(2L) + if (n_features == 3L) return(2L) # Set k to test. - k_test <- seq(2, n_features - 1) - silhouette_score <- numeric(n_features - 2) - silhouette_gradient <- numeric(max(c(0, n_features - 4))) + k_test <- seq(2L, n_features - 1L) + silhouette_score <- numeric(n_features - 2L) + silhouette_gradient <- numeric(max(c(0L, n_features - 4L))) for (k in k_test) { # Compute average silhouette. - silhouette_score[k - 1] <- ..optimise_cluster_silhouette( + silhouette_score[k - 1L] <- ..optimise_cluster_silhouette( k = k, distance_matrix = distance_matrix, - object = object) + object = object + ) # Compute gradient as a symmetric difference coefficient. - if (k > 3) { - silhouette_gradient[k - 3] <- 0.5 * (silhouette_score[k - 1] - silhouette_score[k - 3]) + if (k > 3L) { + silhouette_gradient[k - 3L] <- 0.5 * (silhouette_score[k - 1L] - silhouette_score[k - 3L]) # Stop if the gradient is 0 or negative 3 times. - if (sum(silhouette_gradient[seq(1, k - 3)] <= 0.0) > 2) break + if (sum(silhouette_gradient[seq(1L, k - 3L)] <= 0.0) > 2L) break } } @@ -1567,13 +1721,14 @@ create_cluster_method_object <- function( ..optimise_cluster_silhouette <- function( k, distance_matrix, - object) { + object +) { # Suppress NOTES due to non-standard evaluation in data.table sil_width <- cluster_size <- NULL # Round k to integer value. - k <- round(k, digits = 0) + k <- round(k, digits = 0L) if (is(object, "clusterMethodPAM")) { # Generate partioning around medoids cluster @@ -1581,21 +1736,27 @@ create_cluster_method_object <- function( x = distance_matrix, k = k, keep.diss = FALSE, - keep.data = FALSE) + keep.data = FALSE + ) # Extract silhouette table silhouette_table <- data.table::as.data.table( cluster_object$silinfo$widths, - keep.rownames = FALSE) + keep.rownames = FALSE + ) # Compute the size and average silhouette in each cluster - silhouette_table <- silhouette_table[, list( - "average_cluster_silhouette" = mean(sil_width), - "cluster_size" = .N), - by = "cluster"] + silhouette_table <- silhouette_table[ + , + list( + "average_cluster_silhouette" = mean(sil_width), + "cluster_size" = .N + ), + by = "cluster" + ] # Maintain only non-singular clusters - silhouette_table <- silhouette_table[cluster_size > 1] + silhouette_table <- silhouette_table[cluster_size > 1L] # Return average silhouette in the formed non-singular clusters. if (!is_empty(silhouette_table)) { @@ -1609,10 +1770,9 @@ create_cluster_method_object <- function( # Compute silhouette. silhouette_matrix <- cluster::silhouette( - x = stats::cutree( - tree = stats::as.hclust(object@object), - k = k), - dist = distance_matrix) + x = stats::cutree(tree = stats::as.hclust(object@object), k = k), + dist = distance_matrix + ) # Parse to matrix by changing the class. class(silhouette_matrix) <- "matrix" @@ -1620,16 +1780,21 @@ create_cluster_method_object <- function( # Extract silhouette table silhouette_table <- data.table::as.data.table( silhouette_matrix, - keep.rownames = FALSE) + keep.rownames = FALSE + ) # Compute the size and average silhouette in each cluster - silhouette_table <- silhouette_table[, list( - "average_cluster_silhouette" = mean(sil_width), - "cluster_size" = .N), - by = "cluster"] + silhouette_table <- silhouette_table[ + , + list( + "average_cluster_silhouette" = mean(sil_width), + "cluster_size" = .N + ), + by = "cluster" + ] # Maintain only non-singular clusters - silhouette_table <- silhouette_table[cluster_size > 1] + silhouette_table <- silhouette_table[cluster_size > 1L] # Return average silhouette in the formed non-singular clusters. if (!is_empty(silhouette_table)) { @@ -1641,7 +1806,8 @@ create_cluster_method_object <- function( } else { ..error_reached_unreachable_code( - "..optimise_cluster_silhouette: unknown clustering object encountered.") + "..optimise_cluster_silhouette: unknown clustering object encountered." + ) } } @@ -1656,7 +1822,8 @@ create_cluster_method_object <- function( cluster_representation_method = NULL, data_type = "cluster", test_required_packages = TRUE, - message_type = "error") { + message_type = "error" +) { # Perform checks by creating the relevant object. This checks whether the # applicable parameters are set. @@ -1667,7 +1834,8 @@ create_cluster_method_object <- function( cluster_cut_method = cluster_cut_method, cluster_similarity_threshold = cluster_similarity_threshold, cluster_similarity_metric = cluster_similarity_metric, - cluster_representation_method = cluster_representation_method) + cluster_representation_method = cluster_representation_method + ) if (test_required_packages) { # Check whether the cluster package has been installed. @@ -1675,7 +1843,8 @@ create_cluster_method_object <- function( require_package( x = "cluster", purpose = "to compute similarity between features or instances", - message_type = message_type) + message_type = message_type + ) } # Check whether the dynamicTreeCut package has been installed. @@ -1684,7 +1853,8 @@ create_cluster_method_object <- function( require_package( x = "dynamicTreeCut", purpose = "to cut dendrograms dynamically", - message_type = message_type) + message_type = message_type + ) } } @@ -1695,8 +1865,10 @@ create_cluster_method_object <- function( x = "nnet", purpose = paste0( "to compute log-likelihood pseudo R2 similarity using the ", - object@similarity_metric, " metric"), - message_type = message_type) + object@similarity_metric, " metric" + ), + message_type = message_type + ) } } } diff --git a/R/CombatNormalisation.R b/R/CombatNormalisation.R index 6f1fe585..8a34d1b1 100644 --- a/R/CombatNormalisation.R +++ b/R/CombatNormalisation.R @@ -10,14 +10,16 @@ setClass( "featureInfoParametersNormalisationParametricCombat", contains = "featureInfoParametersNormalisationShiftScale", slots = list("method" = "character"), - prototype = list("method" = NA_character_)) + prototype = list("method" = NA_character_) +) # Non-parametric ComBat object ------------------------------------------------- setClass( "featureInfoParametersNormalisationNonParametricCombat", contains = "featureInfoParametersNormalisationShiftScale", slots = list("method" = "character"), - prototype = list("method" = NA_character_)) + prototype = list("method" = NA_character_) +) # Only included in .get_available_batch_normalisation_methods @@ -32,17 +34,19 @@ setClass( -# add_feature_info_parameters (parametric ComBat, data.table) ------------------ +# add_feature_info_parameters (parametric ComBat, numeric) --------------------- setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationParametricCombat", - data = "data.table"), + data = "numeric" + ), function( object, data, batch_parameter_data, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table feature <- batch_id <- NULL @@ -55,7 +59,8 @@ setMethod( replacement_object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, method = "standardisation", - batch = object@batch) + batch = object@batch + ) # Select the current feature and batch from batch_parameter_data. batch_parameter_data <- batch_parameter_data[feature == object@name & batch_id == object@batch, ] @@ -65,7 +70,8 @@ setMethod( if (is_empty(batch_parameter_data)) { return(add_feature_info_parameters( object = replacement_object, - data = data)) + data = data + )) } # If shift and scale parameters are not finite, attempt to use univariate @@ -73,7 +79,8 @@ setMethod( if (!is.finite(batch_parameter_data$norm_shift) || !is.finite(batch_parameter_data$norm_scale)) { return(add_feature_info_parameters( object = replacement_object, - data = data)) + data = data + )) } # Set shift and scale parameters. @@ -92,18 +99,19 @@ setMethod( -# add_feature_info_parameters (non-parametric ComBat, data.table) -------------- +# add_feature_info_parameters (non-parametric ComBat, numeric) ----------------- setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationNonParametricCombat", - data = "data.table"), + data = "numeric" + ), function( object, data, batch_parameter_data, - ...) { - + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table feature <- batch_id <- NULL @@ -115,7 +123,8 @@ setMethod( replacement_object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, method = "standardisation", - batch = object@batch) + batch = object@batch + ) # Select the current feature and batch from batch_parameter_data. batch_parameter_data <- batch_parameter_data[feature == object@name & batch_id == object@batch, ] @@ -125,7 +134,8 @@ setMethod( if (is_empty(batch_parameter_data)) { return(add_feature_info_parameters( object = replacement_object, - data = data)) + data = data + )) } # If shift and scale parameters are not finite, attempt to use @@ -133,7 +143,8 @@ setMethod( if (!is.finite(batch_parameter_data$norm_shift) || !is.finite(batch_parameter_data$norm_scale)) { return(add_feature_info_parameters( object = replacement_object, - data = data)) + data = data + )) } # Set shift and scale parameters. @@ -162,22 +173,27 @@ setMethod( batch_id_column <- get_id_columns(single_column = "batch") # Set a minimum threshold for valid sample sizes - min_valid_samples <- 10 - min_valid_features <- 3 + min_valid_samples <- 10L + min_valid_features <- 3L # Convert the table from wide to long format x <- data.table::melt( data[, mget(c(batch_id_column, feature_names))], id.vars = batch_id_column, variable.name = "feature", - value.name = "value") + value.name = "value" + ) # Sum the number of instances with a valid value, and determine whether all # values are singular. - aggregate_table <- x[, list( - "n" = sum(is.finite(value)), - "invariant" = is_singular_data(value)), - by = c(batch_id_column, "feature")] + aggregate_table <- x[ + , + list( + "n" = sum(is.finite(value)), + "invariant" = is_singular_data(value) + ), + by = c(batch_id_column, "feature") + ] # A feature/batch combination is valid if it is not invariant and has # sufficient instances with a finite value. @@ -206,7 +222,7 @@ setMethod( z[, "gamma_hat" := mean(value), by = c(batch_id_column, "feature")] # Determine the variance (delta_hat_squared) of each feature in each batch. - z[, "delta_hat_squared" := 1 / n * sum((value - gamma_hat)^2.0), by = c(batch_id_column, "feature")] + z[, "delta_hat_squared" := 1.0 / n * sum((value - gamma_hat)^2.0), by = c(batch_id_column, "feature")] } else { z <- NULL @@ -220,9 +236,10 @@ setMethod( .combat_iterative_parametric_bayes_solver <- function( z, tolerance = 0.0001, - max_iterations = 20, + max_iterations = 20L, cl = NULL, - progress_bar = FALSE) { + progress_bar = FALSE +) { # In the empirical Bayes approach with parametric priors, the posterior # estimations of gamma and delta_squared are iteratively optimised. @@ -263,7 +280,8 @@ setMethod( progress_bar = progress_bar, z_short = z_short, tolerance = tolerance, - max_iterations = max_iterations) + max_iterations = max_iterations + ) # Concatenate to single table. batch_parameters <- data.table::rbindlist(batch_parameters) @@ -277,7 +295,8 @@ setMethod( z, z_short, tolerance, - max_iterations) { + max_iterations +) { # Perform the actual parametric estimations within each batch. Called from the # .combat_iterative_parametric_bayes_solver function @@ -290,17 +309,18 @@ setMethod( batch_id_column <- get_id_columns(single_column = "batch") # Limit z_short to the current batch. - current_batch_id <- z[[batch_id_column]][1] + current_batch_id <- z[[batch_id_column]][1L] z_short <- data.table::copy(z_short[batch_id == current_batch_id]) # Initialise conditional posteriors. 1 value per feature per batch. z_short[, ":="( "gamma_star_old" = gamma_hat, - "delta_star_squared_old" = delta_hat_squared)] + "delta_star_squared_old" = delta_hat_squared + )] # Convergence update value. convergence_update <- 1.0 - iteration_count <- 0 + iteration_count <- 0L while (convergence_update > tolerance && iteration_count < max_iterations) { @@ -310,45 +330,53 @@ setMethod( tau_bar_squared = tau_bar_squared, gamma_hat = gamma_hat, delta_star_squared = delta_star_squared_old, - gamma_bar = gamma_bar)] + gamma_bar = gamma_bar + )] # Merge z_short back into z prior to computing the sum squared error. z_new <- merge( x = z[, mget(c(batch_id_column, "feature", "value"))], y = z_short[, mget(c(batch_id_column, "feature", "gamma_star_new"))], by = c(batch_id_column, "feature"), - all = TRUE) + all = TRUE + ) # Compute sum squared error in equation 3.1 for the delta_star_squared posterior. - z_new <- z_new[, list( - "sum_squared_error" = sum((value - gamma_star_new)^2)), - by = c(batch_id_column, "feature")] + z_new <- z_new[ + , + list("sum_squared_error" = sum((value - gamma_star_new)^2.0)), + by = c(batch_id_column, "feature") + ] z_short <- merge( x = z_short, y = z_new, by = c(batch_id_column, "feature"), - all = TRUE) + all = TRUE + ) # Update the conditional delta_star_squared posterior. z_short[, "delta_star_squared_new" := ..combat_delta_squared_posterior( theta_bar = theta_bar, sum_squared_error = sum_squared_error, n = n, - lambda_bar = lambda_bar)] + lambda_bar = lambda_bar + )] # Update convergence convergence_update <- max( abs((z_short$gamma_star_new - z_short$gamma_star_old) / z_short$gamma_star_old), - abs((z_short$delta_star_squared_new - z_short$delta_star_squared_old) / z_short$delta_star_squared_old)) + abs((z_short$delta_star_squared_new - z_short$delta_star_squared_old) / z_short$delta_star_squared_old) + ) # Replace old posterior values z_short[, ":="( "gamma_star_old" = gamma_star_new, "delta_star_squared_old" = delta_star_squared_new, - "sum_squared_error" = NULL)] + "sum_squared_error" = NULL + )] - iteration_count <- iteration_count + 1 + iteration_count <- iteration_count + 1L } # Store delta_star @@ -358,7 +386,8 @@ setMethod( data.table::setnames( x = z_short, old = c("gamma_star_new", "delta_star"), - new = c("norm_shift", "norm_scale")) + new = c("norm_shift", "norm_scale") + ) return(z_short[, mget(c(batch_id_column, "feature", "norm_shift", "norm_scale", "n"))]) } @@ -367,9 +396,10 @@ setMethod( .combat_non_parametric_bayes_solver <- function( z, - n_sample_features = 50, + n_sample_features = 50L, cl = NULL, - progress_bar = TRUE) { + progress_bar = TRUE +) { # Computes batch parameters using non-parametric priors. Sadly, this seems to # be an O(2) problem because it compares each feature with every other # feature. Johnson et al. We may be able to cheat a bit by subsampling the @@ -397,12 +427,14 @@ setMethod( X = split( z, by = c(get_id_columns(single_column = "batch"), "feature"), - drop = TRUE), + drop = TRUE + ), FUN = ..combat_non_parametric_bayes_solver, progress_bar = progress_bar, z_short = z_short, n_sample_features = n_sample_features, - chopchop = TRUE) + chopchop = TRUE + ) # Concatenate to single table. batch_parameters <- data.table::rbindlist(batch_parameters) @@ -415,7 +447,8 @@ setMethod( ..combat_non_parametric_bayes_solver <- function( z, z_short, - n_sample_features) { + n_sample_features +) { # Suppress NOTES due to non-standard evaluation in data.table batch_id <- feature <- NULL @@ -424,12 +457,12 @@ setMethod( batch_id_column <- get_id_columns(single_column = "batch") # Limit z_short to the current batch. - current_batch_id <- z[[batch_id_column]][1] + current_batch_id <- z[[batch_id_column]][1L] # Select the current cohort from z_short. Note that like in sva and other # codes, we interpret the g"=1...G in the supplement of Johnson et al. to # indicate that the current feature is not directly considered. - z_short <- data.table::copy(z_short[batch_id == current_batch_id & feature != z$feature[1]]) + z_short <- data.table::copy(z_short[batch_id == current_batch_id & feature != z$feature[1L]]) # Find the number of features that are used to compute w_ig". features <- z_short$feature @@ -441,7 +474,8 @@ setMethod( selected_features <- fam_sample( features, size = n_sample_features, - replace = FALSE) + replace = FALSE + ) # Make selection z_short <- droplevels(z_short[feature %in% selected_features]) @@ -455,23 +489,25 @@ setMethod( function(prior_pair, x) { # Compute sum((x-gamma_hat)^2) term in the product of the probability # density functions of the normal distribution over x. - sum_squared_error <- sum((x - prior_pair$gamma_hat[1])^2) + sum_squared_error <- sum((x - prior_pair$gamma_hat[1L])^2.0) # Compute w_ig" = L(Z_ig | gamma_hat_ig", delta_hat_squared_ig") # for the current feature in g". - w_ig <- 1.0 / (2.0 * pi * prior_pair$delta_hat_squared[1])^(length(x) / 2) * - exp(-sum_squared_error / (2 * prior_pair$delta_hat_squared[1])) + w_ig <- 1.0 / (2.0 * pi * prior_pair$delta_hat_squared[1L])^(length(x) / 2.0) * + exp(-sum_squared_error / (2.0 * prior_pair$delta_hat_squared[1L])) # Replace NaNs and other problematic values. if (!is.finite(w_ig)) w_ig <- 0.0 return(data.table::data.table( - "feature" = prior_pair$feature[1], + "feature" = prior_pair$feature[1L], "w" = w_ig, - "gamma_hat" = prior_pair$gamma_hat[1], - "delta_hat_squared" = prior_pair$delta_hat_squared[1])) + "gamma_hat" = prior_pair$gamma_hat[1L], + "delta_hat_squared" = prior_pair$delta_hat_squared[1L] + )) }, - x = z$value) + x = z$value + ) # Combine to data.table weight_data <- data.table::rbindlist(weight_data) @@ -481,11 +517,12 @@ setMethod( delta_star_squared <- sum(weight_data$w * weight_data$delta_hat_squared) / sum(weight_data$w) return(data.table::data.table( - "batch_id" = z[[batch_id_column]][1], - "feature" = z$feature[1], + "batch_id" = z[[batch_id_column]][1L], + "feature" = z$feature[1L], "norm_shift" = gamma_star, "norm_scale" = sqrt(delta_star_squared), - "n" = nrow(z))) + "n" = nrow(z) + )) } @@ -500,7 +537,7 @@ setMethod( v <- mean(delta_hat_squared) s_squared <- stats::var(x = delta_hat_squared) - return((v^2 / s_squared) + 2.0) + return((v^2.0 / s_squared) + 2.0) } @@ -511,7 +548,7 @@ setMethod( v <- mean(delta_hat_squared) s_squared <- stats::var(x = delta_hat_squared) - return(v * (1 + (v^2 / s_squared))) + return(v * (1.0 + (v^2.0 / s_squared))) } diff --git a/R/DataObject.R b/R/DataObject.R index b0f6f26f..061744b5 100644 --- a/R/DataObject.R +++ b/R/DataObject.R @@ -8,7 +8,7 @@ NULL #'@title Creates a valid data object from input data. #' -#'@description Creates `dataObject` a object from input data. Input data can be +#'@description Creates a `dataObject` object from input data. Input data can be #' a `data.frame` or `data.table`, a path to such tables on a local or network #' drive, or a path to tabular data that may be converted to these formats. #' @@ -37,6 +37,9 @@ NULL #' stringent checks, particularly for identifier and outcome columns, which may #' be completely absent. Used internally for `predict`. #' +#'@param .no_features_required Internal flag to signify that data without +#' features is allowed. Default: FALSE (most processing steps require features). +#' #'@inheritParams .parse_experiment_settings #' #'@details You can specify settings for your data manually, e.g. the column for @@ -55,7 +58,8 @@ NULL ## as_data_object (generic) ---------------------------------------------------- setGeneric( "as_data_object", - function(data, ...) standardGeneric("as_data_object")) + function(data, ...) standardGeneric("as_data_object") +) @@ -64,7 +68,10 @@ setGeneric( setMethod( "as_data_object", signature(data = "dataObject"), - function(data, object = NULL, ...) return(data)) + function(data, object = NULL, ...) { + return(data) + } +) @@ -76,8 +83,8 @@ setMethod( function( data, object = NULL, - sample_id_column = waiver(), batch_id_column = waiver(), + sample_id_column = waiver(), series_id_column = waiver(), development_batch_id = waiver(), validation_batch_id = waiver(), @@ -92,10 +99,11 @@ setMethod( include_features = waiver(), reference_method = waiver(), check_stringency = "strict", - ...) { - + .no_features_required = FALSE, + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table - type <- NULL + type <- outcome_event <- NULL # Determine whether the object contains data concerning columns, and # outcome. Note that user-provided names always take precedence. @@ -112,7 +120,7 @@ setMethod( } if (check_stringency != "strict") { - if (!has_model_object) stop("Dummy columns cannot be set without a model or ensemble object.") + if (!has_model_object) ..error("Dummy columns cannot be set without a model or ensemble object.") } # Attempt to identify a sample identifier column. @@ -124,7 +132,7 @@ setMethod( # Check that the model actually has a column name (not character(0)) # that is not NA, and set this column name. - if (length(model_sample_id_column) > 0) { + if (length(model_sample_id_column) > 0L) { if (!is.na(model_sample_id_column)) sample_id_column <- model_sample_id_column } } @@ -140,7 +148,7 @@ setMethod( # Check that the model actually has a column name (not character(0)) # that is not NA, and set this column name. - if (length(model_batch_id_column) > 0) { + if (length(model_batch_id_column) > 0L) { if (!is.na(model_batch_id_column)) batch_id_column <- model_batch_id_column } } @@ -156,7 +164,7 @@ setMethod( # Check that the model actually has a column name (not character(0)) # that is not NA, and set this column name. - if (length(model_series_id_column) > 0) { + if (length(model_series_id_column) > 0L) { if (!is.na(model_series_id_column)) series_id_column <- model_series_id_column } } @@ -166,27 +174,6 @@ setMethod( # Development and validation batch ids are not incorporated into # familiarModel or familiarEnsemble objects. - # Attempt to identify the name of the outcome. - if (is.waive(outcome_name)) { - if (has_model_object & has_outcome_info_slot) { - if (is(object@outcome_info, "outcomeInfo")) { - - # Check that the outcome name is not empty. - if (length(object@outcome_info@name) >= 1) outcome_name <- object@outcome_info@name - } - } - } - - # Attempt to identify the outcome columns. - if (is.waive(outcome_column)) { - if (has_model_object & has_outcome_info_slot) { - if (!is_empty(object@data_column_info)) { - # Find the model columns. - outcome_column <- object@data_column_info[type == "outcome_column"]$external - } - } - } - # Attempt to identify the type of outcome. if (is.waive(outcome_type)) { if (is(object, "familiarNoveltyDetector")) { @@ -197,51 +184,74 @@ setMethod( } } - # Attempt to identify the event indicator. - if (is.waive(event_indicator)) { - if (has_model_object & has_outcome_info_slot) { - if (is(object@outcome_info, "outcomeInfo")) { - if (length(object@outcome_info@event) > 0) { - if (!is.na(object@outcome_info@event)) { - event_indicator <- object@outcome_info@event - } + if (outcome_type != "unsupervised") { + # Attempt to identify the name of the outcome. + if (is.waive(outcome_name)) { + if (has_model_object && has_outcome_info_slot) { + if (is(object@outcome_info, "outcomeInfo")) { + + # Check that the outcome name is not empty. + if (length(object@outcome_info@name) >= 1L) outcome_name <- object@outcome_info@name } } } - } - - # Attempt to identify the censoring indicator. - if (is.waive(censoring_indicator)) { - if (has_model_object & has_outcome_info_slot) { - if (is(object@outcome_info, "outcomeInfo")) { - if (length(object@outcome_info@censored) > 0) { - if (!is.na(object@outcome_info@censored)) { - censoring_indicator <- object@outcome_info@censored - } + + # Attempt to identify the outcome columns. + if (is.waive(outcome_column)) { + if (has_model_object && has_outcome_info_slot) { + if (!is_empty(object@data_column_info)) { + # Find the model columns. + outcome_column <- object@data_column_info[type == "outcome_column"]$external } } } - } - - # Attempt to identify the competing risk indicator. - if (is.waive(competing_risk_indicator)) { - if (has_model_object & has_outcome_info_slot) { - if (is(object@outcome_info, "outcomeInfo")) { - if (length(object@outcome_info@competing_risk) > 0) { - if (!is.na(object@outcome_info@competing_risk)) { - competing_risk_indicator <- object@outcome_info@competing_risk - } + + # Attempt to identify the event indicator. + if (is.waive(event_indicator)) { + if (has_model_object && has_outcome_info_slot) { + if (is(object@outcome_info, "outcomeInfo")) { + if (length(object@outcome_info@event) > 0L) { + if (!is.na(object@outcome_info@event)) { + event_indicator <- object@outcome_info@event + } + } } } } - } - - # Attempt to identify class levels of the outcome. - if (is.waive(class_levels)) { - if (has_model_object & has_outcome_info_slot) { - if (is(object@outcome_info, "outcomeInfo")) { - if (length(object@outcome_info@levels) > 0) { - class_levels <- object@outcome_info@levels + + # Attempt to identify the censoring indicator. + if (is.waive(censoring_indicator)) { + if (has_model_object && has_outcome_info_slot) { + if (is(object@outcome_info, "outcomeInfo")) { + if (length(object@outcome_info@censored) > 0L) { + if (!is.na(object@outcome_info@censored)) { + censoring_indicator <- object@outcome_info@censored + } + } + } + } + } + + # Attempt to identify the competing risk indicator. + if (is.waive(competing_risk_indicator)) { + if (has_model_object && has_outcome_info_slot) { + if (is(object@outcome_info, "outcomeInfo")) { + if (length(object@outcome_info@competing_risk) > 0L) { + if (!is.na(object@outcome_info@competing_risk)) { + competing_risk_indicator <- object@outcome_info@competing_risk + } + } + } + } + } + + # Attempt to identify class levels of the outcome. + if (is.waive(class_levels)) { + if (has_model_object && has_outcome_info_slot) { + if (is(object@outcome_info, "outcomeInfo")) { + if (length(object@outcome_info@levels) > 0L) { + class_levels <- object@outcome_info@levels + } } } } @@ -267,21 +277,26 @@ setMethod( "class_levels" = class_levels, "exclude_features" = exclude_features, "include_features" = include_features, - "reference_method" = reference_method), - list(...))) + "reference_method" = reference_method + ), + list(...) + ) + ) # Prepare data.table. data <- .load_data( data = data, sample_id_column = settings$data$sample_col, batch_id_column = settings$data$batch_col, - series_id_column = settings$data$series_col) + series_id_column = settings$data$series_col + ) # Update settings settings <- .update_initial_settings( data = data, settings = settings, - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Parse data data <- .finish_data_preparation( @@ -297,7 +312,8 @@ setMethod( event_indicator = settings$data$event_indicator, competing_risk_indicator = settings$data$competing_risk_indicator, check_stringency = check_stringency, - reference_method = settings$data$reference_method + reference_method = settings$data$reference_method, + .no_features_required = .no_features_required ) # Update the dataset according to the feature info list. @@ -309,6 +325,12 @@ setMethod( outcome_info <- object@outcome_info } else { + if (settings$data$outcome_type %in% c("survival", "competing_risk")) { + # Update time max. + if (is.null(settings$eval$time_max)) { + settings$eval$time_max <- .get_default_time_max(data[outcome_event == 1L]$outcome_time) + } + } outcome_info <- create_outcome_info(settings = settings) } @@ -331,7 +353,8 @@ setMethod( preprocessing_level = "none", outcome_type = settings$data$outcome_type, outcome_info = outcome_info, - data_column_info = data_info) + data_column_info = data_info + ) return(data) } @@ -350,7 +373,8 @@ setMethod( sample_id_column = waiver(), batch_id_column = waiver(), series_id_column = waiver(), - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table type <- NULL @@ -372,7 +396,7 @@ setMethod( # Check that the model actually has a column name (not character(0)) # that is not NA, and set this column name. - if (length(model_sample_id_column) > 0) { + if (length(model_sample_id_column) > 0L) { if (!is.na(model_sample_id_column)) sample_id_column_local <- model_sample_id_column } } @@ -391,7 +415,7 @@ setMethod( # Check that the model actually has a column name (not character(0)) # that is not NA, and set this column name. - if (length(model_batch_id_column) > 0) { + if (length(model_batch_id_column) > 0L) { if (!is.na(model_batch_id_column)) batch_id_column_local <- model_batch_id_column } } @@ -410,7 +434,7 @@ setMethod( # Check that the model actually has a column name (not # character(0)) that is not NA, and set this column name. - if (length(model_series_id_column) > 0) { + if (length(model_series_id_column) > 0L) { if (!is.na(model_series_id_column)) series_id_column_local <- model_series_id_column } } @@ -424,7 +448,8 @@ setMethod( data = data, sample_id_column = sample_id_column_local, batch_id_column = batch_id_column_local, - series_id_column = series_id_column_local) + series_id_column = series_id_column_local + ) # Pass on to data.table method. return(do.call( @@ -435,8 +460,11 @@ setMethod( "object" = object, "sample_id_column" = sample_id_column, "batch_id_column" = batch_id_column, - "series_id_column" = series_id_column), - list(...)))) + "series_id_column" = series_id_column + ), + list(...) + ) + )) } ) @@ -449,7 +477,8 @@ setMethod( function( data, settings = NULL, - signature = NULL) { + signature = NULL + ) { # Suppress NOTES due to non-standard evaluation in data.table type <- NULL @@ -465,28 +494,32 @@ setMethod( current = sample_id_column, data = data@data, internal = data@data_column_info[type == "sample_id_column"]$internal, - external = data@data_column_info[type == "sample_id_column"]$external) + external = data@data_column_info[type == "sample_id_column"]$external + ) # Batch identifier batch_id_column <- ..set_identifier_column( current = batch_id_column, data = data@data, internal = data@data_column_info[type == "batch_id_column"]$internal, - external = data@data_column_info[type == "batch_id_column"]$external) + external = data@data_column_info[type == "batch_id_column"]$external + ) # Series identifier series_id_column <- ..set_identifier_column( current = series_id_column, data = data@data, internal = data@data_column_info[type == "series_id_column"]$internal, - external = data@data_column_info[type == "series_id_column"]$external) + external = data@data_column_info[type == "series_id_column"]$external + ) # Outcome columns outcome_columns <- ..set_identifier_column( current = outcome_columns, data = data@data, internal = data@data_column_info[type == "outcome_column"]$internal, - external = data@data_column_info[type == "outcome_column"]$external) + external = data@data_column_info[type == "outcome_column"]$external + ) } if (is.null(outcome_columns)) get_outcome_columns(data) @@ -515,14 +548,15 @@ setMethod( current = NULL, data = NULL, internal, - external) { + external +) { if (!(is.waive(current) || is.null(current))) return(current) temporary <- NULL # Prefer external before internal, as long as it is present in data. - if (all(sapply(external, length) > 0)) { + if (all(lengths(external) > 0L)) { if (!any(sapply(external, is.na))) { if (data.table::is.data.table(data)) { if (all(external %in% colnames(data))) temporary <- external @@ -536,7 +570,7 @@ setMethod( } # Use external if internal is not present in data. - if (all(sapply(external, length) > 0) && is.null(temporary)) { + if (all(lengths(external) > 0L) && is.null(temporary)) { if (!any(sapply(external, is.na))) temporary <- internal } @@ -549,102 +583,239 @@ setMethod( } +.split_data_by_batch_id <- function(data) { + # Don't split if there is no data. + if (is_empty(data, allow_no_features = TRUE)) return(NULL) + + # Split by batch id. + split_data <- split( + data@data, + by = get_id_columns(id_depth = "batch") + ) + + # Update dataObject. + data <- lapply( + split_data, + function(x, data) { + data@data <- x + return(data) + }, + data = data + ) + + return(data) +} + + + # load_delayed_data methods ---------------------------------------------------- -## load_delayed_data (model) --------------------------------------------------- +## load_delayed_data (dataObject, ANY) ----------------------------------------- setMethod( "load_delayed_data", signature( data = "dataObject", - object = "ANY"), + object = "ANY" + ), function( data, object, - stop_at, - keep_novelty = FALSE) { - # Loads data from internal memory + ... + ) { + # If data is a dataObject, the data already was loaded. + return(data) + } +) + + + +## load_delayed_data (dataObject, NULL) ---------------------------------------- +setMethod( + "load_delayed_data", + signature( + data = "delayedDataObject", + object = "NULL" + ), + function( + data, + object, + column_names = NULL, + ... + ) { + if (is.na(data@validation) && is_empty(data@sample_set_on_load)) { + ..error_reached_unreachable_code("validation attribute was not set") + } - if (!(is(object, "familiarModel") || - is(object, "familiarVimpMethod") || - is(object, "familiarNoveltyDetector"))) { - ..error_reached_unreachable_code(paste0( - "load_delayed_data: object is expected to be a familiarModel, ", - "familiarVimpMethod or familiarNoveltyDetector.")) + # Determine which samples are required. + if (is_empty(data@sample_set_on_load)) { + # Check if data_id and run_id were set. + if (is.na(data@data_id)) { + ..error_reached_unreachable_code("data_id attribute was not set") + } + if (is.na(data@run_id)) { + ..error_reached_unreachable_code("run_id attribute was not set") + } + + # From iteration list. + sample_identifiers <- .get_sample_identifiers( + iteration_list = get_project_list()$iter_list, + data_id = data@data_id, + run_id = data@run_id, + train_or_validate = ifelse(data@validation, "valid", "train") + ) + + } else { + # From data object. + sample_identifiers <- data@sample_set_on_load } - # Check if loading was actually delayed - if (!data@delay_loading) return(data) + # Resample sample identifiers. + if (!is.na(data@sample_seed)) { + sample_identifiers <- fam_sample( + x = sample_identifiers, + seed = data@sample_seed + ) + } + + # Initialise dataObject + new_data <- methods::new( + "dataObject", + data = NULL, + preprocessing_level = "none", + outcome_type = data@outcome_type, + outcome_info = data@outcome_info, + data_column_info = data@data_column_info, + data_id = data@data_id, + run_id = data@run_id, + validation = data@validation, + sample_seed = data@sample_seed + ) - # Read project list and settings - iteration_list <- get_project_list()$iter_list + # Select only unique samples from the backend. + if (!is_empty(sample_identifiers)) { + unique_sample_identifiers <- unique(sample_identifiers) + + } else { + # Return the dataObject placeholder. + return(new_data) + } - # Read required features + # Attach data. + new_data@data <- get_data_from_backend( + sample_identifiers = unique_sample_identifiers, + column_names = column_names + ) + + # Recreate iteration. Note that we here also use duplicate samples to + # recreate e.g. bootstraps. + new_data <- select_data_from_samples( + data = new_data, + samples = sample_identifiers + ) + + return(new_data) + } +) + + +## load_delayed_data (delayedDataObject, model) -------------------------------- +setMethod( + "load_delayed_data", + signature( + data = "delayedDataObject", + object = "familiarModel" + ), + function( + data, + object, + stop_at, + keep_novelty = FALSE, + ... + ) { + # Prevent notes. + data_id <- NULL + + # Read required features. required_features <- object@required_features + if (is.na(data@run_id)) { + data@run_id <- object@run_table[data_id == data@data_id, ]$run_id[1L] + } + # Get columns in data frame which are not features, but identifiers and # outcome instead. - non_feature_cols <- get_non_feature_columns(x = object) + non_feature_columns <- get_non_feature_columns(x = object) - # Find the identifiers for the current run. - run_id_list <- .get_iteration_identifiers( - run = list("run_table" = object@run_table), - perturb_level = data@perturb_level) + # Explicitly refer to the method for object = NULL. + new_data <- load_delayed_data( + data = data, + object = NULL, + column_names = c(non_feature_columns, required_features) + ) - # Derive sample identifiers based on the selected iteration data. - sample_identifiers <- .get_sample_identifiers( - iteration_list = iteration_list, - data_id = run_id_list$data, - run_id = run_id_list$run, - train_or_validate = ifelse(data@load_validation, "valid", "train")) + # Pre-process data, if needed. + new_data <- preprocess_data( + data = new_data, + object = object, + stop_at = stop_at, + keep_novelty = keep_novelty + ) - # Currently select only unique samples from the backend. - if (!is_empty(sample_identifiers)) { - unique_sample_identifiers <- unique(sample_identifiers) - - } else { - # Return an updated data object, but without data - return(methods::new( - "dataObject", - data = NULL, - preprocessing_level = "none", - outcome_type = data@outcome_type, - aggregate_on_load = data@aggregate_on_load)) + # Aggregate data, if needed. + if (data@aggregate_on_load) { + new_data <- aggregate_data(data = new_data) } - # Prepare a new data object - new_data <- methods::new( - "dataObject", - data = get_data_from_backend( - sample_identifiers = unique_sample_identifiers, - column_names = c(non_feature_cols, required_features)), - preprocessing_level = "none", - outcome_type = data@outcome_type, - delay_loading = FALSE, - perturb_level = NA_integer_, - load_validation = data@load_validation, - aggregate_on_load = data@aggregate_on_load, - sample_set_on_load = data@sample_set_on_load) + return(new_data) + } +) + + + +## load_delayed_data (delayedDataObject, novelty detector) --------------------- +setMethod( + "load_delayed_data", + signature( + data = "delayedDataObject", + object = "familiarNoveltyDetector" + ), + function( + data, + object, + stop_at, + ... + ) { + # Prevent notes. + data_id <- NULL - # Preprocess data + # Read required features. + required_features <- object@required_features + + if (is.na(data@run_id)) { + data@run_id <- object@run_table[data_id == data@data_id, ]$run_id[1L] + } + + # Get columns in data frame which are not features, but identifiers instead. + non_feature_columns <- get_non_feature_columns(x = object) + + # Explicitly refer to the method for object = NULL. + new_data <- load_delayed_data( + data = data, + object = NULL, + column_names = c(non_feature_columns, required_features) + ) + + # Pre-process data, if needed. new_data <- preprocess_data( data = new_data, object = object, stop_at = stop_at, - keep_novelty = keep_novelty) + keep_novelty = TRUE + ) - # Recreate iteration. Note that we here also use duplicate samples to - # recreate e.g. bootstraps. - new_data <- select_data_from_samples( - data = new_data, - samples = sample_identifiers) - - if (new_data@aggregate_on_load) { - - # Aggregate data if required + # Aggregate data, if needed. + if (data@aggregate_on_load) { new_data <- aggregate_data(data = new_data) - - # Reset flag to FALSE, as data has been loaded - new_data@aggregate_on_load <- FALSE } return(new_data) @@ -653,127 +824,122 @@ setMethod( -## load_delayed_data (ensemble) ------------------------------------------------ +## load_delayed_data (delayedDataObject, vimp method) -------------------------- setMethod( "load_delayed_data", signature( - data = "dataObject", - object = "familiarEnsemble"), + data = "delayedDataObject", + object = "familiarVimpMethod" + ), function( data, object, - stop_at = "clustering", - keep_novelty = FALSE) { - # Loads data from internal memory -- for familiarEnsemble objects + stop_at, + keep_novelty = FALSE, + ... + ) { + # Prevent notes. + data_id <- NULL - # Suppress NOTES due to non-standard evaluation in data.table - perturb_level <- NULL + # Read required features. + required_features <- object@required_features - # Check if loading was actually delayed - if (!data@delay_loading) return(data) + if (is.na(data@run_id)) { + data@run_id <- object@run_table[data_id == data@data_id, ]$run_id[1L] + } - # Read project list - iteration_list <- get_project_list()$iter_list - - # Read required features - required_features <- object@required_features + # Get columns in data frame which are not features, but identifiers and + # outcome instead. + non_feature_columns <- get_non_feature_columns(x = object) - # Get columns in data frame which are not features, but identifiers and outcome instead - non_feature_cols <- get_non_feature_columns(x = object) + # Explicitly refer to the method for object = NULL. + new_data <- load_delayed_data( + data = data, + object = NULL, + column_names = c(non_feature_columns, required_features) + ) - # Join run tables to identify the runs that should be evaluated. - combined_run_table <- lapply( - object@run_table$run_table, - function(model_run_table, data_perturb_level) { - return(model_run_table[perturb_level == data_perturb_level]) - }, - data_perturb_level = data@perturb_level) + # Pre-process data, if needed. + new_data <- preprocess_data( + data = new_data, + object = object, + stop_at = stop_at, + keep_novelty = keep_novelty + ) - # Merge to single table - combined_run_table <- data.table::rbindlist(combined_run_table) + # Aggregate data, if needed. + if (data@aggregate_on_load) { + new_data <- aggregate_data(data = new_data) + } - # Remove duplicate rows - combined_run_table <- unique(combined_run_table) + return(new_data) + } +) + + + +## load_delayed_data (delayedDataObject, ensemble) ----------------------------- +setMethod( + "load_delayed_data", + signature( + data = "delayedDataObject", + object = "familiarEnsemble" + ), + function( + data, + object, + stop_at, + keep_novelty = FALSE, + ... + ) { + # Prevent notes. + data_id <- NULL - # Check length and extract sample identifiers. - if (nrow(combined_run_table) == 1) { - sample_identifiers <- .get_sample_identifiers( - iteration_list = iteration_list, - data_id = combined_run_table$data_id, - run_id = combined_run_table$run_id, - train_or_validate = ifelse(data@load_validation, "valid", "train")) + # Read required features. + required_features <- object@required_features + + # Leaving the run id NA signals that the run_id is determined by the data_id + # of the data. For ensembles, this data_id may not actually be contained + # in the run table (which is a composite of the underlying models). + if (is.na(data@run_id)) { + run_table <- tail(object@run_table[data_id <= data@data_id, ], n = 1L) - } else { - # Extract all sample identifiers. This happens if the the data is pooled. - sample_identifiers <- data.table::rbindlist(lapply( - seq_len(nrow(combined_run_table)), - function(ii, run_table, iteration_list, train_or_validate) { + if (run_table$data_id == data@data_id) { + data@run_id <- run_table$run_id - sample_identifiers <- .get_sample_identifiers( - iteration_list = iteration_list, - data_id = run_table$data_id[ii], - run_id = run_table$run_id[ii], - train_or_validate = train_or_validate) - - return(sample_identifiers) - }, - run_table = combined_run_table, - iteration_list = iteration_list, - train_or_validate = ifelse(data@load_validation, "valid", "train"))) - - # Select only unique sample identifiers. - sample_identifiers <- unique(sample_identifiers) + } else { + # In this case, we are considering a higher subset of data, and + # we should only consider the training set, because the actually + # requested subset is contained in the training set at that level -- + # but not within the validation subset. + data@data_id <- run_table$data_id + data@run_id <- run_table$run_id + data@validation <- FALSE + } } - # Currently select only unique samples from the backend. - if (!is_empty(sample_identifiers)) { - unique_sample_identifiers <- unique(sample_identifiers) - - } else { - # Return an updated data object, but without data - return(methods::new( - "dataObject", - data = NULL, - preprocessing_level = "none", - outcome_type = data@outcome_type, - aggregate_on_load = data@aggregate_on_load)) - } + # Get columns in data frame which are not features, but identifiers and + # outcome instead. + non_feature_columns <- get_non_feature_columns(x = object) - # Prepare a new data object - new_data <- methods::new( - "dataObject", - data = get_data_from_backend( - sample_identifiers = unique_sample_identifiers, - column_names = c(non_feature_cols, required_features)), - preprocessing_level = "none", - outcome_type = data@outcome_type, - delay_loading = FALSE, - perturb_level = NA_integer_, - load_validation = data@load_validation, - aggregate_on_load = data@aggregate_on_load, - sample_set_on_load = data@sample_set_on_load) + # Explicitly refer to the method for object = NULL. + new_data <- load_delayed_data( + data = data, + object = NULL, + column_names = c(non_feature_columns, required_features) + ) - # Preprocess data + # Pre-process data, if needed. new_data <- preprocess_data( data = new_data, object = object, stop_at = stop_at, - keep_novelty = keep_novelty) - - # Recreate iteration. Note that we here also use duplicate samples - # to recreate e.g. bootstraps. - new_data <- select_data_from_samples( - data = new_data, - samples = sample_identifiers) + keep_novelty = keep_novelty + ) - # Aggregate data if required - if (new_data@aggregate_on_load) { - - # Aggregate + # Aggregate data, if needed. + if (data@aggregate_on_load) { new_data <- aggregate_data(data = new_data) - - # Reset flag to FALSE, as data has been loaded - new_data@aggregate_on_load <- FALSE } return(new_data) @@ -781,27 +947,68 @@ setMethod( ) - # preprocess_data methods ------------------------------------------------------ +## preprocess_data (delayedDataObject, ANY) ------------------------------------ +setMethod( + "preprocess_data", + signature( + data = "delayedDataObject", + object = "ANY" + ), + function( + data, + object, + stop_at = "clustering", + keep_novelty = FALSE, + ... + ) { + + # Load data. This automatically pre-processes the data. + data <- load_delayed_data( + data = data, + object = object, + stop_at = stop_at, + keep_novelty = keep_novelty, + ... + ) + + # Perform any object-specific processing. + data <- preprocess_data( + data = data, + object = object, + stop_at = stop_at, + keep_novelty = keep_novelty, + ... + ) + + return(data) + } +) + + + ## preprocess_data (vimp method) ----------------------------------------------- setMethod( "preprocess_data", signature( data = "dataObject", - object = "familiarVimpMethod"), + object = "familiarVimpMethod" + ), function( data, object, stop_at = "clustering", - keep_novelty = FALSE, ...) { + keep_novelty = FALSE, ... + ) { # Pre-process the data. data <- .preprocess_data( data = data, object = object, stop_at = stop_at, - keep_novelty = keep_novelty) + keep_novelty = keep_novelty + ) return(data) } @@ -814,20 +1021,23 @@ setMethod( "preprocess_data", signature( data = "dataObject", - object = "familiarModel"), + object = "familiarModel" + ), function( data, object, stop_at = "clustering", keep_novelty = FALSE, - ...) { + ... + ) { # Pre-process the data. data <- .preprocess_data( data = data, object = object, stop_at = stop_at, - keep_novelty = keep_novelty) + keep_novelty = keep_novelty + ) # Post-process the data to select the correct feature and identifier set. data <- postprocess_data( @@ -835,7 +1045,8 @@ setMethod( object = object, stop_at = stop_at, keep_novelty = keep_novelty, - ...) + ... + ) return(data) } @@ -848,18 +1059,21 @@ setMethod( "preprocess_data", signature( data = "dataObject", - object = "familiarNaiveModel"), + object = "familiarNaiveModel" + ), function( data, object, stop_at = "clustering", keep_novelty = FALSE, - ...) { + ... + ) { if (.as_preprocessing_level(data@preprocessing_level) > .as_preprocessing_level(stop_at)) { ..error_reached_unreachable_code(paste0( "preprocess_data,dataObject,familiarNaiveModel: data were preprocessed ", - "at a higher level than required by stop_at.")) + "at a higher level than required by stop_at." + )) } # familiarNaiveModels do not have any features, so we remove them. @@ -879,12 +1093,14 @@ setMethod( "preprocess_data", signature( data = "dataObject", - object = "familiarNoveltyDetector"), + object = "familiarNoveltyDetector" + ), function( data, object, stop_at = "clustering", - ...) { + ... + ) { # Note that keep_novelty is always false to prevent reading novelty_features # slot. Novelty features are stored in the model_features slot of @@ -899,14 +1115,16 @@ setMethod( data = data, object = object, stop_at = stop_at, - keep_novelty = FALSE) + keep_novelty = FALSE + ) # Post-process the data to select the correct feature and identifier set. data <- postprocess_data( data = data, object = object, stop_at = stop_at, - ...) + ... + ) return(data) } @@ -918,20 +1136,23 @@ setMethod( "preprocess_data", signature( data = "dataObject", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function( data, object, stop_at = "clustering", keep_novelty = FALSE, - ...) { + ... + ) { # Pre-process the data. data <- .preprocess_data( data = data, object = object, stop_at = stop_at, - keep_novelty = keep_novelty) + keep_novelty = keep_novelty + ) return(data) } @@ -943,8 +1164,8 @@ setMethod( data, object, stop_at, - keep_novelty = FALSE) { - + keep_novelty = FALSE +) { # Convert the preprocessing_level attained and the requested stopping level to # ordinals. preprocessing_level_attained <- .as_preprocessing_level(data@preprocessing_level) @@ -952,20 +1173,18 @@ setMethod( # Check whether pre-processing is required if (preprocessing_level_attained == stop_at) { - return(data) } else if (preprocessing_level_attained > stop_at) { ..error_reached_unreachable_code(paste0( "preprocess_data,dataObject,ANY: data were preprocessed at a higher level", - " than required by stop_at.")) + " than required by stop_at." + )) } if (preprocessing_level_attained < "signature" && stop_at >= "signature") { # Apply the signature. - data <- select_features( - data = data, - features = object@required_features) + data <- select_features(data = data, features = object@required_features) # Update pre-processing level externally as it is not limited to # pre-processing per sé. @@ -977,22 +1196,19 @@ setMethod( selected_features <- object@model_features if (keep_novelty) selected_features <- union(selected_features, object@novelty_features) - if (length(required_features) > 0 && length(selected_features) > 0 && has_feature_data(data)) { + if (length(required_features) > 0L && length(selected_features) > 0L && has_feature_data(data)) { # Select available features specific to the object. if (all(required_features %in% get_feature_columns(data))) { - data <- select_features( - data = data, - features = required_features) + data <- select_features(data = data, features = required_features) } else if (all(selected_features %in% get_feature_columns(data))) { - data <- select_features( - data = data, - features = selected_features) + data <- select_features(data = data, features = selected_features) } else { ..error_reached_unreachable_code( - ".preprocess_data: could not identify overlapping features") + ".preprocess_data: could not identify overlapping features" + ) } } } @@ -1001,35 +1217,40 @@ setMethod( # Transform the features. data <- transform_features( data = data, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) } if (preprocessing_level_attained < "normalisation" && stop_at >= "normalisation") { # Normalise feature values. data <- normalise_features( data = data, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) } if (preprocessing_level_attained < "batch_normalisation" && stop_at >= "batch_normalisation") { # Batch-normalise feature values data <- batch_normalise_features( data = data, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) } if (preprocessing_level_attained < "imputation" && stop_at >= "imputation") { # Impute missing values data <- impute_features( data = data, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) } if (preprocessing_level_attained < "clustering" && stop_at >= "clustering") { # Cluster features data <- cluster_features( data = data, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) } return(data) @@ -1043,14 +1264,16 @@ setMethod( "postprocess_data", signature( data = "dataObject", - object = "familiarModel"), + object = "familiarModel" + ), function( data, object, stop_at = "clustering", keep_novelty = FALSE, force_check = FALSE, - ...) { + ... + ) { # Convert the preprocessing_level attained and the requested stopping level # to ordinals. @@ -1064,17 +1287,19 @@ setMethod( if (keep_novelty) features <- union(features, object@novelty_features) # Return data if there are no features. - if (length(features) == 0 && !force_check) return(data) + if (length(features) == 0L && !force_check) return(data) # Determine the features after clustering. features <- features_after_clustering( features = features, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) # Create a slice of the data for the feature set. data <- select_features( data = data, - features = features) + features = features + ) return(data) } @@ -1087,13 +1312,15 @@ setMethod( "postprocess_data", signature( data = "dataObject", - object = "familiarNoveltyDetector"), + object = "familiarNoveltyDetector" + ), function( data, object, stop_at = "clustering", force_check = FALSE, - ...) { + ... + ) { # Convert the preprocessing_level attained and the requested stopping level # to ordinals. @@ -1106,17 +1333,19 @@ setMethod( features <- object@model_features # Return data if there are no features. - if (length(features) == 0 && !force_check) return(data) + if (length(features) == 0L && !force_check) return(data) # Determine the features after clustering. features <- features_after_clustering( features = features, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) # Create a slice of the data for the feature set. data <- select_features( data = data, - features = features) + features = features + ) return(data) } @@ -1129,14 +1358,16 @@ setMethod( "process_input_data", signature( object = "familiarVimpMethod", - data = "ANY"), + data = "ANY" + ), function( object, data, is_pre_processed = FALSE, stop_at = "clustering", keep_novelty = FALSE, - ...) { + ... + ) { data <- .process_input_data( object = object, @@ -1144,7 +1375,8 @@ setMethod( is_pre_processed = is_pre_processed, stop_at = stop_at, keep_novelty = keep_novelty, - ...) + ... + ) return(data) } @@ -1155,13 +1387,15 @@ setMethod( "process_input_data", signature( object = "familiarNoveltyDetector", - data = "ANY"), + data = "ANY" + ), function( object, data, is_pre_processed = FALSE, stop_at = "clustering", - ...) { + ... + ) { # Ensure that the outcome_type of data is changed to "unsupervised". We # don't need any outcome columns. @@ -1174,7 +1408,8 @@ setMethod( is_pre_processed = is_pre_processed, stop_at = stop_at, keep_novelty = FALSE, - ...) + ... + ) return(data) } @@ -1187,14 +1422,16 @@ setMethod( "process_input_data", signature( object = "familiarModel", - data = "ANY"), + data = "ANY" + ), function( object, data, is_pre_processed = FALSE, stop_at = "clustering", keep_novelty = FALSE, - ...) { + ... + ) { data <- .process_input_data( object = object, @@ -1202,7 +1439,8 @@ setMethod( is_pre_processed = is_pre_processed, stop_at = stop_at, keep_novelty = keep_novelty, - ...) + ... + ) return(data) } @@ -1215,26 +1453,48 @@ setMethod( "process_input_data", signature( object = "familiarEnsemble", - data = "ANY"), + data = "ANY" + ), function( object, data, is_pre_processed = FALSE, stop_at = "clustering", - keep_novelty = FALSE) { + keep_novelty = FALSE + ) { data <- .process_input_data( object = object, data = data, is_pre_processed = is_pre_processed, stop_at = stop_at, - keep_novelty = keep_novelty) + keep_novelty = keep_novelty + ) return(data) } ) +## process_input_data (dataObject) ----------------------------------------------- +setMethod( + "process_input_data", + signature( + object = "dataObject", + data = "ANY" + ), + function( + object, + data, + is_pre_processed = FALSE, + stop_at = "clustering", + keep_novelty = FALSE + ) { + return(data) + } +) + + .process_input_data <- function( object, @@ -1242,34 +1502,37 @@ setMethod( is_pre_processed, stop_at, keep_novelty = FALSE, - ...) { + ... +) { # Check whether data is a dataObject, and create one otherwise - if (!is(data, "dataObject")) { + if (is(data, "delayedDataObject")) { + data <- load_delayed_data( + data = data, + object = object, + stop_at = stop_at, + keep_novelty = keep_novelty, + ... + ) + + } else if (!is(data, "dataObject")) { data <- as_data_object( data = data, - object = object) + object = object + ) # Set pre-processing level. data@preprocessing_level <- ifelse(is_pre_processed, "clustering", "none") } - # Load data from internal memory, if not provided otherwise - if (data@delay_loading) { - data <- load_delayed_data( - data = data, - object = object, - stop_at = stop_at, - keep_novelty = keep_novelty) - } - # Pre-process data in case it has not been pre-processed data <- preprocess_data( data = data, object = object, stop_at = stop_at, keep_novelty = keep_novelty, - ...) + ... + ) # Return data return(data) @@ -1277,92 +1540,62 @@ setMethod( -# select_data_from_samples ----------------------------------------------------- +# select_data_from_samples (dataObject) ---------------------------------------- setMethod( "select_data_from_samples", signature( data = "dataObject", - samples = "ANY"), + samples = "ANY" + ), function(data, samples = NULL) { - # Check if data is loaded - if (data@delay_loading) { - - # Store samples until the data is loaded. - data@sample_set_on_load <- samples + # Determine the names of the id-columns, up to the series level. + id_columns <- get_id_columns(id_depth = "series") + + if (is_empty(samples)) { + # Return an empty data set if no samples are provided + data@data <- head(data@data, n = 0L) } else { - - # Determine the names of the id-columns, up to the series level. - id_columns <- get_id_columns(id_depth = "series") - - if (is_empty(samples) && is.null(data@sample_set_on_load)) { - # Return an empty data set if no samples are provided - data@data <- head(data@data, n = 0) - - } else if (is_empty(samples) && !is.null(data@sample_set_on_load)) { - # Use samples in the sample_set_on_load attribute. + # Use samples from the samples function argument. allow.cartesian is set + # to true to allow use with repeated measurements. + if (all(id_columns %in% colnames(samples))) { data@data <- merge( - x = data@sample_set_on_load, + x = samples, y = data@data, by = id_columns, all = FALSE, - allow.cartesian = TRUE) - - } else if (!is_empty(samples) & is.null(data@sample_set_on_load)) { - # Use samples from the samples function argument. allow.cartesian is set - # to true to allow use with repeated measurements. - if (all(id_columns %in% colnames(samples))) { - data@data <- merge( - x = samples, - y = data@data, - by = id_columns, - all = FALSE, - allow.cartesian = TRUE) - - } else { - data@data <- merge( - x = samples, - y = data@data, - by = get_id_columns(id_depth = "sample"), - all = FALSE, - allow.cartesian = TRUE) - } + allow.cartesian = TRUE + ) } else { - # Use samples that appear both as function argument and within the - # sample_set_on_load attribute. The sample_set_on_load attribute is used - # as a filter. allow.cartesian is set to true to allow use with repeated - # measurements. - samples <- data.table::fintersect(samples, data@sample_set_on_load) - - if (is_empty(samples)) { - # Return an empty data set if no samples are left. - data@data <- head(data@data, n = 0) - - } else { - # Check if series identifiers are present. They may be absent if - # samples were generated using fam_sample - - if (all(id_columns %in% colnames(sample))) { - data@data <- merge( - x = samples, - y = data@data, - by = id_columns, - all = FALSE, - allow.cartesian = TRUE) - - } else { - data@data <- merge( - x = samples, - y = data@data, - by = get_id_columns(id_depth = "sample"), - all = FALSE, - allow.cartesian = TRUE) - } - } + data@data <- merge( + x = samples, + y = data@data, + by = get_id_columns(id_depth = "sample"), + all = FALSE, + allow.cartesian = TRUE + ) } - } + } + + return(data) + } +) + + + +# select_data_from_samples (delayedDataObject) --------------------------------- +setMethod( + "select_data_from_samples", + signature( + data = "delayedDataObject", + samples = "ANY" + ), + function(data, samples = NULL) { + + # Set the sample set that should be loaded. + data@sample_set_on_load <- samples return(data) } @@ -1370,23 +1603,13 @@ setMethod( -# aggregate_data --------------------------------------------------------------- + +# aggregate_data (dataObject) -------------------------------------------------- setMethod( "aggregate_data", signature(data = "dataObject"), function(data) { - # Check if loading of the data object was delayed - if (data@delay_loading) { - # Mark for future aggregation after loading the data - data@aggregate_on_load <- TRUE - return(data) - - } else { - # Set aggregation flag to FALSE and continue - data@aggregate_on_load <- FALSE - } - # Check if the data is empty if (is_empty(data)) return(data) @@ -1396,31 +1619,31 @@ setMethod( # Identify the columns containing outcome, series, sample, and batch # identifiers. id_cols <- get_non_feature_columns(x = data, id_depth = "series") + if (all(data@data$repetition_id == 1L)) return(data) - # Determine the number of different entries - - if (all(data@data$repetition_id == 1)) return(data) - # Identify feature columns for repeated measurement data. feature_columns <- get_feature_columns(x = data) # Identify class of features column_class <- lapply( feature_columns, - function(ii, data) (class(data[[ii]])[1]), - data = data@data) + function(ii, data) (class(data[[ii]])[1L]), + data = data@data + ) # Determine numerical features numeric_features <- sapply( column_class, - function(selected_column_class) (any(selected_column_class %in% c("numeric", "integer")))) + function(selected_column_class) (any(selected_column_class %in% c("numeric", "integer"))) + ) numeric_features <- feature_columns[numeric_features] # Determine categorical features categorical_features <- sapply( column_class, - function(selected_column_class) (any(selected_column_class %in% c("logical", "character", "factor")))) + function(selected_column_class) (any(selected_column_class %in% c("logical", "character", "factor"))) + ) categorical_features <- feature_columns[categorical_features] @@ -1428,38 +1651,44 @@ setMethod( aggregated_data <- unique(data@data[, mget(id_cols)]) # Add aggregated numeric columns - if (length(numeric_features) > 0) { - numeric_data <- data@data[, lapply( - .SD, stats::median), + if (length(numeric_features) > 0L) { + numeric_data <- data@data[ + , lapply(.SD, stats::median), by = id_cols, - .SDcols = numeric_features] + .SDcols = numeric_features + ] aggregated_data <- merge( x = aggregated_data, y = numeric_data, - by = id_cols) + by = id_cols + ) } # Add aggregated factor columns - if (length(categorical_features) > 0) { - categorical_data <- data@data[, lapply( - .SD, get_mode), + if (length(categorical_features) > 0L) { + categorical_data <- data@data[ + , + lapply(.SD, get_mode), by = id_cols, - .SDcols = categorical_features] + .SDcols = categorical_features + ] aggregated_data <- merge( x = aggregated_data, y = categorical_data, - by = id_cols) + by = id_cols + ) } # Add in repetition_id column again - aggregated_data[, "repetition_id" := -1] + aggregated_data[, "repetition_id" := -1L] # Reorder columns so that it matches the input data.table::setcolorder( aggregated_data, - neworder = colnames(data@data)) + neworder = colnames(data@data) + ) data@data <- aggregated_data @@ -1468,6 +1697,37 @@ setMethod( ) + +# aggregate_data (delayedDataObject) ------------------------------------------- +setMethod( + "aggregate_data", + signature(data = "delayedDataObject"), + function(data) { + # Mark for future aggregation after loading the data. + data@aggregate_on_load <- TRUE + return(data) + } +) + + + +# select_unique_data (dataObject) ---------------------------------------------- +setMethod( + "select_unique_data", + signature(data = "dataObject"), + function(data) { + # Check if the data is empty + if (is_empty(data)) return(data) + + # Drop any duplicates (e.g. from bootstraps). + data@data <- unique(data@data) + + return(data) + } +) + + + # filter_features -------------------------------------------------------------- setMethod( "filter_features", @@ -1475,7 +1735,8 @@ setMethod( function( data, remove_features = NULL, - available_features = NULL) { + available_features = NULL + ) { # Removes features from a data set # If both are provided, use remove_features @@ -1495,10 +1756,6 @@ setMethod( # Based on available_features input } else if (!is.null(available_features)) { - - # Skip if length equals 0 - if (length(available_features) == 0) return(data) - # Determine which features should be removed remove_features <- setdiff(get_feature_columns(x = data), available_features) @@ -1507,20 +1764,22 @@ setMethod( } else { ..error_reached_unreachable_code( - "This point should never be reachable. Check for inconsistencies if it does.") + "This point should never be reachable. Check for inconsistencies if it does." + ) } # Make a copy to prevent updating by reference. data@data <- data.table::copy(data@data) # Remove features from data if there is 1 or more feature to remove - if (length(remove_features) > 0) data@data[, (remove_features) := NULL] + if (length(remove_features) > 0L) data@data[, (remove_features) := NULL] # Make sure that the column order is the same as available_features if (!is.null(available_features)) { data.table::setcolorder( x = data@data, - neworder = c(get_non_feature_columns(x = data), available_features)) + neworder = c(get_non_feature_columns(x = data), available_features) + ) } return(data) @@ -1528,34 +1787,62 @@ setMethod( ) -# filter_missing_outcome ------------------------------------------------------ +# filter_missing_outcome (dataObject) ------------------------------------------ setMethod( "filter_missing_outcome", signature(data = "dataObject"), - function(data, is_validation = FALSE) { + function(data, is_validation = FALSE, ...) { # Check if data is empty if (is_empty(data)) return(data) - # Change behaviour by outcome_type - if (data@outcome_type == "survival") { - outcome_is_valid <- is_valid_data(data@data[["outcome_time"]]) & is_valid_data(data@data[["outcome_event"]]) + # Pass to method for data.table. + data@data <- filter_missing_outcome( + data = data@data, + outcome_type = data@outcome_type, + is_validation = is_validation, + ... + ) + + return(data) + } +) + + +# filter_missing_outcome (data.table) ------------------------------------------ +setMethod( + "filter_missing_outcome", + signature(data = "data.table"), + function( + data, + outcome_type, + is_validation = FALSE, + ... + ) { + if (is_empty(data)) return(data) + + # Check predicted outcome columns. + if (outcome_type %in% c("survival", "competing_risk")) { + outcome_is_valid <- is_valid_data(data[["outcome_time"]]) & is_valid_data(data[["outcome_event"]]) - } else if (data@outcome_type %in% c("binomial", "multinomial", "continuous", "count")) { - outcome_is_valid <- is_valid_data(data@data[["outcome"]]) + } else if (outcome_type %in% c("continuous")) { + outcome_is_valid <- is_valid_data(data[["outcome"]]) + + } else if (outcome_type %in% c("binomial", "multinomial")) { + outcome_is_valid <- is_valid_data(data[["outcome"]]) } else { - stop(paste0("Implementation for outcome_type ", data@outcome_type, " is missing.")) + ..error_no_known_outcome_type(outcome_type) } if (is_validation) { # Check whether all outcome information is missing for validation. It may # be a prospective study. In that case, keep all data. - if (all(!outcome_is_valid)) outcome_is_valid <- !outcome_is_valid + if (!any(outcome_is_valid)) outcome_is_valid <- !outcome_is_valid } # Keep only data for which the outcome exists - data@data <- data@data[(outcome_is_valid), ] + data <- data[(outcome_is_valid), ] return(data) } @@ -1601,12 +1888,14 @@ setMethod( function( data, feature_info_list, - invert = FALSE) { + invert = FALSE + ) { # Check if transformation was already performed. if (!invert && .as_preprocessing_level(data) >= "transformation") { ..error_reached_unreachable_code( - "transform_features,dataObject: attempting to transform data that are already transformed.") + "transform_features,dataObject: attempting to transform data that are already transformed." + ) } # Update the preprocessing level. @@ -1624,7 +1913,8 @@ setMethod( data = data@data, feature_info_list = feature_info_list, features = feature_columns, - invert = invert) + invert = invert + ) return(data) } @@ -1639,7 +1929,8 @@ setMethod( data, feature_info_list, features, - invert = FALSE) { + invert = FALSE + ) { # Check if data is empty if (is_empty(data)) return(data) @@ -1648,17 +1939,18 @@ setMethod( transformed_list <- lapply( features, function(ii, data, feature_info_list, invert) { - x <- apply_feature_info_parameters( object = feature_info_list[[ii]]@transformation_parameters, data = data[[ii]], - invert = invert) + invert = invert + ) return(x) }, data = data, feature_info_list = feature_info_list, - invert = invert) + invert = invert + ) # Update name of data in columns names(transformed_list) <- features @@ -1666,7 +1958,8 @@ setMethod( # Update with replacement in the data object data <- update_with_replacement( data = data, - replacement_list = transformed_list) + replacement_list = transformed_list + ) return(data) } @@ -1682,18 +1975,21 @@ setMethod( function( data, feature_info_list, - invert = FALSE) { + invert = FALSE + ) { # Check if normalisation was already performed. - if (!invert & .as_preprocessing_level(data) >= "normalisation") { + if (!invert && .as_preprocessing_level(data) >= "normalisation") { ..error_reached_unreachable_code( - "normalise_features,dataObject: attempting to normalise data that are already normalised.") + "normalise_features,dataObject: attempting to normalise data that are already normalised." + ) } # Check if the previous step (transformation) was conducted. - if (!invert & .as_preprocessing_level(data) < "transformation") { + if (!invert && .as_preprocessing_level(data) < "transformation") { ..error_reached_unreachable_code( - "normalise_features,dataObject: data should be transformed prior to normalisation.") + "normalise_features,dataObject: data should be transformed prior to normalisation." + ) } # Update the preprocessing_level. @@ -1711,7 +2007,8 @@ setMethod( data = data@data, feature_info_list = feature_info_list, features = feature_columns, - invert = invert) + invert = invert + ) return(data) } @@ -1726,7 +2023,8 @@ setMethod( data, feature_info_list, features, - invert = FALSE) { + invert = FALSE + ) { # Check if data is empty. if (is_empty(data)) return(data) @@ -1735,17 +2033,18 @@ setMethod( normalised_list <- lapply( features, function(ii, data, feature_info_list, invert) { - x <- apply_feature_info_parameters( object = feature_info_list[[ii]]@normalisation_parameters, data = data[[ii]], - invert = invert) + invert = invert + ) return(x) }, data = data, feature_info_list = feature_info_list, - invert = invert) + invert = invert + ) # Update name of data in columns. names(normalised_list) <- features @@ -1753,7 +2052,8 @@ setMethod( # Update with replacement in the data object. data <- update_with_replacement( data = data, - replacement_list = normalised_list) + replacement_list = normalised_list + ) return(data) } @@ -1761,6 +2061,8 @@ setMethod( # batch_normalise_features ----------------------------------------------------- + +## batch_normalise_features (dataObject) --------------------------------------- setMethod( "batch_normalise_features", signature(data = "dataObject"), @@ -1768,20 +2070,23 @@ setMethod( data, feature_info_list, cl = NULL, - invert = FALSE) { + invert = FALSE + ) { # Check if batch normalisation was already performed. if (!invert && .as_preprocessing_level(data) >= "batch_normalisation") { ..error_reached_unreachable_code(paste0( "batch_normalise_features,dataObject: attempting to batch normalise data ", - "that are already batch normalised.")) + "that are already batch normalised." + )) } # Check if the previous step (normalisation) was conducted. if (!invert && .as_preprocessing_level(data) < "normalisation") { ..error_reached_unreachable_code(paste0( "batch_normalise_features,dataObject: data should be normalised globally ", - "prior to batch normalisation.")) + "prior to batch normalisation." + )) } # Update the preprocessing_level. @@ -1792,44 +2097,75 @@ setMethod( if (is_empty(data)) return(data) # Find the columns containing features - feature_columns <- get_feature_columns(x = data) + features <- get_feature_columns(x = data) # Update feature_info_list by adding info for missing batches feature_info_list <- add_batch_normalisation_parameters( - feature_info_list = feature_info_list[feature_columns], - data = data) + feature_info_list = feature_info_list[features], + data = data + ) + + # Apply normalisation + data@data <- batch_normalise_features( + data = data@data, + feature_info_list = feature_info_list, + features = features, + invert = invert + ) + + return(data) + } +) + + + +## batch_normalise_features (data.table) --------------------------------------- +setMethod( + "batch_normalise_features", + signature(data = "data.table"), + function( + data, + feature_info_list, + features, + invert = FALSE + ) { - # Apply batch-normalisation + # Check if data is empty. + if (is_empty(data)) return(data) + + # Apply batch normalisation. batch_normalised_list <- lapply( - feature_columns, - function(ii, data, feature_info_list, invert) { - - # Dispatch to apply-method. + features, + function(ii, data, batch_data, feature_info_list, invert) { x <- apply_feature_info_parameters( object = feature_info_list[[ii]]@batch_normalisation_parameters, - data = data@data[, mget(c(ii, get_id_columns("batch")))], - invert = invert) + data = data[[ii]], + batch_data = batch_data, + invert = invert + ) return(x) }, data = data, + batch_data = data[[get_id_columns("batch")]], feature_info_list = feature_info_list, - invert = invert) + invert = invert + ) - # Update name of data in columns - names(batch_normalised_list) <- feature_columns + # Update name of data in columns. + names(batch_normalised_list) <- features - # Update with replacement in the data object + # Update with replacement in the data object. data <- update_with_replacement( data = data, - replacement_list = batch_normalised_list) + replacement_list = batch_normalised_list + ) return(data) } ) - # impute_features -------------------------------------------------------------- setMethod( "impute_features", @@ -1837,18 +2173,21 @@ setMethod( function( data, feature_info_list, - cl = NULL) { + cl = NULL + ) { # Check if imputation was already performed. if (.as_preprocessing_level(data) >= "imputation") { ..error_reached_unreachable_code( - "impute_features,dataObject: attempting to impute data that already have been imputed.") + "impute_features,dataObject: attempting to impute data that already have been imputed." + ) } # Check if the previous step (batch normalisation) was conducted. if (.as_preprocessing_level(data) < "batch_normalisation") { ..error_reached_unreachable_code( - "impute_features,dataObject: data should be batch normalised prior to imputation.") + "impute_features,dataObject: data should be batch normalised prior to imputation." + ) } # Update the attained processing level. @@ -1864,14 +2203,16 @@ setMethod( imputed_data <- .impute_features( data = data, feature_info_list = feature_info_list, - initial_imputation = TRUE) + initial_imputation = TRUE + ) # Apply multivariate model to the dataset. data <- .impute_features( data = imputed_data, feature_info_list = feature_info_list, initial_imputation = FALSE, - mask_data = data) + mask_data = data + ) return(data) } @@ -1889,13 +2230,15 @@ setMethod( if (.as_preprocessing_level(data) >= "clustering") { ..error_reached_unreachable_code( - "cluster_features,dataObject: attempting to cluster data that already have been clustered.") + "cluster_features,dataObject: attempting to cluster data that already have been clustered." + ) } # Check if the previous step (imputation) was conducted. if (.as_preprocessing_level(data) < "imputation") { ..error_reached_unreachable_code( - "cluster_features,dataObject: data should be imputed prior to clustering.") + "cluster_features,dataObject: data should be imputed prior to clustering." + ) } # Update the attained processing level. @@ -1913,22 +2256,26 @@ setMethod( # Derive clustering table. cluster_table <- .create_clustering_table( feature_info_list = feature_info_list, - selected_features = feature_columns) + selected_features = feature_columns + ) # Update data using the clustering table. Note that only features # that are both required and present are processed. clustered_data <- lapply( split( cluster_table[feature_required == TRUE & feature_name %in% feature_columns], - by = "cluster_name"), + by = "cluster_name" + ), set_clustered_data, data = data, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Attach the clustered data. data@data <- cbind( data@data[, mget(get_non_feature_columns(data))], - data.table::setDT(clustered_data)) + data.table::setDT(clustered_data) + ) return(data) } @@ -1947,7 +2294,8 @@ setMethod( # Replace data by passing to the data.table method. data@data <- update_with_replacement( data = data@data, - replacement_list = replacement_list) + replacement_list = replacement_list + ) return(data) } @@ -1973,7 +2321,8 @@ setMethod( } return(replacement_table) - }) + } +) # select_features -------------------------------------------------------------- @@ -1987,7 +2336,7 @@ setMethod( non_feature_columns <- get_non_feature_columns(x = data) # Check if features are present as column name - if (length(features) > 0) { + if (length(features) > 0L) { if (!all(features %in% colnames(data@data))) { logger_stop("Not all features were found in the data set.") } @@ -2021,20 +2370,13 @@ setMethod( features = NULL, exclude_signature = FALSE, exclude_novelty = FALSE, - ...) { + ... + ) { # Check if features are provided externally. is_external <- !is.null(features) - # Create features from columns in the dataset, if unset. - if (!is_external && x@delay_loading) { - # Get features from the feature info list. - features <- get_available_features( - feature_info_list = feature_info_list, - exclude_signature = exclude_signature, - exclude_novelty = exclude_novelty) - - } else if (!is_external) { + if (!is_external) { # Get features directly. features <- get_feature_columns(x) } @@ -2046,7 +2388,45 @@ setMethod( is_clustered = .as_preprocessing_level(x@preprocessing_level) == "clustering", is_external = is_external, exclude_signature = exclude_signature, - exclude_novelty = exclude_novelty)) + exclude_novelty = exclude_novelty + )) + } +) + + +## get_required_features (delayedDataObject) ----------------------------------- +setMethod( + "get_required_features", + signature(x = "delayedDataObject"), + function( + x, + feature_info_list, + features = NULL, + exclude_signature = FALSE, + exclude_novelty = FALSE, + ... + ) { + # Check if features are provided externally. + is_external <- !is.null(features) + + if (is_external) { + ..error_reached_unreachable_code("features should remain unset (NULL).") + } + + features <- get_available_features( + feature_info_list = feature_info_list, + exclude_signature = exclude_signature, + exclude_novelty = exclude_novelty + ) + + return(.get_required_features( + features = features, + feature_info_list, + is_clustered = .as_preprocessing_level(x@preprocessing_level) == "clustering", + is_external = is_external, + exclude_signature = exclude_signature, + exclude_novelty = exclude_novelty + )) } ) @@ -2062,10 +2442,11 @@ setMethod( is_clustered, exclude_signature = FALSE, exclude_novelty = FALSE, - ...) { + ... + ) { # Method intended for directly providing features. - if (length(x) == 0) return(NULL) + if (length(x) == 0L) return(NULL) return(.get_required_features( features = x, @@ -2073,7 +2454,8 @@ setMethod( is_clustered = is_clustered, is_external = TRUE, exclude_signature = exclude_signature, - exclude_novelty = exclude_novelty)) + exclude_novelty = exclude_novelty + )) } ) @@ -2087,22 +2469,24 @@ setMethod( x, exclude_signature = FALSE, exclude_novelty = FALSE, - ...) { + ... + ) { # Method intended for directly providing a list of featureInfo objects. - if (is_empty(x)) return(NULL) # Sanity check. x should be a list of if (!all(sapply(x, is, "featureInfo"))) { ..error_reached_unreachable_code( - "get_required_features,list: expected a list of featureInfo objects.") + "get_required_features,list: expected a list of featureInfo objects." + ) } # Get features from the featureInfo objects. features <- get_available_features( feature_info_list = x, exclude_signature = exclude_signature, - exclude_novelty = exclude_novelty) + exclude_novelty = exclude_novelty + ) return(.get_required_features( features = features, @@ -2110,7 +2494,8 @@ setMethod( is_clustered = FALSE, is_external = FALSE, exclude_signature = exclude_signature, - exclude_novelty = exclude_novelty)) + exclude_novelty = exclude_novelty + )) } ) @@ -2135,7 +2520,8 @@ setMethod( exclude_signature = FALSE, exclude_novelty = FALSE, exclude_imputation = FALSE, - ...) { + ... +) { # What are required features? Required features are features that are: # # 1. Directly used for clustering (representative features). @@ -2155,7 +2541,8 @@ setMethod( if (is_clustered) { # Data are clustered. required_features <- cluster_table[ - cluster_name %in% features & feature_required == TRUE]$feature_name + cluster_name %in% features & feature_required == TRUE + ]$feature_name # Sanity check. All externally provided features should be present # in the cluster table. @@ -2163,14 +2550,16 @@ setMethod( if (!all(features %in% cluster_table$cluster_name)) { ..error_reached_unreachable_code(paste0( ".get_required_features: some features do not appear in the ", - " cluster table. Potentially, an incomplete feature_info_list was passed.")) + " cluster table. Potentially, an incomplete feature_info_list was passed." + )) } } } else { # Data are not yet clustered. required_features <- cluster_table[ - feature_name %in% features & feature_required == TRUE]$feature_name + feature_name %in% features & feature_required == TRUE + ]$feature_name # Sanity check. All externally provided features should be present # in the cluster table. @@ -2178,7 +2567,8 @@ setMethod( if (!all(features %in% cluster_table$feature_name)) { ..error_reached_unreachable_code(paste0( ".get_required_features: some features do not appear in the ", - " cluster table. Potentially, an incomplete feature_info_list was passed.")) + " cluster table. Potentially, an incomplete feature_info_list was passed." + )) } } } @@ -2187,21 +2577,24 @@ setMethod( available_features <- get_available_features( feature_info_list = feature_info_list, exclude_signature = exclude_signature, - exclude_novelty = exclude_novelty) + exclude_novelty = exclude_novelty + ) # Sanity check. All features that we provide externally should be # present in the available features. if (is_external) { - if (length(required_features) == 0) { + if (length(required_features) == 0L) { ..error_reached_unreachable_code(paste0( "get_required_features,dataObject: there are no required features, ", - "whereas at least one is expected.")) + "whereas at least one is expected." + )) } if (!all(required_features %in% available_features)) { ..error_reached_unreachable_code(paste0( "get_required_features,dataObject: there are required features for clustering ", - "that are not available.")) + "that are not available." + )) } } @@ -2209,18 +2602,21 @@ setMethod( required_features <- intersect(available_features, required_features) # Return NULL if no features are required. - if (length(required_features) == 0) return(NULL) + if (length(required_features) == 0L) return(NULL) if (!exclude_imputation) { # Now, additionally select which features are required for imputation. required_features <- unique(unlist(lapply( feature_info_list[required_features], - function(x) x@required_features))) + function(x) x@required_features + ))) } return(required_features) } + + # get_model_features methods --------------------------------------------------- ## get_model_features (dataObject) --------------------------------------------- @@ -2233,20 +2629,13 @@ setMethod( features = NULL, exclude_signature = FALSE, exclude_novelty = FALSE, - ...) { + ... + ) { # Check if features are provided externally. is_external <- !is.null(features) - # Create features from columns in the dataset, if unset. - if (!is_external && x@delay_loading) { - # Get features from the feature info list. - features <- get_available_features( - feature_info_list = x, - exclude_signature = exclude_signature, - exclude_novelty = exclude_novelty) - - } else if (!is_external) { + if (!is_external) { # Get features directly. features <- get_feature_columns(x) } @@ -2260,12 +2649,54 @@ setMethod( exclude_signature = exclude_signature, exclude_novelty = exclude_novelty, exclude_imputation = TRUE, - ...)) + ... + )) + } +) + + + +## get_model_features (delayedDataObject) -------------------------------------- +setMethod( + "get_model_features", + signature(x = "delayedDataObject"), + function( + x, + feature_info_list, + features = NULL, + exclude_signature = FALSE, + exclude_novelty = FALSE, + ... + ) { + # Check if features are provided externally. + is_external <- !is.null(features) + + if (is_external) { + ..error_reached_unreachable_code("features should remain unset (NULL).") + } + + features <- get_available_features( + feature_info_list = feature_info_list, + exclude_signature = exclude_signature, + exclude_novelty = exclude_novelty + ) + + return(.get_required_features( + features = features, + feature_info_list, + is_clustered = .as_preprocessing_level(x@preprocessing_level) == "clustering", + is_external = is_external, + exclude_signature = exclude_signature, + exclude_novelty = exclude_novelty, + exclude_imputation = TRUE, + ... + )) } ) + ## get_model_features (character) ---------------------------------------------- setMethod( "get_model_features", @@ -2276,8 +2707,8 @@ setMethod( is_clustered, exclude_signature = FALSE, exclude_novelty = FALSE, - ...) { - + ... + ) { return(.get_required_features( features = x, feature_info_list = feature_info_list, @@ -2286,7 +2717,8 @@ setMethod( exclude_signature = exclude_signature, exclude_novelty = exclude_novelty, exclude_imputation = TRUE, - ...)) + ... + )) } ) @@ -2303,6 +2735,27 @@ setMethod( +## get_model_features (familiarEnsemble) --------------------------------------- +setMethod( + "get_model_features", + signature(x = "familiarEnsemble"), + function(x, ...) { + return(x@model_features) + } +) + + + +## get_model_features (familiarModel) ------------------------------------------ +setMethod( + "get_model_features", + signature(x = "familiarModel"), + function(x, ...) { + return(x@model_features) + } +) + + create_data_column_info <- function(settings) { # Read from settings. If not set, these will be NULL. @@ -2324,14 +2777,16 @@ create_data_column_info <- function(settings) { "batch_id_column", "sample_id_column", "series_id_column", - "repetition_id_column"), - "internal" = - get_id_columns(), + "repetition_id_column" + ), + "internal" = get_id_columns(), "external" = c( batch_id_column, sample_id_column, series_id_column, - repetition_id_column)) + repetition_id_column + ) + ) if (settings$data$outcome_type %in% c("survival", "competing_risk")) { @@ -2347,9 +2802,10 @@ create_data_column_info <- function(settings) { outcome_info_table <- data.table::data.table( "type" = c("outcome_column", "outcome_column"), "internal" = internal_outcome_columns, - "external" = external_outcome_columns) + "external" = external_outcome_columns + ) - } else if (settings$data$outcome_type %in% c("binomial", "multinomial", "continuous", "count")) { + } else if (settings$data$outcome_type %in% c("binomial", "multinomial", "continuous")) { # Find internal and external outcome column names. internal_outcome_columns <- get_outcome_columns(settings$data$outcome_type) @@ -2363,7 +2819,8 @@ create_data_column_info <- function(settings) { outcome_info_table <- data.table::data.table( "type" = "outcome_column", "internal" = internal_outcome_columns, - "external" = external_outcome_columns) + "external" = external_outcome_columns + ) } else if (settings$data$outcome_type %in% c("unsupervised")) { @@ -2377,3 +2834,23 @@ create_data_column_info <- function(settings) { # Combine into one table and add to object return(rbind(data_info_table, outcome_info_table)) } + + + +# add_model_name (familiarDataElement, dataObject)------------------------ +setMethod( + "add_model_name", + signature( + data = "familiarDataElement", + object = "dataObject" + ), + function(data, object) { + + data <- add_data_element_identifier( + x = data, + model_name = "custom_data" + )[[1L]] + + return(data) + } +) diff --git a/R/DataParameterChecks.R b/R/DataParameterChecks.R index 42f6df28..d705f6ed 100644 --- a/R/DataParameterChecks.R +++ b/R/DataParameterChecks.R @@ -15,7 +15,8 @@ formula = NULL, data, settings, - check_stringency = "strict") { + check_stringency = "strict" +) { # Outcome columns, outcome type, signature, included_features, # excluded_features, class_levels. @@ -37,12 +38,18 @@ # Ignore include_features and exclude_features when using the formula # interface if (!is.null(settings$data$include_features)) { - warning("The include_features parameter is ignored when using the formula interface.") + ..warning( + "The include_features parameter is ignored when using the formula interface.", + warning_class = "input_argument_error" + ) settings$data$include_features <- NULL } if (!is.null(settings$data$exclude_features)) { - warning("The exclude_features parameter is ignored when using the formula interface.") + ..warning( + "The exclude_features parameter is ignored when using the formula interface.", + warning_class = "input_argument_error" + ) settings$data$exclude_features <- NULL } @@ -59,28 +66,31 @@ # Identifier columns---------------------------------------------------------- if (!is.null(settings$data$sample_col) && check_stringency != "strict") { - # Check if the internal default is used instead. - if (!any(settings$data$sample_col %in% colnames(data)) && - get_id_columns(single_column = "sample") %in% colnames(data)) { + if ( + !any(settings$data$sample_col %in% colnames(data)) && + get_id_columns(single_column = "sample") %in% colnames(data) + ) { settings$data$sample_col <- get_id_columns(single_column = "sample") } } if (!is.null(settings$data$batch_col) && check_stringency != "strict") { - # Check if the internal default is used instead. - if (!any(settings$data$batch_col %in% colnames(data)) && - get_id_columns(single_column = "batch") %in% colnames(data)) { + if ( + !any(settings$data$batch_col %in% colnames(data)) && + get_id_columns(single_column = "batch") %in% colnames(data) + ) { settings$data$batch_col <- get_id_columns(single_column = "batch") } } if (!is.null(settings$data$series_col) && check_stringency != "strict") { - # Check if the internal default is used instead. - if (!any(settings$data$series_col %in% colnames(data)) && - get_id_columns(single_column = "series") %in% colnames(data)) { + if ( + !any(settings$data$series_col %in% colnames(data)) && + get_id_columns(single_column = "series") %in% colnames(data) + ) { settings$data$series_col <- get_id_columns(single_column = "series") } } @@ -97,12 +107,14 @@ other_id_column = c(settings$data$batch_col, settings$data$series_col), outcome_column = settings$data$outcome_col, col_type = "sample", - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Remove sample column identifier if it doesn't appear in the dataset, and # autopopulate the column. Only possible when checks are not strict. - if (!settings$data$sample_col %in% colnames(data) && - check_stringency != "strict") { + if ( + !settings$data$sample_col %in% colnames(data) && check_stringency != "strict" + ) { settings$data$sample_col <- NULL } @@ -122,12 +134,14 @@ other_id_column = c(settings$data$sample_col, settings$data$series_col), outcome_column = settings$data$outcome_col, col_type = "batch", - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Remove batch column identifier if it doesn't appear in the dataset, and # autopopulate the column. Only possible when checks are not strict. - if (!settings$data$batch_col %in% colnames(data) && - check_stringency != "strict") { + if ( + !settings$data$batch_col %in% colnames(data) && check_stringency != "strict" + ) { settings$data$batch_col <- NULL } @@ -148,12 +162,14 @@ other_id_column = c(settings$data$batch_col, settings$data$sample_col), outcome_column = settings$data$outcome_col, col_type = "series", - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Remove series column identifier if it doesn't appear in the dataset, and # autopopulate the column. Only possible when checks are not strict. - if (!settings$data$series_col %in% colnames(data) && - check_stringency != "strict") { + if ( + !settings$data$series_col %in% colnames(data) && check_stringency != "strict" + ) { settings$data$series_col <- NULL } @@ -167,8 +183,10 @@ if (outcome_type != "unset" && check_stringency != "strict") { # Check if outcome columns are present, or internal defaults are present. - if (!any(settings$data$outcome_col %in% colnames(data)) && - all(get_outcome_columns(outcome_type) %in% colnames(data))) { + if ( + !any(settings$data$outcome_col %in% colnames(data)) && + all(get_outcome_columns(outcome_type) %in% colnames(data)) + ) { settings$data$outcome_col <- get_outcome_columns(settings$data$outcome_type) } @@ -176,23 +194,29 @@ # exclude_features. if (outcome_type == "unsupervised") { if (!is.null(settings$data$outcome_col)) { - warning(paste0( - paste_s(settings$data$outcome_col), " was selected as an outcome column, but ", - "unsupervised learners and novelty detectors do not require ", - "outcome columns.")) + ..warning( + paste0( + paste_s(settings$data$outcome_col), " was selected as an outcome column, but ", + "unsupervised learners and novelty detectors do not require ", + "outcome columns." + ), + warning_class = "dataset_error" + ) settings$data$exclude_features <- c( - settings$data$exclude_features, - settings$data$outcome_col) + settings$data$exclude_features, settings$data$outcome_col + ) settings$data$outcome_col <- NULL } } } # Check for presence of outcome column - if (is.null(settings$data$outcome_col) && - outcome_type != "unsupervised" && - check_stringency == "strict") { + if ( + is.null(settings$data$outcome_col) && + outcome_type != "unsupervised" && + check_stringency == "strict" + ) { # Attempt to determine the outcome_col from the set difference of all # features and the union of signature, include_features and @@ -203,13 +227,19 @@ settings$data$exclude_features, settings$data$include_features, settings$data$signature, - settings$data$novelty_features)) + settings$data$novelty_features + ) + ) - if (length(outcome_col) == 1) { + if (length(outcome_col) == 1L) { # Only select outcome column with stringent checks. - warning(paste0( - paste_s(outcome_col), "was selected as an outcome column. It is recommended ", - "to provide the column name manually to avoid selecting the wrong column.")) + ..warning( + paste0( + paste_s(outcome_col), "was selected as an outcome column. It is recommended ", + "to provide the column name manually to avoid selecting the wrong column." + ), + warning_class = "dataset_error" + ) # Set the outcome column settings$data$outcome_col <- outcome_col @@ -218,9 +248,13 @@ predictor_vars <- predictor_vars[!predictor_vars %in% outcome_col] } else { - stop(paste0( - "No column(s) that determine the outcome were provided and none could be imputed. ", - " Please provide outcome columns.")) + ..error( + paste0( + "No column(s) that determine the outcome were provided and none could be imputed. ", + " Please provide outcome columns." + ), + error_class = "dataset_error" + ) } } @@ -231,10 +265,13 @@ missing_col <- setdiff(settings$data$outcome_col, colnames(data)) if (check_stringency %in% c("strict", "external_warn")) { - stop_or_warn(paste0( - "The outcome column ", paste_s(missing_col), - " does not appear in the provided data set."), - check_stringency == "strict") + stop_or_warn( + paste0( + "The outcome column ", paste_s(missing_col), + " does not appear in the provided data set." + ), + check_stringency == "strict" + ) } # Set NULL and auto-generate outcome columns later. @@ -242,8 +279,11 @@ } } - if (length(settings$data$outcome_col) > 2) { - stop("Only one or two (in case of survival endpoints), may be specified") + if (length(settings$data$outcome_col) > 2L) { + ..error( + "Only one or two (in case of survival endpoints), may be specified", + error_class = "dataset_error" + ) } @@ -257,7 +297,8 @@ class_levels = settings$data$class_levels, censoring_indicator = settings$data$censoring_indicator, event_indicator = settings$data$event_indicator, - competing_risk_indicator = settings$data$competing_risk_indicator) + competing_risk_indicator = settings$data$competing_risk_indicator + ) } # Check whether the outcome type fits the data. @@ -268,7 +309,8 @@ censoring_indicator = settings$data$censoring_indicator, event_indicator = settings$data$event_indicator, competing_risk_indicator = settings$data$competing_risk_indicator, - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Class levels --------------------------------------------------------------- .check_class_level_plausibility( @@ -276,12 +318,15 @@ outcome_type = settings$data$outcome_type, outcome_column = settings$data$outcome_col, class_levels = settings$data$class_levels, - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Set class levels in settings, if appropriate. - if (is.null(settings$data$class_levels) && - settings$data$outcome_type %in% c("binomial", "multinomial") && - !is.null(settings$data$outcome_col)) { + if ( + is.null(settings$data$class_levels) && + settings$data$outcome_type %in% c("binomial", "multinomial") && + !is.null(settings$data$outcome_col) + ) { if (is.factor(data[[settings$data$outcome_col]])) { settings$data$class_levels <- levels(data[[settings$data$outcome_col]]) @@ -292,13 +337,16 @@ } # Survival event indicator --------------------------------------------------- - if (settings$data$outcome_type %in% c("survival", "competing_risk") && - !is.null(settings$data$outcome_col)) { + if ( + settings$data$outcome_type %in% c("survival", "competing_risk") && + !is.null(settings$data$outcome_col) + ) { settings <- .impute_survival_indicators( data = data, outcome_type = settings$data$outcome_type, settings = settings, - check_stringency = check_stringency) + check_stringency = check_stringency + ) } # Features ------------------------------------------------------------------- @@ -306,46 +354,58 @@ ## Signature features -------------------------------------------------------- if (!is.null(settings$data$signature)) { # Check for overlap with exclude_features - overlap_cols <- intersect( - settings$data$signature, - settings$data$exclude_features) + overlap_cols <- intersect(settings$data$signature, settings$data$exclude_features) - if (length(overlap_cols) > 0) { - stop(paste0( - "One or more columns were provided that both appear in the signature and ", - "among the features that should be removed. There can be no overlap. Found: ", - paste_s(overlap_cols))) + if (length(overlap_cols) > 0L) { + ..error( + paste0( + "One or more columns were provided that both appear in the signature and ", + "among the features that should be removed. There can be no overlap. Found: ", + paste_s(overlap_cols) + ), + error_class = "dataset_error" + ) } # Check if all features in the signature appear in the data missing_cols <- settings$data$signature[!settings$data$signature %in% predictor_vars] - if (length(missing_cols) > 0) { - stop(paste0( - "One or more features assigned to the signature were not found in the data set:", - paste_s(missing_cols))) + if (length(missing_cols) > 0L) { + ..error( + paste0( + "One or more features assigned to the signature were not found in the data set:", + paste_s(missing_cols) + ), + error_class = "dataset_error" + ) } } ## Novelty features ---------------------------------------------------------- if (!is.null(settings$data$novelty_features)) { # Check for overlap with exclude_features - overlap_cols <- intersect( - settings$data$novelty_features, - settings$data$exclude_features) - - if (length(overlap_cols) > 0) { - stop(paste0( - "One or more columns were provided that both appear in novelty_features and", - "among the features that should be removed. There can be no overlap. Found:", - paste_s(overlap_cols))) + overlap_cols <- intersect(settings$data$novelty_features, settings$data$exclude_features) + + if (length(overlap_cols) > 0L) { + ..error( + paste0( + "One or more columns were provided that both appear in novelty_features and", + "among the features that should be removed. There can be no overlap. Found:", + paste_s(overlap_cols) + ), + error_class = "dataset_error" + ) } # Check if all features in novelty_features appear in the data missing_cols <- settings$data$novelty_features[!settings$data$novelty_features %in% predictor_vars] - if (length(missing_cols) > 0) { - stop(paste0( - "One or more features assigned to novelty_features were not found in the data set:", - paste_s(missing_cols))) + if (length(missing_cols) > 0L) { + ..error( + paste0( + "One or more features assigned to novelty_features were not found in the data set:", + paste_s(missing_cols) + ), + error_class = "dataset_error" + ) } } @@ -354,29 +414,39 @@ # Check if all features marked for exclusion appear in the data missing_cols <- settings$data$exclude_features[!settings$data$exclude_features %in% predictor_vars] - if (length(missing_cols) > 0) { - stop(paste0( - "One or more features marked for exclusion were not found in the data set:", - paste_s(missing_cols))) + if (length(missing_cols) > 0L) { + ..error( + paste0( + "One or more features marked for exclusion were not found in the data set:", + paste_s(missing_cols) + ), + error_class = "dataset_error" + ) } # Check if include_features also exists. - overlap_cols <- intersect( - settings$data$include_features, - settings$data$exclude_features) + overlap_cols <- intersect(settings$data$include_features, settings$data$exclude_features) - if (length(overlap_cols) > 0) { - stop(paste0( - "One or more columns were provided that appear in both the set of features ", - "marked for exclusion and for inclusion. There can be no overlap. Found:", - paste_s(overlap_cols))) + if (length(overlap_cols) > 0L) { + ..error( + paste0( + "One or more columns were provided that appear in both the set of features ", + "marked for exclusion and for inclusion. There can be no overlap. Found:", + paste_s(overlap_cols) + ), + error_class = "dataset_error" + ) } # Notify the used that include_features parameter takes precedence. if (!is.null(settings$data$include_features)) { - warning(paste0( - "Features marked for inclusion take precedence over the features marked for inclusion, i.e. ", - "the final data set will only contain those features marked for inclusion.")) + ..warning( + paste0( + "Features marked for inclusion take precedence over the features marked for inclusion, i.e. ", + "the final data set will only contain those features marked for inclusion." + ), + warning_class = "dataset_error" + ) settings$data$exclude_features <- NULL } @@ -387,10 +457,14 @@ missing_cols <- settings$data$include_features[!settings$data$include_features %in% predictor_vars] - if (length(missing_cols) > 0) { - stop(paste0( - "One or more features marked for inclusion were not found in the data set:", - paste_s(missing_cols))) + if (length(missing_cols) > 0L) { + ..error( + paste0( + "One or more features marked for inclusion were not found in the data set:", + paste_s(missing_cols) + ), + error_class = "dataset_error" + ) } } @@ -399,14 +473,16 @@ # Select everything but the features marked for exclusion settings$data$include_features <- setdiff( predictor_vars, - settings$data$exclude_features) + settings$data$exclude_features + ) } else if (!is.null(settings$data$include_features)) { # Select features marked for inclusion and signature, in so far as these do not overlap. settings$data$include_features <- unique(c( settings$data$include_features, settings$data$signature, - settings$data$novelty_features)) + settings$data$novelty_features + )) } else { # Select all available predictor variables. @@ -418,7 +494,7 @@ settings$data$outcome_type %in% c("survival", "competing_risk")) { if (!is.null(settings$data$outcome_col)) { # Use the name of the event column, because its usually more indicative. - settings$data$outcome_name <- tolower(settings$data$outcome_col[2]) + settings$data$outcome_name <- tolower(settings$data$outcome_col[2L]) } else { settings$data$outcome_name <- "survival" @@ -456,7 +532,9 @@ .update_experimental_design_settings <- function( section_table, data, - settings) { + settings, + verbose = FALSE +) { # Find out if any external validation is performed as part of the workflow if (is.waive(section_table)) { @@ -473,129 +551,167 @@ # Determine what happens if batch identifiers are not specified for both # development and validation. - if (is.null(union(settings$data$train_cohorts, settings$data$valid_cohorts)) && - !perform_external_validation) { + if ( + is.null(union(settings$data$train_cohorts, settings$data$valid_cohorts)) && + !perform_external_validation + ) { # Use all cohorts for training if nothing is specifically provided, and # external validation is not necessary. settings$data$train_cohorts <- available_batch_ids - } else if (is.null(union(settings$data$train_cohorts, settings$data$valid_cohorts)) && - perform_external_validation) { + } else if ( + is.null(union(settings$data$train_cohorts, settings$data$valid_cohorts)) && + perform_external_validation + ) { # Validation cohort(s) should be provided, or be identifiable - stop(paste0("The validation_batch_id variable should be set to perform external validation.")) + ..error( + "The validation_batch_id variable should be set to perform external validation.", + error_class = "dataset_error" + ) } # Check if some cohorts are available for external validation, if required. - if (all(available_batch_ids %in% settings$data$train_cohorts) && - perform_external_validation) { + if ( + all(available_batch_ids %in% settings$data$train_cohorts) && + perform_external_validation + ) { # All cohorts are found in the set used for development. Prompt the user # to assign some cohorts to validation. - stop(paste0( - "All batches/cohorts in the data set are assigned for model development. ", - "External validation is not possible. ", - "Please assign one or more batches/cohorts to external validation by ", - "passing their names as an argument to the validation_batch_id variable.")) + ..error( + paste0( + "All batches/cohorts in the data set are assigned for model development. ", + "External validation is not possible. ", + "Please assign one or more batches/cohorts to external validation by ", + "passing their names as an argument to the validation_batch_id variable." + ), + error_class = "dataset_error" + ) } # Check if one or more cohorts are available for development. if (all(available_batch_ids %in% settings$data$valid_cohorts)) { # All cohorts are found in the set used for external validation. Prompt the # user to assign some development cohorts. - stop(paste0( - "All batches/cohorts in the data set are assigned for external validation. ", - "Model development is not possible. ", - "Please assign one or more batches/cohorts to model development by ", - "passing their names as an argument to the development_batch_id variable.")) + ..error( + paste0( + "All batches/cohorts in the data set are assigned for external validation. ", + "Model development is not possible. ", + "Please assign one or more batches/cohorts to model development by ", + "passing their names as an argument to the development_batch_id variable." + ), + error_class = "dataset_error" + ) } # Check whether there is an overlap between development and validation group # identifiers. overlapping_batches <- intersect( settings$data$train_cohorts, - settings$data$valid_cohorts) + settings$data$valid_cohorts + ) - if (length(overlapping_batches) > 0) { - stop(paste0( - "One or more batch/cohort names occur in both the development_batch_id ", - "and validation_batch_id variables: ", - paste_s(overlapping_batches))) + if (length(overlapping_batches) > 0L) { + ..error( + paste0( + "One or more batch/cohort names occur in both the development_batch_id ", + "and validation_batch_id variables: ", + paste_s(overlapping_batches) + ), + error_class = "dataset_error" + ) } # Check whether all specified development group identifiers actually appear in # the data. - missing_batches <- setdiff( - settings$data$train_cohorts, - available_batch_ids) + missing_batches <- setdiff(settings$data$train_cohorts, available_batch_ids) - if (length(missing_batches) > 0) { - stop(paste0( - "One or more batch/cohort names specified in the development_batch_id ", - "variable could not be found in the data: ", - paste_s(missing_batches))) + if (length(missing_batches) > 0L) { + ..error( + paste0( + "One or more batch/cohort names specified in the development_batch_id ", + "variable could not be found in the data: ", + paste_s(missing_batches) + ), + error_class = "dataset_error" + ) } # Determine if there are any missing batches for validation cohorts - missing_batches <- setdiff( - settings$data$valid_cohorts, - available_batch_ids) + missing_batches <- setdiff(settings$data$valid_cohorts, available_batch_ids) - if (length(missing_batches) > 0 && perform_external_validation) { + if (length(missing_batches) > 0L && perform_external_validation) { # Raise an error if external validation is expected. - stop(paste0( - "One or more batch/cohort names specified in the validation_batch_id ", - "variable could not be found in the data: ", - paste_s(missing_batches))) - - } else if (length(missing_batches) > 0) { + ..error( + paste0( + "One or more batch/cohort names specified in the validation_batch_id ", + "variable could not be found in the data: ", + paste_s(missing_batches) + ), + error_class = "dataset_error" + ) + + } else if (length(missing_batches) > 0L) { # Filter out the missing cohort names when external validation is not # performed. - settings$data$valid_cohorts <- setdiff( - settings$data$valid_cohorts, - missing_batches) + settings$data$valid_cohorts <- setdiff(settings$data$valid_cohorts, missing_batches) # If the remaining number of validation cohorts is zero, set valid_cohorts # to NULL - if (length(settings$data$valid_cohorts) == 0) settings$data$valid_cohorts <- NULL + if (length(settings$data$valid_cohorts) == 0L) settings$data$valid_cohorts <- NULL } # Infer validation cohorts. - if (!is.null(settings$data$train_cohorts) && - is.null(settings$data$valid_cohorts)) { + if ( + !is.null(settings$data$train_cohorts) && + is.null(settings$data$valid_cohorts) + ) { # Identify batch ids that appear in the data set but are not included for # development. These are then assigned for validation. new_validation_batch_id <- setdiff( available_batch_ids, - settings$data$train_cohorts) + settings$data$train_cohorts + ) - if (length(new_validation_batch_id) > 0 && perform_external_validation) { - message(paste0( - "One or more batches/cohorts were not used for development and are now ", - "used for external validation: ", - paste_s(new_validation_batch_id))) + if (length(new_validation_batch_id) > 0L && perform_external_validation) { + if (verbose) { + message(paste0( + "One or more batches/cohorts were not used for development and are now ", + "used for external validation: ", + paste_s(new_validation_batch_id) + )) + } settings$data$valid_cohorts <- new_validation_batch_id } else if (length(new_validation_batch_id)) { - message(paste0( - "One or more batches/cohorts in the data are not used for development because they ", - "were not provided in the development_batch_id variable.")) + if (verbose) { + message(paste0( + "One or more batches/cohorts in the data are not used for development because they ", + "were not provided in the development_batch_id variable." + )) + } } } # Infer training cohorts - if (is.null(settings$data$train_cohorts) && - !is.null(settings$data$valid_cohorts)) { + if ( + is.null(settings$data$train_cohorts) && !is.null(settings$data$valid_cohorts) + ) { # Identify batch ids that appear in the data set but are not included for # validation. These are then assigned for development. new_development_batch_id <- setdiff( available_batch_ids, - settings$data$valid_cohorts) + settings$data$valid_cohorts + ) - if (length(new_development_batch_id) > 0) { - message(paste0( - "One or more batches/cohorts were not used for external validation and are now ", - "used for development: ", - paste_s(new_development_batch_id))) + if (length(new_development_batch_id) > 0L) { + if (verbose) { + message(paste0( + "One or more batches/cohorts were not used for external validation and are now ", + "used for development: ", + paste_s(new_development_batch_id) + )) + } settings$data$train_cohorts <- new_development_batch_id } @@ -606,12 +722,17 @@ available_batch_ids, union( settings$data$train_cohorts, - settings$data$valid_cohorts)) + settings$data$valid_cohorts + ) + ) - if (length(unused_batch_id) > 0) { - message(paste0( - "One or more batches/cohorts are not used for development or external validation: ", - paste_s(unused_batch_id))) + if (length(unused_batch_id) > 0L) { + if (verbose) { + message(paste0( + "One or more batches/cohorts are not used for development or external validation: ", + paste_s(unused_batch_id) + )) + } } return(settings) @@ -623,7 +744,7 @@ #' #' This function allows for imputation of the most plausible outcome type. #' This imputation is only done for trivial cases, where there is little doubt. -#' As a consequence `count` and `continuous` outcome types are never imputed. +#' As a consequence `continuous` outcome type is never imputed. #' #' @param data Data set as loaded using the `.load_data` function. #' @param outcome_column Name of the outcome column in the data set. @@ -643,16 +764,21 @@ class_levels, censoring_indicator, event_indicator, - competing_risk_indicator) { + competing_risk_indicator +) { - if (length(outcome_column) > 2) { - stop(paste0( - "Only one or two (in case of survival endpoints) outcome columns are expected.", - "However ", length(outcome_column), " were found.")) + if (length(outcome_column) > 2L) { + ..error( + paste0( + "Only one or two (in case of survival endpoints) outcome columns are expected.", + "However ", length(outcome_column), " were found." + ), + error_class = "dataset_error" + ) } # Test for survival - if (length(outcome_column) == 2) { + if (length(outcome_column) == 2L) { # One column should contain continuous data >= 0.0 (time column). One column # should contain numerical or logical data with 0, 1 (event status column) @@ -663,7 +789,8 @@ data = data, censoring_indicator = censoring_indicator, event_indicator = event_indicator, - competing_risk_indicator = NULL) + competing_risk_indicator = NULL + ) event_competing_risk_cols <- sapply( outcome_column, @@ -671,43 +798,60 @@ data = data, censoring_indicator = censoring_indicator, event_indicator = event_indicator, - competing_risk_indicator = competing_risk_indicator) + competing_risk_indicator = competing_risk_indicator + ) # Check for presence of a time column time_cols <- sapply( outcome_column, .is_survival_time_col, - data = data) + data = data + ) - if (!any(time_cols) || - (!any(event_survival_cols) && !any(event_competing_risk_cols))) { + if ( + !any(time_cols) || + (!any(event_survival_cols) && !any(event_competing_risk_cols)) + ) { # Check if there is at least one event_col and one time_col, and in case # there is only one event_col and one time_col, that these are not the # same. - stop(paste0( - "Survival or competing risk outcomes were expected as two outcome columns were provided. ", - "However, data in the columns did not strictly correspond to these outcomes. ", - "Check if a survival outcome was intended, and provide a single outcome column otherwise. ", - "Columns for survival or competing risk outcomes should contain time (numeric values >= 0) and event status ", - "(0 and 1 or FALSE and TRUE, or values according to censoring_indicator, ", - "event_indicator and competing_risk_indicator arguments) information.")) + ..error( + paste0( + "Survival or competing risk outcomes were expected as two outcome columns were provided. ", + "However, data in the columns did not strictly correspond to these outcomes. ", + "Check if a survival outcome was intended, and provide a single outcome column otherwise. ", + "Columns for survival or competing risk outcomes should contain time (numeric values >= 0) and event status ", + "(0 and 1 or FALSE and TRUE, or values according to censoring_indicator, ", + "event_indicator and competing_risk_indicator arguments) information." + ), + error_class = "dataset_error" + ) - } else if (sum(time_cols) == 1 && - sum(event_survival_cols) == 1 && - sum(event_competing_risk_cols) == 1) { + } else if ( + sum(time_cols) == 1L && + sum(event_survival_cols) == 1L && + sum(event_competing_risk_cols) == 1L + ) { # Only one column of either type. The test below yields 0 if these are # different columns, and 1 if they are the same column, in which case an # error is raised. - if (sum(time_cols * event_survival_cols) && - sum(time_cols * event_competing_risk_cols)) { - stop(paste0( - "Survival or competing risk outcome was expected as two outcome columns were provided. ", - "However, data in the columns did not strictly correspond to these outcomes. ", - "Check if a survival outcome was intended, and provide a single outcome column otherwise. ", - "Columns for survival or competing risk outcomes should contain time (numeric values >= 0) and event status ", - "(0 and 1 or FALSE and TRUE, censoring_indicator, event_indicator ", - "and competing_risk_indicator arguments) information.")) + if ( + sum(time_cols * event_survival_cols) && + sum(time_cols * event_competing_risk_cols) + ) { + ..error( + paste0( + "Survival or competing risk outcome was expected as two outcome columns were provided. ", + "However, data in the columns did not strictly correspond to these outcomes. ", + "Check if a survival outcome was intended, and provide a single outcome column otherwise. ", + "Columns for survival or competing risk outcomes should contain time ", + "(numeric values >= 0) and event status ", + "(0 and 1 or FALSE and TRUE, censoring_indicator, event_indicator ", + "and competing_risk_indicator arguments) information." + ), + error_class = "dataset_error" + ) } } @@ -715,7 +859,8 @@ # Set outcome_type to survival as it is plausible message(paste0( "A survival outcome was imputed based on the data. If this is an incorrect type, ", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("survival") @@ -723,30 +868,33 @@ # Set outcome_type to competing_risk as it is plausible message(paste0( "A competing_risk outcome was imputed based on the data. If this is an incorrect type,", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("competing_risk") } } - if (length(outcome_column) == 1) { + if (length(outcome_column) == 1L) { # Extract data x <- data[[outcome_column]] # Test for binomial and multinomial outcomes based on class_levels if (!is.null(class_levels)) { if (all(x %in% class_levels, na.rm = TRUE)) { - if (length(class_levels) == 2) { + if (length(class_levels) == 2L) { message(paste0( "A binomial outcome was imputed based on the data. If this is an incorrect type, ", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("binomial") - } else if (length(class_levels) > 2) { + } else if (length(class_levels) > 2L) { message(paste0( "A multinomial outcome was imputed based on the data. If this is an incorrect type, ", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("multinomial") } @@ -757,17 +905,19 @@ # column, in this case factor. if (is.factor(x)) { - if (nlevels(x) == 2) { + if (nlevels(x) == 2L) { message(paste0( "A binomial outcome was imputed based on the data. If this is an incorrect type, ", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("binomial") - } else if (nlevels(x) > 2) { + } else if (nlevels(x) > 2L) { message(paste0( "A multinomial outcome was imputed based on the data. If this is an incorrect type,", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("multinomial") } @@ -778,7 +928,8 @@ if (is.logical(x)) { message(paste0( "A binomial outcome was imputed based on the data. If this is an incorrect type,", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("binomial") } @@ -786,28 +937,33 @@ # Test for categorical outcomes based on class of the data in the outcome # column, in this case character. if (is.character(x)) { - if (data.table::uniqueN(x, na.rm = TRUE) == 2) { + if (data.table::uniqueN(x, na.rm = TRUE) == 2L) { message(paste0( "A binomial outcome was imputed based on the data. If this is an incorrect type, ", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("binomial") - } else if (data.table::uniqueN(x, na.rm = TRUE) > 2) { + } else if (data.table::uniqueN(x, na.rm = TRUE) > 2L) { message(paste0( "A multinomial outcome was imputed based on the data. If this is an incorrect type, ", - "please provide an outcome_type manually.")) + "please provide an outcome_type manually." + )) return("multinomial") } } - # Tests for continuous and count type data are not really possible. One - # could test on is.numeric, and minimum value, but these data could still - # represent binomial (e.g. 0s and 1s) or multinomial data. One may devise - # some tests by counting the number of samples with a unique value, but this - # is dangerous for smaller data sets. - stop("Imputation of the outcome type was not possible. Please provide an outcome type manually.") + # Tests for continuous type data are not really possible. One could test on + # is.numeric, and minimum value, but these data could still represent + # binomial (e.g. 0s and 1s) or multinomial data. One may devise some tests + # by counting the number of samples with a unique value, but this is + # dangerous for smaller data sets. + ..error( + "Imputation of the outcome type was not possible. Please provide an outcome type manually.", + error_class = "dataset_error" + ) } } @@ -817,19 +973,20 @@ data, outcome_type, settings, - check_stringency = "strict") { + check_stringency = "strict" +) { # Skip checks if check stringency is external: no checks on outcome columns # are required. if (check_stringency == "external") return(settings) # Define standard indicators for censoring, event and competing risk. - standard_censoring_indicator <- c("0", "false", "f", "n", "no") + standard_censoring_indicator <- .get_available_default_censoring_indicator() if (!is.null(settings$data$censoring_indicator)) { standard_censoring_indicator <- settings$data$censoring_indicator } - standard_event_indicator <- c("1", "true", "t", "y", "yes") + standard_event_indicator <- .get_available_default_event_indicator() if (!is.null(settings$data$event_indicator)) { standard_event_indicator <- settings$data$event_indicator } @@ -843,7 +1000,8 @@ all_indicators <- c( standard_censoring_indicator, standard_event_indicator, - standard_competing_risk_indicator) + standard_competing_risk_indicator + ) # Find the number of matches with each of the two outcome columns. n_matches <- sapply( @@ -852,10 +1010,11 @@ x <- data[[column]] x <- tolower(as.character(x[!is.na(x)])) - return(sum(x %in% tolower(all_indicators))) - }, - data = data, - all_indicators = all_indicators) + return(sum(x %in% tolower(all_indicators))) + }, + data = data, + all_indicators = all_indicators + ) # For non-strict test, we assume that that outcome columns are already # organised as time, event, whereas for strict tests we need to identify it de @@ -865,7 +1024,7 @@ event_column <- settings$data$outcome_col[which.max(n_matches)] } else { - event_column <- settings$data$outcome_col[2] + event_column <- settings$data$outcome_col[2L] } # Select unique values in the event column. @@ -874,71 +1033,101 @@ # Try to identify indicators present in the dataset. present_censoring_indicator <- event_values[ - tolower(as.character(event_values)) %in% tolower(standard_censoring_indicator)] + tolower(as.character(event_values)) %in% tolower(standard_censoring_indicator) + ] present_event_indicator <- event_values[ - tolower(as.character(event_values)) %in% tolower(standard_event_indicator)] + tolower(as.character(event_values)) %in% tolower(standard_event_indicator) + ] present_competing_risk_indicator <- event_values[ - tolower(as.character(event_values)) %in% tolower(standard_competing_risk_indicator)] + tolower(as.character(event_values)) %in% tolower(standard_competing_risk_indicator) + ] # Identify values in the event column which are not yet assigned. event_values <- setdiff( - event_values, c( - present_censoring_indicator, - present_event_indicator, - present_competing_risk_indicator)) + event_values, + c( + present_censoring_indicator, + present_event_indicator, + present_competing_risk_indicator + ) + ) # Check the presence of user-provided indicators. - if (!is.null(settings$data$event_indicator) && length(event_values) > 0) { + if (!is.null(settings$data$event_indicator) && length(event_values) > 0L) { # An event indicator should always be present. - if (!all(tolower(as.character(settings$data$event_indicator)) %in% tolower(as.character(event_values))) && - check_stringency == "strict") { - stop(paste0( - "The following provided event indicator(s) were not found in the data: ", - paste_s(setdiff( - tolower(as.character(settings$data$event_indicator)), - tolower(as.character(event_values)))), - " . Please check for spelling errors.")) + if ( + !all(tolower(as.character(settings$data$event_indicator)) %in% tolower(as.character(event_values))) && + check_stringency == "strict" + ) { + ..error( + paste0( + "The following provided event indicator(s) were not found in the data: ", + paste_s(setdiff( + tolower(as.character(settings$data$event_indicator)), + tolower(as.character(event_values)) + )), + " . Please check for spelling errors." + ), + error_class = "dataset_error" + ) } } - if (!is.null(settings$data$censoring_indicator) && length(event_values) > 0) { + if (!is.null(settings$data$censoring_indicator) && length(event_values) > 0L) { # An censoring indicator is not required to be present, but if the user # provides one, and it isn't found in the dataset, raise an error. - if (!all(tolower(as.character(settings$data$censoring_indicator)) %in% tolower(as.character(event_values))) && - check_stringency == "strict") { - stop(paste0( - "The following provided censoring indicator(s) were not found in the data: ", - paste_s(setdiff( - tolower(as.character(settings$data$censoring_indicator)), - tolower(as.character(event_values)))))) + if ( + !all(tolower(as.character(settings$data$censoring_indicator)) %in% tolower(as.character(event_values))) && + check_stringency == "strict" + ) { + ..error( + paste0( + "The following provided censoring indicator(s) were not found in the data: ", + paste_s(setdiff( + tolower(as.character(settings$data$censoring_indicator)), + tolower(as.character(event_values)) + )) + ), + error_class = "dataset_error" + ) } } - if (!is.null(settings$data$competing_risk_indicator) && length(event_values) > 0) { + if (!is.null(settings$data$competing_risk_indicator) && length(event_values) > 0L) { # Competing risk indicators are only present in competing_risk outcomes. if (outcome_type == "survival" && check_stringency == "strict") { - stop(paste0( - "One or indicators for competing risks were specified. ", - "However, the outcome type was set to survival, which does not check competing risks. ", - "Please change outcome_type to competing_risk, or remove the competing risk indicators.")) + ..error( + paste0( + "One or indicators for competing risks were specified. ", + "However, the outcome type was set to survival, which does not check competing risks. ", + "Please change outcome_type to competing_risk, or remove the competing risk indicators." + ), + error_class = "dataset_error" + ) } - if (!all(tolower(as.character(settings$data$competing_risk_indicator)) %in% tolower(as.character(event_values))) && - check_stringency == "strict") { - stop(paste0( - "The following provided competing risk indicator(s) were not found in the data: ", - paste_s(setdiff( - tolower(as.character(settings$data$competing_risk_indicator)), - tolower(as.character(event_values)))))) + if ( + !all(tolower(as.character(settings$data$competing_risk_indicator)) %in% tolower(as.character(event_values))) && + check_stringency == "strict" + ) { + ..error( + paste0( + "The following provided competing risk indicator(s) were not found in the data: ", + paste_s(setdiff( + tolower(as.character(settings$data$competing_risk_indicator)), + tolower(as.character(event_values)) + )) + ), + error_class = "dataset_error" + ) } } - if (length(event_values) > 0) { + if (length(event_values) > 0L) { # Event indicator can only be determined if there is one value left over. - if (length(present_event_indicator) == 0) { - - if (length(event_values) == 1) { + if (length(present_event_indicator) == 0L) { + if (length(event_values) == 1L) { # Assign the remaining value to the event indicator. present_event_indicator <- event_values @@ -948,10 +1137,14 @@ if (check_stringency %in% c("strict", "external_warn")) { # Throw a warning, because the assumption may be false. - warning(paste0( - "The event indicator for survival/competing risk outcomes was neither ", - "a standard value, nor provided. Based on the values found in ", event_column, - ", ", present_event_indicator, " was selected as an event indicator.")) + ..warning( + paste0( + "The event indicator for survival/competing risk outcomes was neither ", + "a standard value, nor provided. Based on the values found in ", event_column, + ", ", present_event_indicator, " was selected as an event indicator." + ), + error_class = "dataset_error" + ) } } else if (check_stringency %in% c("strict", "external_warn")) { @@ -960,14 +1153,16 @@ "The event indicator for survival/competing risk outcomes was neither ", "a standard value, nor provided. More than one unassigned value was found in ", event_column, ", preventing automatic assignment: ", - paste_s(event_values)), - as_error = check_stringency == "strict") + paste_s(event_values) + ), + as_error = check_stringency == "strict" + ) } } } - if (length(event_values) > 0 && outcome_type == "survival") { - if (length(present_censoring_indicator) == 0) { + if (length(event_values) > 0L && outcome_type == "survival") { + if (length(present_censoring_indicator) == 0L) { # Assign all remaining values. present_censoring_indicator <- event_values @@ -977,12 +1172,16 @@ if (check_stringency %in% c("strict", "external_warn")) { # Throw a warning, because the assumption may be false. - warning(paste0( - "The censoring indicator for the survival outcome was neither a standard value, nor provided. ", - "Based on the values found in ", event_column, ", ", - paste_s(present_censoring_indicator), - ifelse(length(present_censoring_indicator) == 1, " was", " were"), - " selected as censoring indicator.")) + ..warning( + paste0( + "The censoring indicator for the survival outcome was neither a standard value, nor provided. ", + "Based on the values found in ", event_column, ", ", + paste_s(present_censoring_indicator), + ifelse(length(present_censoring_indicator) == 1L, " was", " were"), + " selected as censoring indicator." + ), + warning_class = "dataset_error" + ) } } else if (check_stringency %in% c("strict", "external_warn")) { @@ -990,24 +1189,29 @@ paste0( "One or more unassigned values for the survival outcome were found in ", event_column, ": ", paste_s(event_values), - ". Please assign manually."), - as_error = check_stringency == "strict") + ". Please assign manually." + ), + as_error = check_stringency == "strict" + ) } } - if (length(event_values) > 0 && outcome_type == "competing_risk") { - if (length(present_censoring_indicator) == 0 && - length(present_competing_risk_indicator) == 0) { + if (length(event_values) > 0L && outcome_type == "competing_risk") { + if ( + length(present_censoring_indicator) == 0L && length(present_competing_risk_indicator) == 0L + ) { if (check_stringency %in% c("strict", "external_warn")) { stop_or_warn( paste0( "One or more unassigned values for the survival outcome were found in ", event_column, ": ", paste_s(event_values), ". These could not be assigned automatically as indicators for ", - "censoring and competing risks were both missing. Please assign manually."), - as_error = check_stringency == "strict") + "censoring and competing risks were both missing. Please assign manually." + ), + as_error = check_stringency == "strict" + ) } - } else if (length(present_censoring_indicator) == 0) { + } else if (length(present_censoring_indicator) == 0L) { # Assign all remaining values. present_censoring_indicator <- event_values @@ -1017,15 +1221,19 @@ if (check_stringency %in% c("strict", "external_warn")) { # Throw a warning, because the assumption may be false. - warning(paste0( - "The censoring indicator for the competing risk outcome was neither a standard value, nor provided. ", - "Based on the values found in ", event_column, ", ", - paste_s(present_censoring_indicator), - ifelse(length(present_censoring_indicator) == 1, " was", " were"), - " selected as censoring indicator.")) + ..warning( + paste0( + "The censoring indicator for the competing risk outcome was neither a standard value, nor provided. ", + "Based on the values found in ", event_column, ", ", + paste_s(present_censoring_indicator), + ifelse(length(present_censoring_indicator) == 1L, " was", " were"), + " selected as censoring indicator." + ), + warning_class = "dataset_error" + ) } - } else if (length(present_competing_risk_indicator) == 0) { + } else if (length(present_competing_risk_indicator) == 0L) { # Assign all remaining values. present_competing_risk_indicator <- event_values @@ -1035,12 +1243,16 @@ if (check_stringency %in% c("strict", "external_warn")) { # Throw a warning, because the assumption may be false. - warning(paste0( - "The competing risk indicator for the competing risk outcome was not provided. ", - "Based on the values found in ", event_column, ", ", - paste_s(present_competing_risk_indicator), - ifelse(length(present_competing_risk_indicator) == 1, " was", " were"), - " selected as competing risk indicator.")) + ..warning( + paste0( + "The competing risk indicator for the competing risk outcome was not provided. ", + "Based on the values found in ", event_column, ", ", + paste_s(present_competing_risk_indicator), + ifelse(length(present_competing_risk_indicator) == 1L, " was", " were"), + " selected as competing risk indicator." + ), + warning_class = "dataset_error" + ) } } else { @@ -1049,14 +1261,16 @@ paste0( "One or more unassigned values for the competing risk outcome were found in ", event_column, ": ", paste_s(event_values), - ". Please assign manually to the indicators."), - as_error = check_stringency == "strict") + ". Please assign manually to the indicators." + ), + as_error = check_stringency == "strict" + ) } } } # Update censoring indicator in settings. - if (length(present_censoring_indicator) > 0) { + if (length(present_censoring_indicator) > 0L) { settings$data$censoring_indicator <- present_censoring_indicator } else { @@ -1064,14 +1278,14 @@ } # Update event indicator in settings. - if (length(present_event_indicator) > 0) { + if (length(present_event_indicator) > 0L) { settings$data$event_indicator <- present_event_indicator } else { settings$data$event_indicator <- NULL } - if (length(present_competing_risk_indicator) > 0) { + if (length(present_competing_risk_indicator) > 0L) { settings$data$competing_risk_indicator <- present_competing_risk_indicator } else { @@ -1115,19 +1329,30 @@ censoring_indicator, event_indicator, competing_risk_indicator, - check_stringency = "strict") { + check_stringency = "strict" +) { # Checks plausibility of the outcome type and identifies any errors # Check if only a single outcome_type is specified. - if (length(outcome_type) != 1) { - stop(paste0("A single outcome type should be provided. Found: ", length(outcome_type))) + if (length(outcome_type) != 1L) { + ..error( + paste0("A single outcome type should be provided. Found: ", length(outcome_type)), + error_class = "input_argument_error" + ) + } + + # Check for the count outcome type -- this type of outcome was deprecated in + # version 2.0.0. + if (outcome_type == "count") { + ..deprecation_count(as_error = TRUE) } # Check if the provided outcome_type is a valid choice. if (!outcome_type %in% c( - "binomial", "multinomial", "count", "continuous", - "survival", "competing_risk", "unsupervised")) { + "binomial", "multinomial", "continuous", + "survival", "competing_risk", "unsupervised" + )) { ..error_no_known_outcome_type(outcome_type) } @@ -1137,41 +1362,57 @@ if (check_stringency != "strict" && !is.null(outcome_column)) { # For non-strict checks only check in case any outcome columns are # present. - if (length(outcome_column) != 2) { - stop(paste0( - "Two outcome columns are expected for data with survival outcomes. Found: ", - length(outcome_column))) + if (length(outcome_column) != 2L) { + ..error( + paste0( + "Two outcome columns are expected for data with survival outcomes. Found: ", + length(outcome_column) + ), + error_class = "dataset_error" + ) } } else if (check_stringency == "strict") { # For strict checks always check. - if (length(outcome_column) != 2) { - stop(paste0( - "Two outcome columns are expected for data with survival outcomes. Found: ", - length(outcome_column))) + if (length(outcome_column) != 2L) { + ..error( + paste0( + "Two outcome columns are expected for data with survival outcomes. Found: ", + length(outcome_column) + ), + error_class = "dataset_error" + ) } } } - # Check if one column is provided for binomial, multinomial, count and - # continuous outcome types. - if (outcome_type %in% c("binomial", "multinomial", "count", "continuous")) { + # Check if one column is provided for binomial, multinomial, and continuous + # outcome types. + if (outcome_type %in% c("binomial", "multinomial", "continuous")) { if (check_stringency != "strict" && !is.null(outcome_column)) { # For non-strict checks only check in case any outcome columns are # present. - if (length(outcome_column) != 1) { - stop(paste0( - "One outcome column is expected for data with ", outcome_type, " outcomes. ", - "Found: ", length(outcome_column))) + if (length(outcome_column) != 1L) { + ..error( + paste0( + "One outcome column is expected for data with ", outcome_type, " outcomes. ", + "Found: ", length(outcome_column) + ), + error_class = "dataset_error" + ) } } else if (check_stringency == "strict") { # For strict checks always check. - if (length(outcome_column) != 1) { - stop(paste0( - "One outcome column is expected for data with ", outcome_type, " outcomes. ", - "Found: ", length(outcome_column))) + if (length(outcome_column) != 1L) { + ..error( + paste0( + "One outcome column is expected for data with ", outcome_type, " outcomes. ", + "Found: ", length(outcome_column) + ), + error_class = "dataset_error" + ) } } } @@ -1181,10 +1422,14 @@ if (check_stringency == "strict") { # For strict checks always check if outcome columns are present. - if (length(outcome_column) > 0) { - stop(paste0( - "No outcome columns are expected for unsupervised analysis. Found: ", - paste_s(outcome_column))) + if (length(outcome_column) > 0L) { + ..error( + paste0( + "No outcome columns are expected for unsupervised analysis. Found: ", + paste_s(outcome_column) + ), + error_class = "dataset_error" + ) } } } @@ -1195,22 +1440,25 @@ outcome_na <- any(sapply( outcome_column, function(ii, data) (!any(is_valid_data(data[[ii]]))), - data = data)) + data = data + )) } - if (check_stringency == "strict" && - outcome_na && - outcome_type != "unsupervised") { + if ( + check_stringency == "strict" && outcome_na && outcome_type != "unsupervised" + ) { # Under strict conditions, outcome data should be present. - stop(paste0("Outcome column(s) do not contain any data.")) + ..error("Outcome column(s) do not contain any data.", error_class = "dataset_error") - } else if (check_stringency == "external_warn" && - outcome_na && - outcome_type != "unsupervised") { + } else if ( + check_stringency == "external_warn" && outcome_na && outcome_type != "unsupervised" + ) { # Under less strict conditions, outcome data may be absent, but the user # should be warned. - warning(paste0( - "Outcome column(s) do not contain any data. Some evaluation steps may fail to produce results.")) + ..warning( + "Outcome column(s) do not contain any data. Some evaluation steps may fail to produce results.", + warning_class = "dataset_error" + ) } # Plausibility checks for binomial outcome type @@ -1220,25 +1468,37 @@ classes_present <- unique_na(data[[outcome_column]]) if (check_stringency == "strict") { - if (length(classes_present) > 2) { - stop(paste0( - "More than two classes (", paste_s(classes_present), - ") were found in the outcome column: ", outcome_column, ". ", - "Exactly two classes are expected for the binomial outcome type. ", - "Specify outcome_type=\"multinomial\" if this is intentional.")) + if (length(classes_present) > 2L) { + ..error( + paste0( + "More than two classes (", paste_s(classes_present), + ") were found in the outcome column: ", outcome_column, ". ", + "Exactly two classes are expected for the binomial outcome type. ", + "Specify outcome_type=\"multinomial\" if this is intentional." + ), + error_class = "dataset_error" + ) - } else if (length(classes_present) < 2) { - stop(paste0( - "Fewer than two classes were found in the outcome column: ", outcome_column, - ". Exactly two classes are expected for the binomial outcome type.")) + } else if (length(classes_present) < 2L) { + ..error( + paste0( + "Fewer than two classes were found in the outcome column: ", outcome_column, + ". Exactly two classes are expected for the binomial outcome type." + ), + error_class = "dataset_error" + ) } } else if (check_stringency == "external_warn") { - if (length(classes_present) > 2) { - stop(paste0( - "More than two classes (", paste_s(classes_present), - ") were found in the outcome column: ", outcome_column, - ". Exactly two classes are expected for the binomial outcome type.")) + if (length(classes_present) > 2L) { + ..error( + paste0( + "More than two classes (", paste_s(classes_present), + ") were found in the outcome column: ", outcome_column, + ". Exactly two classes are expected for the binomial outcome type." + ), + error_class = "dataset_error" + ) } } } @@ -1249,32 +1509,14 @@ classes_present <- unique_na(data[[outcome_column]]) if (check_stringency == "strict") { - if (length(classes_present) < 2) { - stop(paste0( - "Fewer than two classes were found in the outcome column:", outcome_column, - ". Two or more classes are expected for the multinomial outcome type.")) - } - } - } - - # Plausibility check for the count outcome type - if (outcome_type == "count" && !outcome_na) { - - ..deprecation_count() - - if (check_stringency %in% c("strict", "external_warn")) { - if (!is.numeric(data[[outcome_column]])) { - stop(paste0( - "The outcome column (", outcome_column, ") does not contain numeric data. ", - "Numeric data are expected for the count outcome type.")) - } - - if (min(data[[outcome_column]], na.rm = TRUE) < 0.0) { - stop_or_warn( + if (length(classes_present) < 2L) { + ..error( paste0( - "The outcome column (", outcome_column, ") contains values smaller than 0. ", - "The count outcome type expects that all values are 0 or greater."), - check_stringency == "strict") + "Fewer than two classes were found in the outcome column:", outcome_column, + ". Two or more classes are expected for the multinomial outcome type." + ), + error_class = "dataset_error" + ) } } } @@ -1284,9 +1526,13 @@ if (check_stringency %in% c("strict", "external_warn")) { if (!is.numeric(data[[outcome_column]])) { - stop(paste0( - "The outcome column (", outcome_column, ") does not contain numeric data. ", - "Numeric data are expected for the continuous outcome type.")) + ..error( + paste0( + "The outcome column (", outcome_column, ") does not contain numeric data. ", + "Numeric data are expected for the continuous outcome type." + ), + error_class = "dataset_error" + ) } } } @@ -1304,7 +1550,8 @@ data = data, censoring_indicator = censoring_indicator, event_indicator = event_indicator, - competing_risk_indicator = NULL) + competing_risk_indicator = NULL + ) } else { event_cols <- sapply( @@ -1313,50 +1560,69 @@ data = data, censoring_indicator = censoring_indicator, event_indicator = event_indicator, - competing_risk_indicator = competing_risk_indicator) + competing_risk_indicator = competing_risk_indicator + ) } time_cols <- sapply( outcome_column, .is_survival_time_col, - data = data) + data = data + ) # Check if there is at least one event_col and one time_col, and in case # there is only one event_col and one time_col, that these are not the # same. if (!any(event_cols)) { - stop(paste0( - "None of the outcome columns (", paste_s(outcome_column), - ") contain event status information. This column may only contain values 0 and 1 or ", - "FALSE and TRUE, or the value indicated by ", - ifelse( - outcome_type == "survival", - "censoring_indicator and event_indicator", - "censoring_indicator, event_indicator and competing_risk_indicator"), - " arguments.")) + ..error( + paste0( + "None of the outcome columns (", paste_s(outcome_column), + ") contain event status information. This column may only contain values 0 and 1 or ", + "FALSE and TRUE, or the value indicated by ", + ifelse( + outcome_type == "survival", + "censoring_indicator and event_indicator", + "censoring_indicator, event_indicator and competing_risk_indicator" + ), + " arguments." + ), + error_class = "dataset_error" + ) } else if (all(event_cols)) { - stop(paste0( - "Both outcome columns (", paste_s(outcome_column), - ") seem to contain event status information. One column with survival times should ", - "be provided together with one column with survival event status information.")) + ..error( + paste0( + "Both outcome columns (", paste_s(outcome_column), + ") seem to contain event status information. One column with survival times should ", + "be provided together with one column with survival event status information." + ), + error_class = "dataset_error" + ) } else if (!any(time_cols)) { - stop(paste0( - "None of the outcome columns (", paste_s(outcome_column), - ") contain survival time information. This column may only contain numeric values ", - "greater or equal to 0.")) + ..error( + paste0( + "None of the outcome columns (", paste_s(outcome_column), + ") contain survival time information. This column may only contain numeric values ", + "greater or equal to 0." + ), + error_class = "dataset_error" + ) - } else if (sum(time_cols) == 1 && sum(event_cols) == 1) { + } else if (sum(time_cols) == 1L && sum(event_cols) == 1L) { # Only one column of either type. The test below yields 0 if these are # different columns, and 1 if they are the same column, in which case an # error is raised. if (sum(time_cols * event_cols)) { - stop(paste0( - "None of the outcome columns (", paste_s(outcome_column), - ") contain survival time information. This column may only contain numeric values ", - "greater or equal to 0, and may not contain only 0s and 1s to avoid misinterpration ", - "as event status information.")) + ..error( + paste0( + "None of the outcome columns (", paste_s(outcome_column), + ") contain survival time information. This column may only contain numeric values ", + "greater or equal to 0, and may not contain only 0s and 1s to avoid misinterpration ", + "as event status information." + ), + error_class = "dataset_error" + ) } } } @@ -1395,13 +1661,18 @@ other_id_column = NULL, outcome_column = NULL, col_type, - check_stringency = "strict") { + check_stringency = "strict" +) { # Check number of provided columns - if (length(id_column) > 1) { - stop(paste0( - "Only one column is expected to be contain ", col_type, " identifiers. ", - length(id_column), " columns were provided.")) + if (length(id_column) > 1L) { + ..error( + paste0( + "Only one column is expected to be contain ", col_type, " identifiers. ", + length(id_column), " columns were provided." + ), + error_class = "dataset_error" + ) } # End of checks for external. @@ -1413,22 +1684,32 @@ stop_or_warn( paste0( "The ", col_type, " identifier column ", id_column, - " does not appear in the provided data set."), - check_stringency == "strict") + " does not appear in the provided data set." + ), + check_stringency == "strict" + ) } # Check whether the id column is the same as another id_column - if (length(intersect(id_column, other_id_column)) > 0) { - stop(paste0( - "The ", col_type, " identifier column ", id_column, - " is also used as a different identifier column.")) + if (length(intersect(id_column, other_id_column)) > 0L) { + ..error( + paste0( + "The ", col_type, " identifier column ", id_column, + " is also used as a different identifier column." + ), + error_class = "dataset_error" + ) } # Check whether the id column overlaps with the outcome column - if (length(intersect(id_column, outcome_column)) > 0) { - stop(paste0( - "The ", col_type, " identifier column ", id_column, - " is also used as an outcome column.")) + if (length(intersect(id_column, outcome_column)) > 0L) { + ..error( + paste0( + "The ", col_type, " identifier column ", id_column, + " is also used as an outcome column." + ), + error_class = "dataset_error" + ) } # End of checks for external_warn. Only strict remains. @@ -1436,26 +1717,38 @@ # Check whether the identifier column is erroneously included in the # signature. - if (length(intersect(id_column, signature)) > 0) { - stop(paste0( - "The ", col_type, " identifier column ", id_column, - " also appears in the signature.")) + if (length(intersect(id_column, signature)) > 0L) { + ..error( + paste0( + "The ", col_type, " identifier column ", id_column, + " also appears in the signature." + ), + error_class = "dataset_error" + ) } # Check whether the identifier column is erroneously included in the set of # features marked for exclusion. - if (length(intersect(id_column, exclude_features)) > 0) { - stop(paste0( - "The ", col_type, " identifier column ", id_column, - " also appears among the features marked for exclusion.")) + if (length(intersect(id_column, exclude_features)) > 0L) { + ..error( + paste0( + "The ", col_type, " identifier column ", id_column, + " also appears among the features marked for exclusion." + ), + error_class = "dataset_error" + ) } # Check whether the identifier column is erroneously included in the set of # features marked for inclusion. - if (length(intersect(id_column, include_features)) > 0) { - stop(paste0( - "The ", col_type, " identifier column ", id_column, - " also appears among the features marked for inclusion.")) + if (length(intersect(id_column, include_features)) > 0L) { + ..error( + paste0( + "The ", col_type, " identifier column ", id_column, + " also appears among the features marked for inclusion." + ), + error_class = "dataset_error" + ) } return(invisible(TRUE)) @@ -1479,20 +1772,25 @@ data, outcome_type, outcome_column, - check_stringency = "strict") { + check_stringency = "strict" +) { if (outcome_type %in% c("survival", "competing_risk")) { - # Find the levels in the data outcome_time <- unique_na(data[[outcome_column]]) - if (length(outcome_time) > 0) { - if (any(outcome_time <= 0.0) && - check_stringency %in% c("strict", "external_warn")) { - warning(paste0( - "Survival data contain instances with non-positive (zero or negative) time. ", - "Some packages that could be used during the analysis, such as glmnet, ", - "will not be able to produce useful models.")) + if (length(outcome_time) > 0L) { + if ( + any(outcome_time <= 0.0) && check_stringency %in% c("strict", "external_warn") + ) { + ..warning( + paste0( + "Survival data contain instances with non-positive (zero or negative) time. ", + "Some packages that could be used during the analysis, such as glmnet, ", + "will not be able to produce useful models." + ), + warning_class = "dataset_error" + ) } } } @@ -1519,10 +1817,14 @@ outcome_type, outcome_column, class_levels, - check_stringency = "strict") { + check_stringency = "strict" +) { - if (outcome_type %in% c("binomial", "multinomial") && - !is.null(class_levels)) { + if ( + outcome_type %in% c("binomial", "multinomial") && + !is.null(class_levels) && + !is.null(outcome_column) + ) { # Find the levels in the data unique_levels <- unique_na(data[[outcome_column]]) @@ -1531,10 +1833,14 @@ missing_levels <- setdiff(unique_levels, class_levels) if (check_stringency %in% c("strict", "external_warn")) { - if (length(missing_levels) > 0) { - stop(paste0( - "The outcome data contains levels that are not found among the provided class levels: ", - paste_s(missing_levels))) + if (length(missing_levels) > 0L) { + ..error( + paste0( + "The outcome data contains levels that are not found among the provided class levels: ", + paste_s(missing_levels) + ), + error_class = "dataset_error" + ) } } } @@ -1561,10 +1867,14 @@ # Missing features are features that are not available in the provided data. missing_feature <- feature[!feature %in% colnames(data)] - if (length(missing_feature) > 0) { - stop(paste0( - "One or more features could not be found in the data set: ", - paste_s(missing_feature))) + if (length(missing_feature) > 0L) { + ..error( + paste0( + "One or more features could not be found in the data set: ", + paste_s(missing_feature) + ), + error_class = "dataset_error" + ) } return(invisible(TRUE)) @@ -1577,14 +1887,16 @@ data, censoring_indicator = NULL, event_indicator = NULL, - competing_risk_indicator = NULL) { + competing_risk_indicator = NULL +) { # Identify if the column could contain survival status information. # Find all indicators present_indicators <- c( censoring_indicator, event_indicator, - competing_risk_indicator) + competing_risk_indicator + ) if (!is.null(present_indicators)) { x <- data[[column_name]] @@ -1601,7 +1913,7 @@ x <- x[is.finite(x)] # Check if all finite values are either 0 or 1 - return((sum(x == 0) + sum(x == 1)) == length(x)) + return((sum(x == 0L) + sum(x == 1L)) == length(x)) } @@ -1625,3 +1937,12 @@ return(FALSE) } + + +.get_available_default_censoring_indicator <- function() { + return(c("0", "false", "f", "n", "no")) +} + +.get_available_default_event_indicator <- function() { + return(c("1", "true", "t", "y", "yes")) +} diff --git a/R/DataPreProcessing.R b/R/DataPreProcessing.R index ed298964..cee14857 100644 --- a/R/DataPreProcessing.R +++ b/R/DataPreProcessing.R @@ -1,326 +1,46 @@ -run_preprocessing <- function( - cl, - feature_info_list = NULL, - project_info, - settings, - file_paths, - message_indent = 0L, - verbose) { - - # Suppress NOTES due to non-standard evaluation in data.table - data_id <- run_id <- list_name <- complete <- NULL - - # Determine how parallel processing takes place. - if (settings$prep$do_parallel %in% c("TRUE", "inner")) { - # Parallel processing in inner function, i.e. within each data subset. - cl_inner <- cl - cl_outer <- NULL - - } else if (settings$prep$do_parallel %in% c("outer")) { - # Parallel processing in outer loop, i.e. over all data subsets. - cl_inner <- NULL - cl_outer <- cl - - if (!is.null(cl_outer)) { - logger_message(paste0( - "\nPre-processing: Load-balanced parallel processing is done in the outer loop. ", - "No progress can be displayed."), - indent = message_indent, - verbose = verbose) - } - - } else { - # No parallel processing. - cl_inner <- cl_outer <- NULL - } - - # Check if a feature info list was already created. This will typically - # generate a generic feature info list when called from summon_familiar. - if (is.null(feature_info_list)) { - feature_info_list <- .get_feature_info_data( - data = get_data_from_backend(), - file_paths = file_paths, - project_id = project_info$project_id, - outcome_type = settings$data$outcome_type) - } - - # TODO: Check if the generic contains all the required data -- particularly - # for externally provided feature information. - - # Create a list of runs for which pre-processing information should be - # obtained. First find the data ids over which should be iterated. - data_id <- c( - .get_process_step_data_identifier( - project_info = project_info, - process_step = "fs"), - .get_process_step_data_identifier( - project_info = project_info, - process_step = "mb")) - - # Create a list of runs, with data_id and run_id. - run_list <- data.table::rbindlist(lapply( - unique(data_id), - function(data_id, project_info) { - # Find the current data identifier for pre-processing. This may or may not - # be data_id. - pre_process_data_id <- .get_preprocessing_iteration_identifiers(run = .get_run_list( - iteration_list = project_info$iter_list, - data_id = data_id, - run_id = 1))$data - - # Find data and run ids. - iteration_list <- .get_run_list( - iteration_list = project_info$iter_list, - data_id = pre_process_data_id) - - # Iterate over the iteration list, extract the run-table and return it. - return(data.table::rbindlist(lapply( - iteration_list, - function(x) (tail(x$run_table, n = 1L))))) - }, - project_info = project_info)) - - # Remove duplicates. - run_list <- unique(run_list) - - # Add list names and check for completeness. - run_list[, ":="( - "list_name" = .get_feature_info_list_name(data_id = data_id, run_id = run_id), - "complete" = FALSE)] - - # Iterate over the runs and check which feature information lists are already - # fully complete. - run_list[, "complete" := feature_info_complete(feature_info_list[[list_name]]), by = "list_name"] - - # Get all runs which are not (fully) complete, and add some additional data. - run_list <- run_list[complete == FALSE, ] - - if (!is_empty(run_list)) { - # Set preprocessing run identifier and total number of datasets. - run_list[, ":="( - "preprocessing_run_id" = .I, - "n_preprocessing_runs" = nrow(run_list))] - - # Iterate over data subsets for which parameters have not yet been set. - new_feature_info_list <- fam_mapply_lb( - cl = cl_outer, - assign = "data", - FUN = .run_preprocessing, - progress_bar = !is.null(cl_outer), - run = split(run_list, by = c("preprocessing_run_id")), - MoreArgs = list( - "cl" = cl_inner, - "feature_info_list" = feature_info_list, - "project_info" = project_info, - "settings" = settings, - "message_indent" = message_indent, - "verbose" = verbose & is.null(cl_outer))) - - # Set names of the new feature list. - names(new_feature_info_list) <- run_list$list_name - - # Update lists with feature information. - feature_info_list[run_list$list_name] <- new_feature_info_list - } - - # Save to file, if necessary. - if (!is.null(file_paths)) { - # Determine file name - feature_info_file <- .get_feature_info_file_name( - file_paths = file_paths, - project_id = project_info$project_id) - - # Write to file - saveRDS(feature_info_list, file = feature_info_file) - } - - # Attach the feature info file to the backend. - .assign_feature_info_to_backend(feature_info_list = feature_info_list) - - return(invisible(TRUE)) -} - - - -.run_preprocessing <- function( - cl = NULL, - run, - feature_info_list, - project_info, - settings, - message_indent, - verbose) { - - logger_message( - paste0( - "\nPre-processing: Starting preprocessing for run ", - run$preprocessing_run_id, " of ", - run$n_preprocessing_runs, "."), - indent = message_indent, - verbose = verbose) - - # Selected feature information list. - template_feature_info <- combine_feature_info_list( - preferred = feature_info_list[[run$list_name]], - custom = feature_info_list[["custom"]], - generic = feature_info_list[["generic"]]) - - # Find pre-processing parameters - feature_info_list <- determine_preprocessing_parameters( - cl = cl, - feature_info_list = template_feature_info, - data_id = run$data_id, - run_id = run$run_id, - project_info = project_info, - settings = settings, - message_indent = message_indent + 1L, - verbose = verbose) - - return(feature_info_list) -} - - - -determine_preprocessing_parameters <- function( - cl = NULL, - feature_info_list, - data_id, - run_id, - project_info, - settings, - message_indent, - verbose) { - - # Add workflow control info. - feature_info_list <- add_control_info( - feature_info_list = feature_info_list, - data_id = data_id, - run_id = run_id) - - # Add signature feature info. - feature_info_list <- add_signature_info( - feature_info_list = feature_info_list, - signature = settings$data$signature) - - # Add novelty feature info. - feature_info_list <- add_novelty_info( - feature_info_list = feature_info_list, - novelty_features = settings$data$novelty_features) - - # Find the run list. - run_list <- .get_run_list( - iteration_list = project_info$iter_list, - data_id = data_id, - run_id = run_id) - - # Select unique samples. - sample_identifiers <- .get_sample_identifiers( - run = run_list, - train_or_validate = "train") - sample_identifiers <- unique(sample_identifiers) - - # Find currently available features. - available_features <- get_available_features(feature_info_list = feature_info_list) - - # Create a dataObject. - data <- methods::new( - "dataObject", - data = get_data_from_backend(sample_identifiers = sample_identifiers), - preprocessing_level = "none", - outcome_type = settings$data$outcome_type) - - # Remove unavailable features from the data object. - data <- filter_features( - data = data, - available_features = available_features) - - return(.determine_preprocessing_parameters( - cl = cl, - data = data, - feature_info_list = feature_info_list, - settings = settings, - message_indent = message_indent, - verbose = verbose)) -} - - - -.get_feature_info_file_name <- function(file_paths, project_id) { - # Generate file name of pre-processing file - file_name <- paste0(project_id, "_feature_info.RDS") - - # Add file path and normalise according to the OS - file_name <- normalizePath(file.path( - file_paths$process_data_dir, file_name), mustWork = FALSE) - - return(file_name) -} - - - -.get_feature_info_list_name <- function(data_id, run_id) { - return(paste0(data_id, ".", run_id)) -} - - - -.get_feature_info_list <- function(run) { - - # Find pre-processing control element for the current run - pre_proc_id_list <- .get_preprocessing_iteration_identifiers(run = run) - - # Load feature info list from backend - feature_info_list <- get_feature_info_from_backend( - data_id = pre_proc_id_list$data, - run_id = pre_proc_id_list$run) - - return(feature_info_list) -} - - - .determine_preprocessing_parameters <- function( cl = NULL, data, feature_info_list, settings, message_indent = 0L, - verbose = FALSE) { + verbose = FALSE +) { if (!is(data, "dataObject")) { ..error_reached_unreachable_code( - ".determine_preprocessing_parameters: data is not a dataObject.") + ".determine_preprocessing_parameters: data is not a dataObject." + ) } - if (is_empty(data)) stop("The provided dataset does not contain any samples.") - if (!has_feature_data(data)) stop("The provided dataset does not contain any features.") + if (is_empty(data)) ..error_data_set_is_empty() + if (!has_feature_data(data)) ..error_data_set_has_no_features() # Remove samples with missing outcome data ----------------------------------- - n_samples_current <- data.table::uniqueN( - x = data@data, - by = get_id_columns(id_depth = "sample")) + n_samples_current <- get_n_samples(data) logger_message( paste0("Pre-processing: ", n_samples_current, " samples were initially available."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Remove all samples with missing outcome data data <- filter_missing_outcome(data = data, is_validation = FALSE) - if (is_empty(data)) stop("The provided training dataset lacks outcome data.") - - n_samples_remain <- data.table::uniqueN( - x = data@data, - by = get_id_columns(id_depth = "sample")) + if (is_empty(data)) ..error_data_set_has_no_outcome() + n_samples_remain <- get_n_samples(data) n_samples_removed <- n_samples_current - n_samples_remain logger_message( - paste0("Pre-processing: ", n_samples_removed, - " samples were removed because of missing outcome data. ", - n_samples_remain, " samples remain."), + paste0( + "Pre-processing: ", n_samples_removed, + " samples were removed because of missing outcome data. ", + n_samples_remain, " samples remain." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) #Remove features with a large fraction of missing values --------------------- @@ -328,28 +48,32 @@ determine_preprocessing_parameters <- function( logger_message( paste0("Pre-processing: ", n_features_current, " features were initially available."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Determine the fraction of missing values feature_info_list <- add_missing_value_fractions( cl = cl, feature_info_list = feature_info_list, data = data, - threshold = settings$prep$feature_max_fraction_missing) + threshold = settings$prep$feature_max_fraction_missing + ) # Find features that are not missing too many values. available_features <- get_available_features(feature_info_list = feature_info_list) # Remove features with a high fraction of missing values - data <- filter_features( - data = data, - available_features = available_features) + data <- filter_features(data = data, available_features = available_features) if (!has_feature_data(data)) { - stop(paste0( - "The provided dataset lacks features with sufficient available values. ", - "Please investigate missing values in the dataset or increase the missingness ", - "threshold by increasing the feature_max_fraction_missing configuration parameter.")) + ..error( + paste0( + "The provided dataset lacks features with sufficient available values. ", + "Please investigate missing values in the dataset or increase the missingness ", + "threshold by increasing the feature_max_fraction_missing configuration parameter." + ), + error_class = "dataset_error" + ) } # Message how many features were removed @@ -357,9 +81,11 @@ determine_preprocessing_parameters <- function( paste0( "Pre-processing: ", n_features_current - length(available_features), " features were removed because of a high fraction of missing values. ", - length(available_features), " features remain."), + length(available_features), " features remain." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) n_samples_current <- n_samples_remain @@ -368,27 +94,32 @@ determine_preprocessing_parameters <- function( data <- filter_bad_samples( data = data, - threshold = settings$prep$sample_max_fraction_missing) + threshold = settings$prep$sample_max_fraction_missing + ) if (is_empty(data)) { - stop(paste0( - "The provided dataset lacks samples with sufficient available feature values. ", - "Please investigate missing values in the dataset or increase the missingness ", - "threshold by increasing the sample_max_fraction_missing configuration parameter.")) + ..error( + paste0( + "The provided dataset lacks samples with sufficient available feature values. ", + "Please investigate missing values in the dataset or increase the missingness ", + "threshold by increasing the sample_max_fraction_missing configuration parameter." + ), + error_class = "dataset_error" + ) } - # Message how many subjects were removed - n_samples_remain <- data.table::uniqueN( - x = data@data, - by = get_id_columns(id_depth = "sample")) + # Message how many samples were removed + n_samples_remain <- get_n_samples(data) logger_message( paste0( "Pre-processing: ", n_samples_current - n_samples_remain, " samples were removed because of missing feature data. ", - n_samples_remain, " samples remain."), + n_samples_remain, " samples remain." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) n_features_current <- length(available_features) @@ -399,20 +130,23 @@ determine_preprocessing_parameters <- function( feature_info_list <- find_invariant_features( cl = cl, feature_info_list = feature_info_list, - data = data) + data = data + ) # Find available features. available_features <- get_available_features(feature_info_list = feature_info_list) # Remove invariant features from the data - data <- filter_features( - data = data, - available_features = available_features) + data <- filter_features(data = data, available_features = available_features) if (!has_feature_data(data)) { - stop(paste0( - "Remaining features in the dataset only have a single value for all samples ", - "and cannot be used for training.")) + ..error( + paste0( + "Remaining features in the dataset only have a single value for all samples ", + "and cannot be used for training." + ), + error_class = "dataset_error" + ) } # Message number of features removed by the no-variance filter. @@ -420,29 +154,34 @@ determine_preprocessing_parameters <- function( paste0( "Pre-processing: ", n_features_current - length(available_features), " features were removed due to invariance. ", - length(available_features), " features remain."), + length(available_features), " features remain." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Add feature distribution data ---------------------------------------------- logger_message( paste0("Pre-processing: Adding value distribution statistics to features."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Add feature distribution data feature_info_list <- compute_feature_distribution_data( cl = cl, feature_info_list = feature_info_list, - data = data) + data = data + ) # Transform features --------------------------------------------------------- logger_message( "Pre-processing: Performing transformations to normalise feature value distributions.", indent = message_indent, - verbose = verbose && settings$prep$transform_method != "none") + verbose = verbose && settings$prep$transform_method != "none" + ) # Add skeletons to the feature information list. feature_info_list <- create_transformation_parameter_skeleton( @@ -457,17 +196,20 @@ determine_preprocessing_parameters <- function( cl = cl, feature_info_list = feature_info_list, data = data, - verbose = verbose) + verbose = verbose + ) # Apply transformation. data <- transform_features( data = data, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) logger_message( "Pre-processing: Feature distributions have been transformed for normalisation.", indent = message_indent, - verbose = verbose & settings$prep$transform_method != "none") + verbose = verbose & settings$prep$transform_method != "none" + ) # Remove low-variance features ----------------------------------------------- @@ -479,21 +221,24 @@ determine_preprocessing_parameters <- function( cl = cl, feature_info_list = feature_info_list, data = data, - settings = settings) + settings = settings + ) # Check available features. available_features <- get_available_features(feature_info_list = feature_info_list) # Remove invariant features from the data - data <- filter_features( - data = data, - available_features = available_features) + data <- filter_features(data = data, available_features = available_features) if (!has_feature_data(data)) { - stop(paste0( - "Remaining features in the dataset have a variance that is lower than the threshold ", - "and were therefore all removed. Please investigate your data, or increase the threshold ", - "through the low_var_minimum_variance_threshold configuration parameter.")) + ..error( + paste0( + "Remaining features in the dataset have a variance that is lower than the threshold ", + "and were therefore all removed. Please investigate your data, or increase the threshold ", + "through the low_var_minimum_variance_threshold configuration parameter." + ), + error_class = "dataset_error" + ) } # Message number of features removed by the low-variance filter. @@ -501,9 +246,11 @@ determine_preprocessing_parameters <- function( paste0( "Pre-processing: ", n_features_current - length(available_features), " features were removed due to low variance. ", - length(available_features), " features remain."), + length(available_features), " features remain." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } @@ -512,59 +259,75 @@ determine_preprocessing_parameters <- function( logger_message( "Pre-processing: Extracting normalisation parameters from feature data.", indent = message_indent, - verbose = verbose && settings$prep$normalisation_method != "none") + verbose = verbose && settings$prep$normalisation_method != "none" + ) # Add skeletons to the feature information list. feature_info_list <- create_normalisation_parameter_skeleton( feature_info_list = feature_info_list, - normalisation_method = settings$prep$normalisation_method) + normalisation_method = settings$prep$normalisation_method + ) # Add normalisation parameters to the feature information list. feature_info_list <- add_normalisation_parameters( cl = cl, feature_info_list = feature_info_list, data = data, - verbose = verbose) + verbose = verbose + ) # Apply normalisation to data before clustering data <- normalise_features( data = data, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) logger_message( "Pre-processing: Feature data were normalised.", indent = message_indent, - verbose = verbose && settings$prep$normalisation_method != "none") + verbose = verbose && settings$prep$normalisation_method != "none" + ) # Batch normalise features --------------------------------------------------- logger_message( "Pre-processing: Extracting batch normalisation parameters from feature data.", indent = message_indent, - verbose = verbose && settings$prep$batch_normalisation_method != "none") + verbose = verbose && settings$prep$batch_normalisation_method != "none" + ) + + # Check that assumptions for batch normalisation are fulfilled. + .check_batch_normalisation_assumptions( + data = data, + normalisation_method = settings$prep$batch_normalisation_method + ) # Add batch normalisation skeletons. feature_info_list <- create_batch_normalisation_parameter_skeleton( feature_info_list = feature_info_list, - normalisation_method = settings$prep$batch_normalisation_method) + normalisation_method = settings$prep$batch_normalisation_method + ) # Add batch normalisation parameters to the feature information list. feature_info_list <- add_batch_normalisation_parameters( cl = cl, feature_info_list = feature_info_list, data = data, - verbose = verbose) + verbose = verbose + ) # Batch-normalise feature values data <- batch_normalise_features( data = data, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) logger_message( "Pre-processing: Feature data were batch-normalised.", indent = message_indent, - verbose = verbose && settings$prep$batch_normalisation_method != "none") + verbose = verbose && settings$prep$batch_normalisation_method != "none" + ) # Remove non-robust features ------------------------------------------------- @@ -576,20 +339,23 @@ determine_preprocessing_parameters <- function( cl = cl, feature_info_list = feature_info_list, data = data, - settings = settings) + settings = settings + ) available_features <- get_available_features(feature_info_list = feature_info_list) # Remove non-robust features from the data - data <- filter_features( - data = data, - available_features = available_features) + data <- filter_features(data = data, available_features = available_features) if (!has_feature_data(data)) { - stop(paste0( - "Remaining features in the dataset have a robustness that is lower than the threshold ", - "and were therefore all removed. Please investigate your data, or decrease the threshold ", - "through the robustness_threshold_value configuration parameter.")) + ..error( + paste0( + "Remaining features in the dataset have a robustness that is lower than the threshold ", + "and were therefore all removed. Please investigate your data, or decrease the threshold ", + "through the robustness_threshold_value configuration parameter." + ), + error_class = "dataset_error" + ) } # Message number of features removed by the robustness filter. @@ -597,9 +363,11 @@ determine_preprocessing_parameters <- function( paste0( "Pre-processing: ", n_features_current - length(available_features), " features were removed due to low robustness. ", - length(available_features), " features remain."), + length(available_features), " features remain." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } @@ -612,20 +380,23 @@ determine_preprocessing_parameters <- function( cl = cl, feature_info_list = feature_info_list, data = data, - settings = settings) + settings = settings + ) available_features <- get_available_features(feature_info_list = feature_info_list) # Remove unimportant features from the data - data <- filter_features( - data = data, - available_features = available_features) + data <- filter_features(data = data, available_features = available_features) if (!has_feature_data(data)) { - stop(paste0( - "Remaining features in the dataset have a p-value that is higher than the threshold ", - "and were therefore all removed. Please investigate your data, or increase the threshold ", - "through the univariate_test_threshold configuration parameter.")) + ..error( + paste0( + "Remaining features in the dataset have a p-value that is higher than the threshold ", + "and were therefore all removed. Please investigate your data, or increase the threshold ", + "through the univariate_test_threshold configuration parameter." + ), + error_class = "dataset_error" + ) } # Message number of features removed by the importance filter. @@ -633,9 +404,11 @@ determine_preprocessing_parameters <- function( paste0( "Pre-processing: ", n_features_current - length(available_features), " features were removed due to low importance. ", - length(available_features), " features remain."), + length(available_features), " features remain." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } @@ -643,31 +416,39 @@ determine_preprocessing_parameters <- function( logger_message( "Pre-processing: Adding imputation information to features.", indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Add imputation skeletons. feature_info_list <- create_imputation_parameter_skeleton( feature_info_list = feature_info_list, - imputation_method = settings$prep$imputation_method) + imputation_method = settings$prep$imputation_method + ) # Add imputation info feature_info_list <- add_imputation_info( cl = cl, feature_info_list = feature_info_list, data = data, - verbose = verbose) + verbose = verbose + ) # Impute features with censored data prior to clustering data <- impute_features( data = data, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Cluster features ----------------------------------------------------------- logger_message( "Pre-processing: Starting clustering of redundant features", indent = message_indent, - verbose = verbose && settings$prep$cluster_method != "none") + verbose = verbose && settings$prep$cluster_method != "none" + ) + + # Determine the number of features prior to clustering. + n_features_current <- length(get_available_features(feature_info_list = feature_info_list)) # Add clustering skeletons. feature_info_list <- create_cluster_parameter_skeleton( @@ -677,7 +458,8 @@ determine_preprocessing_parameters <- function( cluster_cut_method = settings$prep$cluster_cut_method, cluster_similarity_threshold = settings$prep$cluster_similarity_threshold, cluster_similarity_metric = settings$prep$cluster_similarity_metric, - cluster_representation_method = settings$prep$cluster_representation_method) + cluster_representation_method = settings$prep$cluster_representation_method + ) # Extract clustering information feature_info_list <- add_cluster_info( @@ -685,31 +467,31 @@ determine_preprocessing_parameters <- function( feature_info_list = feature_info_list, data = data, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) # Build cluster table. cluster_table <- .create_clustering_table(feature_info_list = feature_info_list) - # Determine the number of features prior to clustering. - n_features_current <- nrow(cluster_table) - # Further summarise the clusters by grouping. cluster_table <- cluster_table[, list("cluster_size" = .N), by = "cluster_name"] logger_message( paste0( nrow(cluster_table), - ifelse(nrow(cluster_table) == 1, " feature cluster was", " feature clusteres were"), + ifelse(nrow(cluster_table) == 1L, " feature cluster was", " feature clusters were"), " created from ", n_features_current, - ifelse(n_features_current == 1, " feature. ", " features. "), + ifelse(n_features_current == 1L, " feature. ", " features. "), sum(cluster_table$cluster_size > 1L), - ifelse(sum(cluster_table$cluster_size > 1L) == 1, " cluster contains", " clusters contain"), + ifelse(sum(cluster_table$cluster_size > 1L) == 1L, " cluster contains", " clusters contain"), " more than one feature. The remaining ", sum(cluster_table$cluster_size == 1L), - ifelse(sum(cluster_table$cluster_size == 1L) == 1, " cluster is", " clusters are"), - " singular."), + ifelse(sum(cluster_table$cluster_size == 1L) == 1L, " cluster is", " clusters are"), + " singular." + ), indent = message_indent + 1L, - verbose = verbose && settings$prep$cluster_method != "none") + verbose = verbose && settings$prep$cluster_method != "none" + ) # Add required features feature_info_list <- add_required_features(feature_info_list = feature_info_list) @@ -726,7 +508,8 @@ determine_preprocessing_parameters <- function( combine_feature_info_list <- function( preferred = NULL, custom = NULL, - generic = NULL) { + generic = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table name <- present <- list_name <- complete <- NULL @@ -735,7 +518,8 @@ combine_feature_info_list <- function( feature_names <- unique(c( names(preferred), names(custom), - names(generic))) + names(generic) + )) # Identify which features appear where. data <- mapply( @@ -746,7 +530,8 @@ combine_feature_info_list <- function( "list_name" = x_name, "name" = feature_names, "present" = FALSE, - "complete" = FALSE) + "complete" = FALSE + ) # Mark feature names that are present in the current dataset. data[name %in% names(x), "present" := TRUE] @@ -755,17 +540,20 @@ combine_feature_info_list <- function( data[ present == TRUE, "complete" := feature_info_complete(object = x[[name]]), - by = "name"] + by = "name" + ] return(data) }, x = list( "preferred" = preferred, "custom" = custom, - "generic" = generic), + "generic" = generic + ), x_name = c("preferred", "custom", "generic"), MoreArgs = list("feature_names" = feature_names), - SIMPLIFY = FALSE) + SIMPLIFY = FALSE + ) # Combine list. data <- data.table::rbindlist(data) @@ -778,7 +566,7 @@ combine_feature_info_list <- function( selected_feature_names <- data[list_name == "preferred" & complete == TRUE]$name # Add to feature list and remove from set of features. - if (length(selected_feature_names) > 0) { + if (length(selected_feature_names) > 0L) { new_feature_list <- c(new_feature_list, preferred[selected_feature_names]) feature_names <- setdiff(feature_names, selected_feature_names) } @@ -787,7 +575,7 @@ combine_feature_info_list <- function( selected_feature_names <- data[name %in% feature_names & list_name == "custom" & complete == TRUE, ]$name # Add to feature list and remove from set of features. - if (length(selected_feature_names) > 0) { + if (length(selected_feature_names) > 0L) { new_feature_list <- c(new_feature_list, custom[selected_feature_names]) feature_names <- setdiff(feature_names, selected_feature_names) } @@ -796,7 +584,7 @@ combine_feature_info_list <- function( selected_feature_names <- data[name %in% feature_names & list_name == "preferred" & present == TRUE, ]$name # Add to feature list and remove from set of features. - if (length(selected_feature_names) > 0) { + if (length(selected_feature_names) > 0L) { new_feature_list <- c(new_feature_list, preferred[selected_feature_names]) feature_names <- setdiff(feature_names, selected_feature_names) } @@ -805,7 +593,7 @@ combine_feature_info_list <- function( selected_feature_names <- data[name %in% feature_names & list_name == "custom" & present == TRUE, ]$name # Add to feature list and remove from set of features. - if (length(selected_feature_names) > 0) { + if (length(selected_feature_names) > 0L) { new_feature_list <- c(new_feature_list, custom[selected_feature_names]) feature_names <- setdiff(feature_names, selected_feature_names) } @@ -814,7 +602,7 @@ combine_feature_info_list <- function( selected_feature_names <- data[name %in% feature_names & list_name == "generic" & present == TRUE, ]$name # Add to feature list and remove from set of features. - if (length(selected_feature_names) > 0) { + if (length(selected_feature_names) > 0L) { new_feature_list <- c(new_feature_list, generic[selected_feature_names]) feature_names <- setdiff(feature_names, selected_feature_names) } diff --git a/R/DataProcessing.R b/R/DataProcessing.R index aace1e67..67b9319f 100644 --- a/R/DataProcessing.R +++ b/R/DataProcessing.R @@ -1,13 +1,14 @@ .get_run_list <- function( iteration_list, data_id, - run_id = NULL) { + run_id = NULL +) { # Check if data_id has any length. - if (length(data_id) == 0) return(list()) + if (length(data_id) == 0L) return(list()) # Return an empty list if data_id equals 0. - if (data_id == 0) return(list()) + if (data_id == 0L) return(list()) # Return part of the run list. if (is.null(run_id)) { @@ -25,14 +26,16 @@ iteration_list = NULL, data_id = NULL, run_id = NULL, - train_or_validate) { + train_or_validate +) { # Get run from iter_list if not provided directly. if (is.null(run)) { run <- .get_run_list( iteration_list = iteration_list, data_id = data_id, - run_id = run_id) + run_id = run_id + ) } # Extract training or validation data - note that run$valid_samples can be @@ -70,10 +73,11 @@ # Extract data and run identifiers. return(list( - "data" = run_table$data_id[1], - "run" = run_table$run_id[1], - "perturb_level" = run_table$perturb_level[1], - "perturbation" = run_table$perturbation[1])) + "data" = run_table$data_id[1L], + "run" = run_table$run_id[1L], + "perturb_level" = run_table$perturb_level[1L], + "perturbation" = run_table$perturbation[1L] + )) } @@ -93,10 +97,11 @@ # Extract data and run identifiers. return(list( - "data" = run_table$data_id[1], - "run" = run_table$run_id[1], - "perturb_level" = run_table$perturb_level[1], - "perturbation" = run_table$perturbation[1])) + "data" = run_table$data_id[1L], + "run" = run_table$run_id[1L], + "perturb_level" = run_table$perturb_level[1L], + "perturbation" = run_table$perturbation[1L] + )) } @@ -105,25 +110,25 @@ # Get the main data id for a step in the overall modelling process. # Suppress NOTES due to non-standard evaluation in data.table - feat_sel <- model_building <- external_validation <- NULL + vimp <- train <- external_validation <- NULL # Load experiment data table experiment_table <- project_info$experiment_setup - if (process_step == "fs") { + if (process_step == "vimp") { # Find row on where feature selection takes place and extract the main data # id. - main_data_id <- experiment_table[feat_sel == TRUE, ]$main_data_id[1] + main_data_id <- experiment_table[vimp == TRUE, ]$main_data_id[1L] } else if (process_step %in% c("mb")) { # Find row where model building takes place and extract the main data id. - main_data_id <- experiment_table[model_building == TRUE, ]$main_data_id[1] + main_data_id <- experiment_table[train == TRUE, ]$main_data_id[1L] } else if (process_step == "ev") { # Check if external validation is present; otherwise return an illegal main # data id. if (any(experiment_table$external_validation)) { - main_data_id <- experiment_table[external_validation == TRUE, ]$main_data_id[1] + main_data_id <- experiment_table[external_validation == TRUE, ]$main_data_id[1L] } else { main_data_id <- -1L @@ -132,7 +137,8 @@ } else { ..error_reached_unreachable_code(paste0( ".get_process_step_data_identifier: encountered unknown process step code: ", - process_step)) + process_step + )) } return(main_data_id) diff --git a/R/DataServerBackend.R b/R/DataServerBackend.R index b96510be..6c53fc6c 100644 --- a/R/DataServerBackend.R +++ b/R/DataServerBackend.R @@ -35,17 +35,20 @@ } else { ..error_reached_unreachable_code( - ".get_selected_backend_type: backend_type was not found in familiar_global_env or .GlobalEnv") + ".get_selected_backend_type: backend_type was not found in familiar_global_env or .GlobalEnv" + ) } backend_type <- tryCatch( get("backend_type", envir = data_env), - error = identity) + error = identity + ) if (inherits(backend_type, "error")) { .assign_backend_options_to_global( backend_type = "none", - server_port = NULL) + server_port = NULL + ) backend_type <- "none" } @@ -71,7 +74,8 @@ } else { ..error_reached_unreachable_code( - ".get_backend_server_port: server_port was not found in familiar_global_env or .GlobalEnv") + ".get_backend_server_port: server_port was not found in familiar_global_env or .GlobalEnv" + ) } return(get("server_port", envir = data_env)) @@ -83,18 +87,24 @@ assign( "backend_type", value = backend_type, - envir = familiar_global_env) + envir = familiar_global_env + ) assign( "server_port", value = server_port, - envir = familiar_global_env) + envir = familiar_global_env + ) return(invisible(TRUE)) } -.assign_data_to_backend <- function(data, backend_type = NULL, server_port = NULL) { +.assign_data_to_backend <- function( + data, + backend_type = NULL, + server_port = NULL +) { # Find the server port and backend_type variables if not directly provided. if (is.null(server_port)) server_port <- .get_backend_server_port() @@ -103,14 +113,16 @@ # Check if required packages are installed. require_package( x = .required_packages_backend(backend_type = backend_type), - purpose = paste0("to use the requested backend (", backend_type, ")")) + purpose = paste0("to use the requested backend (", backend_type, ")") + ) if (backend_type %in% c("none")) { # Put master_data in global environment assign( x = "master_data", value = data, - envir = familiar_global_env) + envir = familiar_global_env + ) } else if (backend_type %in% c("socket_server")) { # Start the separate r session thread that will run the socket server. @@ -125,10 +137,12 @@ assign( x = "master_data", value = data, - envir = familiar_global_env) + envir = familiar_global_env + ) }, args = list("data" = data), - package = TRUE) + package = TRUE + ) # Finally, activate the server subroutine. .activate_socket_server_routine(server_port = server_port) @@ -146,7 +160,8 @@ get_data_from_backend <- function( backend_type = NULL, server_port = NULL, sample_identifiers = NULL, - column_names = NULL) { + column_names = NULL +) { # Find the server port and backend_type variables if not directly provided. if (is.null(server_port)) server_port <- .get_backend_server_port() @@ -155,13 +170,15 @@ get_data_from_backend <- function( # Check if required packages are installed. require_package( x = .required_packages_backend(backend_type = backend_type), - purpose = paste0("to use the requested backend (", backend_type, ")")) + purpose = paste0("to use the requested backend (", backend_type, ")") + ) if (backend_type == "none") { # Absence of backend. x <- .get_data_from_backend( sample_identifiers = sample_identifiers, - column_names = column_names) + column_names = column_names + ) } else if (backend_type == "socket_server") { # Socket server backend. @@ -176,11 +193,14 @@ get_data_from_backend <- function( .get_data_from_backend, args = list( "sample_identifiers" = sample_identifiers, - "column_names" = column_names)) + "column_names" = column_names + ) + ) } else { ..error_reached_unreachable_code(paste0( - "get_data_from_backend: encountered unknown type of backend: ", backend_type)) + "get_data_from_backend: encountered unknown type of backend: ", backend_type + )) } return(x) @@ -208,7 +228,8 @@ get_data_from_backend <- function( } else { ..error_reached_unreachable_code( - ".get_data_from_backend: master_data was not found in familiar_global_env or .GlobalEnv") + ".get_data_from_backend: master_data was not found in familiar_global_env or .GlobalEnv" + ) } # Obtain and export views of the master data set to the calling function. @@ -223,12 +244,14 @@ get_data_from_backend <- function( } else if (!is.null(sample_identifiers) && is.null(column_names)) { # Get entire rows from the dataset. x <- data.table::copy(get("master_data", envir = data_env)[ - sample_identifiers, on = .NATURAL]) + sample_identifiers, on = .NATURAL + ]) } else { # Get certain columns and rows from the dataset. x <- data.table::copy(get("master_data", envir = data_env)[ - sample_identifiers, mget(column_names), on = .NATURAL]) + sample_identifiers, mget(column_names), on = .NATURAL + ]) } return(x) @@ -239,7 +262,8 @@ get_data_from_backend <- function( .assign_feature_info_to_backend <- function( feature_info_list, backend_type = NULL, - server_port = NULL) { + server_port = NULL +) { # Find the server port and backend_type variables if not directly provided. if (is.null(server_port)) server_port <- .get_backend_server_port() @@ -248,13 +272,15 @@ get_data_from_backend <- function( # Check if required packages are installed. require_package( x = .required_packages_backend(backend_type = backend_type), - purpose = paste0("to use the requested backend (", backend_type, ")")) + purpose = paste0("to use the requested backend (", backend_type, ")") + ) # Put master_feature_info_list in the familiar global environment. assign( x = "master_feature_info_list", value = feature_info_list, - envir = familiar_global_env) + envir = familiar_global_env + ) if (backend_type %in% c("socket_server")) { # Stop the socket_server subroutine so that we can add or update the list of @@ -266,23 +292,26 @@ get_data_from_backend <- function( # Assign the list of feature information to the socket server process so # that its accessible later. - socket_server_process$run(function(feature_info_list) { - # Assign locally. - assign( - x = "master_feature_info_list", - value = feature_info_list, - envir = familiar_global_env) - - }, - args = list("feature_info_list" = feature_info_list), - package = TRUE) + socket_server_process$run( + function(feature_info_list) { + # Assign locally. + assign( + x = "master_feature_info_list", + value = feature_info_list, + envir = familiar_global_env + ) + }, + args = list("feature_info_list" = feature_info_list), + package = TRUE + ) # Reactivate the server subroutine. .activate_socket_server_routine(server_port = server_port) } else if (backend_type != "none") { ..error_reached_unreachable_code( - ".assign_feature_info_to_backend: unknown backend encountered") + ".assign_feature_info_to_backend: unknown backend encountered" + ) } } @@ -291,7 +320,8 @@ get_feature_info_from_backend <- function( backend_type = NULL, server_port = NULL, data_id = NULL, - run_id = NULL) { + run_id = NULL +) { # Find the server port and backend_type variables if not directly provided. if (is.null(server_port)) server_port <- .get_backend_server_port() @@ -300,7 +330,8 @@ get_feature_info_from_backend <- function( # Check if required packages are installed. require_package( x = .required_packages_backend(backend_type = backend_type), - purpose = paste0("to use the requested backend (", backend_type, ")")) + purpose = paste0("to use the requested backend (", backend_type, ")") + ) if (backend_type == "none") { # Absence of backend. @@ -320,11 +351,14 @@ get_feature_info_from_backend <- function( FUN = .get_feature_info_from_backend, args = list( "data_id" = data_id, - "run_id" = run_id)) + "run_id" = run_id + ) + ) } else { ..error_reached_unreachable_code(paste0( - "get_feature_info_from_backend: encountered unknown type of backend: ", backend_type)) + "get_feature_info_from_backend: encountered unknown type of backend: ", backend_type + )) } return(x) @@ -351,7 +385,8 @@ get_feature_info_from_backend <- function( } else { ..error_reached_unreachable_code(paste0( ".get_feature_info_from_backend: master_feature_info_list was not found ", - "in familiar_global_env or .GlobalEnv.")) + "in familiar_global_env or .GlobalEnv." + )) } # Now read the requested element. @@ -366,13 +401,15 @@ get_feature_info_from_backend <- function( } else if (!is.null(data_id) && !is.null(run_id)) { # Retrieve run-specific feature information. x <- get("master_feature_info_list", envir = data_env)[[ - .get_feature_info_list_name(data_id = data_id, run_id = run_id)]] + paste0(data_id, ".", run_id) + ]] } else { # data_id and run_id are either both provided, or both NULL. ..error_reached_unreachable_code(paste0( ".get_feature_info_from_backend: one of data_id and run_id is NULL ", - "instead of both NULL or both not NULL.")) + "instead of both NULL or both not NULL." + )) } # The feature info list should not be empty. @@ -380,7 +417,8 @@ get_feature_info_from_backend <- function( ..error_reached_unreachable_code(paste0( ".get_feature_info_from_backend: the requested feature information is empty. ", "data_id = ", data_id, - "; run_id = ", run_id)) + "; run_id = ", run_id + )) } return(x) @@ -410,7 +448,8 @@ start_socket_server_process <- function(server_port = NULL) { # Check if required packages are installed. require_package( x = .required_packages_backend(backend_type = "socket_server"), - purpose = paste0("to use the requested backend (socket_server)")) + purpose = paste0("to use the requested backend (socket_server)") + ) # Check if the process is already running. if (!.is_socket_server_process_started()) { @@ -421,7 +460,6 @@ start_socket_server_process <- function(server_port = NULL) { # Assign initial data to the socket_server_process$run( function(server_port) { - # Load the familiar package locally. library(familiar) @@ -429,17 +467,19 @@ start_socket_server_process <- function(server_port = NULL) { assign( x = "server_port", value = server_port, - envir = familiar_global_env) - + envir = familiar_global_env + ) }, args = list("server_port" = server_port), - package = TRUE) + package = TRUE + ) # Export socket_server_process to the familiar global environment. assign( "socket_server_process", socket_server_process, - envir = familiar_global_env) + envir = familiar_global_env + ) } return(invisible(TRUE)) @@ -452,9 +492,10 @@ start_socket_server_process <- function(server_port = NULL) { # socket server process thread. This object is normally stored in the familiar # global environment. if (!exists("socket_server_process", where = familiar_global_env)) { - stop(..error_reached_unreachable_code(paste0( + ..error_reached_unreachable_code(paste0( ".get_socket_server_process_handle: socket_server_process ", - "does not exist in familiar_global_env"))) + "does not exist in familiar_global_env" + )) } return(get("socket_server_process", envir = familiar_global_env)) @@ -484,16 +525,18 @@ start_socket_server_process <- function(server_port = NULL) { # Check whether the socket server process is running in a separate thread. if (!socket_server_process$is_alive()) { - stop(..error_reached_unreachable_code(paste0( + ..error_reached_unreachable_code(paste0( ".activate_socket_server: the socket_server_process that hosts the ", - "socket_server routine is not active."))) + "socket_server routine is not active." + )) } # Check if the socket_server_process is idle. if (!socket_server_process$get_state() == "idle") { - stop(..error_reached_unreachable_code(paste0( + ..error_reached_unreachable_code(paste0( ".activate_socket_server: the socket_server_process that hosts the ", - "socket_server routine is busy."))) + "socket_server routine is busy." + )) } # Find the server port if not directly provided. @@ -503,7 +546,8 @@ start_socket_server_process <- function(server_port = NULL) { socket_server_process$call( socket_server, args = list("port" = server_port), - package = TRUE) + package = TRUE + ) return() } @@ -538,7 +582,7 @@ start_socket_server_process <- function(server_port = NULL) { # The process should be responsive within a few milliseconds after sending # the command to stop the subroutine. We leave the process 5 seconds to # respond. - process_ready <- socket_server_process$poll_process(5000) + process_ready <- socket_server_process$poll_process(5000.0) # Read from the socket_server_process to free up the process again, # thereby finalising the shutdown of the socket_server subroutine and @@ -561,7 +605,8 @@ shutdown_backend_server <- function(backend_type = NULL, server_port = NULL) { # Check if required packages are installed. require_package( x = .required_packages_backend(backend_type = backend_type), - purpose = paste0("to use the requested backend (", backend_type, ")")) + purpose = paste0("to use the requested backend (", backend_type, ")") + ) if (backend_type %in% c("socket_server")) { diff --git a/R/ErrorMessages.R b/R/ErrorMessages.R index aaff2a70..26d71c02 100644 --- a/R/ErrorMessages.R +++ b/R/ErrorMessages.R @@ -1,29 +1,141 @@ -..warning_missing_cohorts <- function(x) { - logger_warning(paste0( +..warning <- function( + ..., + warning_class = NULL, + call = rlang::caller_env() +) { + # Generic error function. + message_string <- paste0(list(...), collapse = "") + rlang::warn( + message = message_string, + class = union("familiar_warning", warning_class), + call = call + ) +} + + +..warning_missing_cohorts <- function(x, call = rlang::caller_env()) { + message_string <- paste0( "Creating iterations: ", - ifelse(length(x) > 1, "Cohorts ", "Cohort "), + ifelse(length(x) > 1L, "Cohorts ", "Cohort "), paste_s(x), - ifelse(length(x) > 1, " were", " was"), - " not found in the data table.")) + ifelse(length(x) > 1L, " were", " was"), + " not found in the data table." + ) + + logger_warning(message_string, call = call) + + return(invisible(TRUE)) +} + + + +..warning_no_comparison_between_models <- function( + call = rlang::caller_env() +) { + logger_warning( + paste0( + "Cannot create plots to compare directly between models. ", + "Please use the hybrid or ensemble detail levels." + ), + call = call + ) + + return(invisible(TRUE)) } -..warning_no_comparison_between_models <- function() { - logger_warning(paste0( - "Cannot create plots to compare directly between models. ", - "Please use the hybrid or ensemble detail levels.")) +..warning_prediction_table_lacks_reference <- function( + data_element_description, + call = rlang::caller_env() +) { + message_string <- paste0( + "Unable to compute ", data_element_description, " using prediction tables as reference data are missing." + ) + + logger_warning( + warn_str = message_string, + warn_class = "prediction_table_no_data_extraction_warning", + call = call + ) + + return(invisible(TRUE)) +} + + + +..warning_no_data_extraction_from_prediction_table <- function( + data_element_description, + call = rlang::caller_env() +) { + message_string <- paste0( + "Unable to compute ", data_element_description, " using prediction tables." + ) + + logger_warning( + warn_str = message_string, + warn_class = "prediction_table_no_data_extraction_warning", + call = call + ) + + return(invisible(TRUE)) +} + + + +..warning_package_not_installed <- function( + x, + purpose = NULL, + call = rlang::caller_env() +) { + + # Only unique packages. + x <- unique(x) + + # Basic error message. + message_string <- ..message_missing_package(x = x, purpose = purpose) + + # Instructions for CRAN packages. + message_string <- c( + message_string, + ..message_install_from_cran(x = x) + ) + + # Instructions for Bioconductor packages. + message_string <- c( + message_string, + ..message_install_from_bioconductor(x = x) + ) + + rlang::warn( + message = paste0(message_string, collapse = ""), + class = c("familiar_warning", "package_missing"), + call = rlang::caller_env() + ) + + return(invisible(TRUE)) } -..deprecation_count <- function() { +..deprecation_count <- function(as_error = FALSE) { + + message_string <- "The \"count\" outcome type has been deprecated in familiar version 2.0.0." + + if (as_error) { + rlang::abort( + message = message_string, + class = c("familiar_error", "deprecation_error") + ) + } + if (!.is_testing()) { rlang::warn( - message = "The \"count\" outcome type will be deprecated in familiar version 2.0.0.", - class = "deprecation_warning", + message = message_string, + class = c("familiar_warning", "deprecation_warning"), .frequency = "once", - .frequency_id = "deprecation_warning_count") + .frequency_id = "deprecation_warning_count" + ) } } @@ -32,10 +144,11 @@ ..deprecation_vgam <- function() { if (!.is_testing()) { rlang::warn( - message = "The use of VGAM for multinomial logistic models will be deprecated in familiar version 2.0.0.", - class = "deprecation_warning", + message = "The use of VGAM for multinomial logistic models has been deprecated since familiar version 2.0.0.", + class = c("familiar_warning", "deprecation_warning"), .frequency = "once", - .frequency_id = "deprecation_warning_vgam") + .frequency_id = "deprecation_warning_vgam" + ) } } @@ -44,10 +157,11 @@ ..deprecation_qvalue <- function() { if (!.is_testing()) { rlang::warn( - message = "The use of qvalue for computing q-values will be deprecated in familiar version 2.0.0.", - class = "deprecation_warning", + message = "The qvalue package for computing q-values has been deprecated since familiar version 2.0.0.", + class = c("familiar_warning", "deprecation_warning"), .frequency = "once", - .frequency_id = "deprecation_warning_qvalue") + .frequency_id = "deprecation_warning_qvalue" + ) } } @@ -56,73 +170,208 @@ ..deprecation_mboost <- function() { if (!.is_testing()) { rlang::warn( - message = "The use of mboost for gradient boosted models will be deprecated in familiar version 2.0.0.", - class = "deprecation_warning", + message = "The mboost package for gradient boosted models has been deprecated since familiar version 2.0.0.", + class = c("familiar_warning", "deprecation_warning"), + .frequency = "once", + .frequency_id = "deprecation_warning_mboost" + ) + } +} + + + +..deprecation_rfsrc_variable_hunting <- function(as_error = FALSE) { + + message_string <- paste0( + "The variable hunting feature selection method of randomForestSRC has been ", + "deprecated in familiar version 2.0.0 due to stability issues." + ) + + if (as_error) { + rlang::abort( + message = message_string, + class = c("familiar_error", "deprecation_error") + ) + } + + if (!.is_testing()) { + rlang::warn( + message = message_string, + class = c("familiar_warning", "deprecation_warning"), + .frequency = "once", + .frequency_id = "deprecation_warning_rfsrc_variable_hunting" + ) + } +} + + + +..deprecation_rfsrc_minimum_depth <- function(as_error = FALSE) { + message_string <- paste0( + "The minimum depth feature selection method of randomForestSRC has been ", + "deprecated in familiar version 2.0.0 due removal in randomForestSRC version ", + "3.4.0." + ) + + if (as_error) { + rlang::abort( + message = message_string, + class = c("familiar_error", "deprecation_error") + ) + } + + if (!.is_testing()) { + rlang::warn( + message = message_string, + class = c("familiar_warning", "deprecation_warning"), .frequency = "once", - .frequency_id = "deprecation_warning_mboost") + .frequency_id = "deprecation_warning_rfsrc_minimum_depth" + ) } + +} + + + +..error <- function( + ..., + error_class = NULL, + call = rlang::caller_env() +) { + # Generic error function. + message_string <- paste0(list(...), collapse = "") + rlang::abort( + message = message_string, + class = union("familiar_error", error_class), + call = call + ) } -..error_no_predictions_possible <- function(outcome_type, prediction_type) { - stop(paste0( +..error_no_predictions_possible <- function( + object, + prediction_type, + call = rlang::caller_env() +) { + message_string <- paste0( "Predictions of the ", prediction_type, " type are not possible ", - "using models for ", outcome_type, " outcomes.")) + "using the ", object@learner, " model (class: ", class(object)[1L], + ") for ", object@outcome_type, " outcomes." + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "prediction_type_error"), + call = call + ) } -..error_no_known_outcome_type <- function(outcome_type) { - stop(paste0( +..error_no_known_outcome_type <- function(outcome_type, call = rlang::caller_env()) { + message_string <- paste0( "Outcome type was not recognised. Found: ", outcome_type, ". ", - "One of binomial, multinomial, continuous, count, or ", - "survival was expected.")) + "One of binomial, multinomial, continuous, or survival was expected." + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "outcome_type_error"), + call = call + ) } -..error_outcome_type_not_implemented <- function(outcome_type) { - stop(paste0( - outcome_type, " is currently not supported, but scheduled for future implementation.")) +..error_outcome_type_not_implemented <- function(outcome_type, call = rlang::caller_env()) { + message_string <- paste0( + outcome_type, " is currently not supported, but scheduled for future implementation." + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "outcome_type_error"), + call = call + ) } -..error_data_set_is_empty <- function() { - stop("The provided data set does not contain any samples.") +..error_data_set_is_empty <- function(call = rlang::caller_env()) { + rlang::abort( + message = "The provided dataset does not contain any samples.", + class = c("familiar_error", "dataset_error"), + call = call + ) } -..error_data_set_has_no_features <- function() { - stop("The provided data has no associated feature data.") +..error_data_set_has_no_features <- function(call = rlang::caller_env()) { + rlang::abort( + message = "The provided dataset has no associated feature data.", + class = c("familiar_error", "dataset_error"), + call = call + ) } -..error_input_missing_without_default <- function(var_name, allow_config = FALSE) { - stop(paste0( +..error_data_set_has_no_outcome <- function(call = rlang::caller_env()) { + rlang::abort( + message = "The provided dataset lacks outcome data.", + class = c("familiar_error", "dataset_error"), + call = call + ) +} + + +..error_input_missing_without_default <- function( + var_name, + allow_config = FALSE, + call = rlang::caller_env() +) { + message_string <- paste0( var_name, " ", ifelse(allow_config, "tag/argument", "argument"), " is missing ", "and does not have a default setting. Please provide the ", var_name, - ifelse(allow_config, " tag/argument.", " argument."))) + ifelse(allow_config, " tag/argument.", " argument.") + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } -..error_input_not_unique <- function(x, var_name, allow_config = FALSE) { +..error_input_not_unique <- function( + x, + var_name, + allow_config = FALSE, + call = rlang::caller_env() +) { # Suppress NOTES due to non-standard evaluation in data.table n <- NULL # Identify duplicate values test_table <- data.table::data.table("value" = x)[, list("n" = .N), by = "value"] - dupl_value <- test_table[n > 1]$value + dupl_value <- test_table[n > 1L]$value - stop(paste0( + message_string <- paste0( var_name, " ", ifelse(allow_config, "tag/argument", "argument"), - " has ", ifelse(length(dupl_value) > 1, "a duplicate value: ", "multiple duplicate values: "), - paste_s(dupl_value))) + " has ", ifelse(length(dupl_value) > 1L, "a duplicate value: ", "multiple duplicate values: "), + paste_s(dupl_value) + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } @@ -132,13 +381,22 @@ to_type, var_name, req_length = 1L, - allow_more = FALSE) { + allow_more = FALSE, + call = rlang::caller_env() +) { - stop(paste0( + message_string <- paste0( "Conversion of input for ", var_name, " argument to the desired ", to_type, " class failed. ", "Please provide ", req_length, ifelse(allow_more, " or more ", " "), - ifelse(req_length != 1 || allow_more, "input values ", "input value "), - "of the correct type. Found: ", paste_s(x))) + ifelse(req_length != 1L || allow_more, "input values ", "input value "), + "of the correct type. Found: ", paste_s(x) + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } @@ -147,16 +405,18 @@ x, var_name, req_length = 1L, - allow_more = FALSE) { + allow_more = FALSE, + call = rlang::caller_env() +) { # Handle req_length being a vector with two values. if (length(req_length) == 2L) { - if (!is.finite(req_length[2])) { - req_length <- req_length[1] + if (!is.finite(req_length[2L])) { + req_length <- req_length[1L] allow_more <- TRUE - } else if (diff(req_length) == 0) { - req_length <- req_length[1] + } else if (diff(req_length) == 0L) { + req_length <- req_length[1L] allow_more <- FALSE } } @@ -164,17 +424,27 @@ if (length(req_length) == 1L) { # The req_length argument specifies the exact number or the minimum number # of values. - stop(paste0( - "The ", var_name, " argument requires ", ifelse(allow_more, "at least ", "exactly "), req_length, + message_string <- paste0( + "The ", var_name, " argument requires ", + ifelse(allow_more, "at least ", "exactly "), req_length, ifelse(req_length == 1L, " value", " values"), ". ", - length(x), ifelse(length(x) == 1L, " value was", " values were"), " found.")) + length(x), ifelse(length(x) == 1L, " value was", " values were"), " found." + ) } else { # The req_length argument specifies a range for the number of values. - stop(paste0( - "The ", var_name, " argument requires between ", req_length[1], " and ", - req_length[2], " values. ", ifelse(length(x) == 1L, " value was", " values were"), " found.")) + message_string <- paste0( + "The ", var_name, " argument requires between ", + req_length[1L], " and ", req_length[2L], " values. ", + ifelse(length(x) == 1L, " value was", " values were"), " found." + ) } + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } @@ -183,16 +453,18 @@ x, var_name, req_length = 1L, - allow_fewer = FALSE) { + allow_fewer = FALSE, + call = rlang::caller_env() +) { # Handle req_length being a vector with two values. if (length(req_length) == 2L) { - if (!is.finite(req_length[1])) { - req_length <- req_length[2] + if (!is.finite(req_length[1L])) { + req_length <- req_length[2L] allow_fewer <- TRUE - } else if (diff(req_length) == 0) { - req_length <- req_length[2] + } else if (diff(req_length) == 0L) { + req_length <- req_length[2L] allow_fewer <- FALSE } } @@ -200,48 +472,74 @@ if (length(req_length) == 1L) { # The req_length argument specifies the exact number or the maximum number # of values. - stop(paste0( - "The ", var_name, " argument requires ", ifelse(allow_fewer, "at most ", "exactly "), req_length, + message_string <- paste0( + "The ", var_name, " argument requires ", + ifelse(allow_fewer, "at most ", "exactly "), req_length, ifelse(req_length == 1L, " value", " values"), ". ", - length(x), ifelse(length(x) == 1L, " value was", " values were"), " found.")) + length(x), ifelse(length(x) == 1L, " value was", " values were"), " found." + ) } else { - - stop(paste0( - "The ", var_name, " argument requires between ", req_length[1], " and ", req_length[2], " values. ", - ifelse(length(x) == 1L, " value was", " values were"), " found.")) + message_string <- paste0( + "The ", var_name, " argument requires between ", + req_length[1L], " and ", req_length[2L], " values. ", + ifelse(length(x) == 1L, " value was", " values were"), " found." + ) } + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } -..error_value_outside_allowed_range <- function(x, var_name, range) { +..error_value_outside_allowed_range <- function( + x, + var_name, + range, + call = rlang::caller_env() +) { # Determine the string for the allowed value. - if (is.infinite(range[1]) && is.infinite(range[2])) { + if (is.infinite(range[1L]) && is.infinite(range[2L])) { allowed_value_text <- "be any real number" - } else if (is.infinite(range[1])) { - allowed_value_text <- paste("have a value of", range[2], "or less") + } else if (is.infinite(range[1L])) { + allowed_value_text <- paste("have a value of", range[2L], "or less") - } else if (is.infinite(range[2])) { - allowed_value_text <- paste("have a value of", range[1], "or more") + } else if (is.infinite(range[2L])) { + allowed_value_text <- paste("have a value of", range[1L], "or more") - } else if (range[1] - range[2] == 0.0) { - allowed_value_text <- paste("be exactly", range[1]) + } else if (range[1L] - range[2L] == 0.0) { + allowed_value_text <- paste("be exactly", range[1L]) } else { - allowed_value_text <- paste("have a value between", range[1], "and", range[2]) + allowed_value_text <- paste("have a value between", range[1L], "and", range[2L]) } - stop(paste0( + message_string <- paste0( var_name, " is expected to ", allowed_value_text, - ". Found: ", paste_s(x))) + ". Found: ", paste_s(x) + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } -..error_value_not_allowed <- function(x, var_name, values) { +..error_value_not_allowed <- function( + x, + var_name, + values, + call = rlang::caller_env() +) { # Replace NULL in x by "NULL" x[is.null(x)] <- "NULL" @@ -252,39 +550,103 @@ # Identify those values that are not allowed forbidden_values <- setdiff(x, values) - stop(paste0( + message_string <- paste0( var_name, " expects one of ", paste_s(values), " as input. ", - "Found the following unknown values: ", paste_s(forbidden_values))) + "Found the following unknown values: ", paste_s(forbidden_values) + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } -..error_type_not_valid <- function(x, var_name, valid_type) { - stop(paste0( +..error_type_not_valid <- function( + x, + var_name, + valid_type, + call = rlang::caller_env() +) { + + message_string <- paste0( var_name, " has type ", paste_s(class(x)), - " whereas ", paste_s(valid_type), " was expected.")) + " whereas ", paste_s(valid_type), " was expected." + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } -..error_ensemble_models_not_loaded <- function() { - stop(paste0( - "familiarModel objects were not loaded and attached the familiarEnsemble. ", - "Please use the load_models method to load the models.")) +..error_value_shared_between_variables <- function( + x, + y, + var_name_x, + var_name_y, + call = rlang::caller_env() +) { + + # Determine overlap + overlap <- intersect(x, y) + + message_string <- paste0( + ifelse(length(overlap) > 1L, "Multiple values were", "One value was"), + " shared between ", var_name_x, " and ", var_name_y, ": ", paste_s(overlap), + ". No overlap is allowed." + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "input_argument_error"), + call = call + ) } -..error_reached_unreachable_code <- function(err_code = "") { - stop(paste0( +..error_reached_unreachable_code <- function(..., call = rlang::caller_env()) { + message_string <- paste0( "This error should not occur, as this code should not be reachable by design. ", "Contact the package maintainer if you see this error.\n\t", - err_code)) + paste0(list(...), collapse = "") + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "developer_error"), + call = call + ) +} + + + +..error_ensemble_models_not_loaded <- function(call = rlang::caller_env()) { + message_string <- paste0( + "familiarModel objects were not loaded and attached the familiarEnsemble. ", + "Please use the load_models method to load the models." + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "object_load_error"), + call = call + ) } -..error_cannot_convert_to_familiar_object <- function(object, expected_class) { +..error_cannot_convert_to_familiar_object <- function( + object, + expected_class, + call = rlang::caller_env() +) { # Determine what classes are allowed as object if (expected_class == "familiarModel") { @@ -300,70 +662,107 @@ allowed_class <- c("familiarModel", "familiarEnsemble", "familiarData", "familiarCollection") } - stop(paste0( + message_string <- paste0( "The provided object cannot be converted from ", class(object), " to ", expected_class, ". ", - "The object should have one of the following classes, or inherit it: ", paste_s(allowed_class))) + "The object should have one of the following classes, or inherit it: ", paste_s(allowed_class) + ) + + rlang::abort( + message = message_string, + class = c("familiar_error", "object_conversion_error"), + call = call + ) } -..error_value_shared_between_variables <- function(x, y, var_name_x, var_name_y) { - - # Determine overlap - overlap <- intersect(x, y) +..error_data_not_prediction_table <- function( + x, + expected_class, + call = rlang::caller_env() +) { + message_string <- paste0( + "A prediction table object of class ", expected_class, + " was expected, but ", class(x)[1L], " was found." + ) - stop( - paste0(ifelse(length(overlap) > 1, "Multiple values were", "One value was")), - " shared between ", var_name_x, " and ", var_name_y, ": ", paste_s(overlap), - ". No overlap is allowed.") + rlang::abort( + message = message_string, + class = c("familiar_error", "incorrect_prediction_table"), + call = call + ) } -..warning_package_not_installed <- function(x, purpose = NULL) { +..error_package_not_installed <- function( + x, + purpose = NULL, + call = rlang::caller_env() +) { # Only unique packages. x <- unique(x) - + # Basic error message. err_message <- ..message_missing_package(x = x, purpose = purpose) # Instructions for CRAN packages. - err_message <- c( - err_message, - ..message_install_from_cran(x = x)) + err_message <- c(err_message, ..message_install_from_cran(x = x)) # Instructions for Bioconductor packages. - err_message <- c( - err_message, - ..message_install_from_bioconductor(x = x)) - - warning(paste0(err_message, collapse = "")) + err_message <- c(err_message, ..message_install_from_bioconductor(x = x)) - return(invisible(TRUE)) + rlang::abort( + message = paste0(err_message, collapse = ""), + class = c("familiar_error", "package_missing"), + call = call + ) } -..error_package_not_installed <- function(x, purpose = NULL) { +..error_cannot_update_object <- function( + object, + fam_version, + call = rlang::caller_env() +) { + # Version of the object. + object_fam_version <- tail(object@familiar_version, n = 1L) - # Only unique packages. - x <- unique(x) - - # Basic error message. - err_message <- ..message_missing_package(x = x, purpose = purpose) + err_message <- paste0( + "Familiar version ", fam_version, " introduces breaking changes to ", + paste_s(class(object)), " objects. ", + "To use this object, you need to install version familiar ", + object_fam_version, ". ", + "This can be achieved using devtools::install_version('familiar', version = '", + object_fam_version, "') or remotes::install_version('familiar', version = '", + object_fam_version, "')." + ) - # Instructions for CRAN packages. - err_message <- c( + ..error( err_message, - ..message_install_from_cran(x = x)) + error_class = "object_update_error", + call = call + ) +} + + + +..error_updated_object_invalid <- function( + object, + call = rlang::caller_env() +) { + err_message <- paste0( + "The provided ", paste_s(class(object)), " failed consistency checks after updating. ", + "Please contact the developers." + ) - # Instructions for Bioconductor packages. - err_message <- c( + ..error( err_message, - ..message_install_from_bioconductor(x = x)) - - stop(paste0(err_message, collapse = "")) + error_class = c("object_update_error", "developer_error"), + call = call + ) } diff --git a/R/Evaluation.R b/R/Evaluation.R deleted file mode 100644 index d524f517..00000000 --- a/R/Evaluation.R +++ /dev/null @@ -1,755 +0,0 @@ -run_evaluation <- function( - cl, - project_list, - settings, - file_paths, - message_indent = 0L, - verbose = TRUE) { - # performs evaluation of the data - - if (settings$eval$do_parallel == "FALSE") cl <- NULL - - # Suppress verbosity if no data elements are extracted. - if (length(settings$eval$evaluation_data_elements) == 0) verbose <- FALSE - - # Extract data from ensembles - data_set_list <- .prepare_familiar_data_sets( - cl = cl, - only_pooling = settings$eval$pool_only, - message_indent = message_indent, - verbose = verbose) - - # Form collections (all individual ensembles with train and validation data - # combined) - collection_list <- .prepare_familiar_collections(data_set_list = data_set_list) - - # Create and save collections and export data. For temporary files we do not - # export the plots and tables, as that does not make sense. - if (!file_paths$is_temporary) { - lapply( - collection_list, - .process_collections, - file_paths = file_paths, - message_indent = message_indent, - verbose = verbose) - - } else { - lapply( - collection_list, - .create_familiar_collection_runtime, - file_paths = file_paths, - message_indent = message_indent, - verbose = verbose) - } -} - - - -#' @title Prepare familiarData objects for evaluation at runtime. -#' -#' @description Information concerning models, features and the experiment is -#' processed and stored in familiarData objects. Information can be extracted -#' from these objects as csv files, or by plotting, or multiple objects can be -#' combined into familiarCollection objects, which allows aggregated exports. -#' -#' @details This function generates the names of familiarData object files, and -#' their corresponding generating ensemble, which allows the familiarData -#' objects to be created. -#' -#' @param cl Cluster for parallel processing. -#' @param only_pooling Flag that, if set, forces evaluation of only the -#' top-level data, and not e.g. ensembles. -#' @param message_indent indent that messages should have. -#' @param verbose Sets verbosity -#' -#' @return A data.table with created links to created data objects. -#' -#' @keywords internal -#' @md -.prepare_familiar_data_sets <- function( - cl = NULL, - only_pooling = FALSE, - message_indent = 0L, - verbose = FALSE) { - - # Suppress NOTES due to non-standard evaluation in data.table - fam_ensemble_exists <- fam_ensemble <- fam_data_exists <- fam_data <- NULL - learner <- fs_method <- NULL - data_dir_path <- model_dir_path <- NULL - model_data_id <- model_run_id <- pool_data_id <- pool_run_id <- NULL - ensemble_data_id <- ensemble_run_id <- is_ensemble <- is_validation <- NULL - - # Determine the models that should be generated. - # Load project list, file_paths and settings if required. - settings <- get_settings() - file_paths <- get_file_paths() - project_list <- get_project_list() - - # Get project_id - project_id <- project_list$project_id - - # Check which data object is required for performing model building - mb_data_id <- .get_process_step_data_identifier( - project_info = project_list, - process_step = "mb") - - # Get runs - run_list <- .get_run_list( - iteration_list = project_list$iter_list, - data_id = mb_data_id) - - # Get list of data collection pools - data_sets <- data.table::rbindlist( - .get_ensemble_structure_info( - run_list = run_list, - project_list = project_list, - only_pooling = only_pooling), - use.names = TRUE) - - # Identify combinations of feature selection methods and learners - run_methods <- data.table::rbindlist( - get_fs_learner_combinations(settings = settings), - use.names = TRUE) - - # Perform a cartesian join of the data sets and the run methods. - data_set_list <- run_methods[, as.list(data_sets), by = c("fs_method", "learner")] - - # Add model file names - data_set_list[, "fam_model" := get_object_file_name( - learner = learner, - fs_method = fs_method, - project_id = project_id, - data_id = model_data_id, - run_id = model_run_id, - object_type = "familiarModel")] - - # Add paths to model directories - data_set_list[, "model_dir_path" := get_object_dir_path( - dir_path = file_paths$mb_dir, - object_type = "familiarModel", - learner = learner, - fs_method = fs_method), - by = c("learner", "fs_method")] - - # Add paths to data - data_set_list[, "data_dir_path" := get_object_dir_path( - dir_path = file_paths$fam_data_dir, - object_type = "familiarData")] - - # Set paths to familiar ensembles - data_set_list[, "fam_ensemble" := get_object_file_name( - dir_path = model_dir_path, - learner = learner, - fs_method = fs_method, - project_id = project_id, - data_id = ensemble_data_id, - run_id = ensemble_run_id, - is_ensemble = TRUE, - object_type = "familiarEnsemble"), - by = c("model_dir_path", "fs_method", "learner", "ensemble_data_id", "ensemble_run_id")] - - # Add data file directory + names - data_set_list[, "fam_data" := get_object_file_name( - dir_path = data_dir_path, - learner = learner, - fs_method = fs_method, - project_id = project_id, - data_id = ensemble_data_id, - run_id = ensemble_run_id, - pool_data_id = pool_data_id, - pool_run_id = pool_run_id, - is_ensemble = is_ensemble, - is_validation = is_validation, - object_type = "familiarData")] - - # Remove model_dir_path and data_dir_path - data_set_list[, ":="( - "model_dir_path" = NULL, - "data_dir_path" = NULL)] - - # Check which ensembles exist - data_set_list[, "fam_ensemble_exists" := file.exists(fam_ensemble)] - - # Check which data objects already exist - data_set_list[, "fam_data_exists" := file.exists(fam_data)] - - # Find any new ensembles that may have to be created - new_ensemble_table <- data.table::copy(data_set_list[ - fam_ensemble_exists == FALSE, - mget(c("ensemble_data_id", "ensemble_run_id", "learner", "fs_method", "fam_model", "fam_ensemble"))]) - - # Determine if there any ensembles that need to be processed. - if (!is_empty(new_ensemble_table)) { - - # Select unique entries. - new_ensemble_table <- unique(new_ensemble_table) - - logger_message( - "\nEvaluation: Creating ensemble models from individual models.", - indent = message_indent, - verbose = verbose) - - # Create familiarEnsemble objects - fam_lapply_lb( - cl = cl, - assign = NULL, - X = split(new_ensemble_table, by = "fam_ensemble"), - FUN = .create_familiar_ensemble_runtime, - progress_bar = verbose, - dir_path = file_paths$mb_dir) - } - - # Re-check which ensembles exist - data_set_list[, "fam_ensemble_exists" := file.exists(fam_ensemble)] - - if (!all(data_set_list$fam_ensemble_exists)) { - ..error_reached_unreachable_code( - ".prepare_familiar_data_sets: not all familiarEnsemble objects were created.") - } - - # Find any new familiarData objects that may have to be created. - new_data_table <- data.table::copy(data_set_list[ - fam_data_exists == FALSE, - mget(c("fam_ensemble", "fam_data", "data_perturb_level", - "pool_data_id", "pool_run_id", "pool_perturb_level", "is_validation"))]) - - if (!is_empty(new_data_table)) { - - # Select unique entries. - new_data_table <- unique(new_data_table) - - # Add iteration_id and total number of iterations - new_data_table[, ":="("iteration_id" = .I, "n_sets" = nrow(new_data_table))] - - logger_message( - "\nEvaluation: Processing data to create familiarData objects.", - indent = message_indent, - verbose = verbose) - - # Set outer vs. inner loop parallelisation. - if (settings$eval$do_parallel %in% c("TRUE", "inner")) { - cl_inner <- cl - cl_outer <- NULL - - } else if (settings$eval$do_parallel %in% c("outer")) { - cl_inner <- NULL - cl_outer <- cl - - logger_message( - paste0( - "Evaluation: Parallel processing is done in the outer loop. ", - "No progress can be displayed."), - indent = message_indent, - verbose = verbose && !is.null(cl_outer)) - - } else { - cl_inner <- cl_outer <- NULL - } - - # Perform the necessary computations to create familiarData objects. - fam_mapply_lb( - cl = cl_outer, - assign = "all", - FUN = .create_familiar_data_runtime, - pool_data_table = split(new_data_table, by = "fam_data"), - progress_bar = !is.null(cl_outer) && verbose, - MoreArgs = list( - "cl" = cl_inner, - "dir_path" = file_paths$fam_data_dir, - "message_indent" = message_indent + 1L, - "verbose" = verbose)) - } - - # Re-check if all familiarData objects exist - data_set_list[, "fam_data_exists" := file.exists(fam_data)] - if (!all(data_set_list$fam_data_exists)) { - ..error_reached_unreachable_code( - ".prepare_familiar_data_sets: not all familiarData_objects were created.") - } - - return(data_set_list) -} - - - -.prepare_familiar_collections <- function(data_set_list) { - - # Suppress NOTES due to non-standard evaluation in data.table - descriptor <- NULL - - # Drop superfluous columns and select unique entries. - data_set_list <- data.table::copy(data_set_list[, mget(c( - "descriptor", "ensemble_data_id", "ensemble_run_id", - "pool_data_id", "pool_run_id", "fam_data"))]) - data_set_list <- unique(data_set_list) - - # Ensemble-based collections - ensemble_descriptors <- c( - "internal_development_ensemble", - "internal_validation_ensemble", - "external_validation_ensemble") - pool_descriptors <- c( - "internal_development_pool", - "internal_validation_pool", - "external_validation_pool") - - # Split by type - ensemble_collections <- split( - data_set_list[descriptor %in% ensemble_descriptors], - by = c("ensemble_data_id", "ensemble_run_id")) - pool_collections <- list(data_set_list[descriptor %in% pool_descriptors]) - - # Combine - collections <- c(ensemble_collections, pool_collections) - - # Process to extract collection_name, familiar_data objects and familiar data - # set names. - collections <- lapply(collections, .collect_collection_info) - - return(collections) -} - - -.get_ensemble_structure_info <- function( - run_list, - project_list, - only_pooling = FALSE) { - - # Suppress NOTES due to non-standard evaluation in data.table - perturb_level <- data_id <- run_id <- has_validation <- NULL - pool_perturb_level <- data_perturb_level <- can_pre_process <- NULL - - # Create empty ensemble run list - ensemble_run_list <- list() - - # Determine perturbation level for model building - model_perturb_level <- tail(run_list[[1]]$run_table, n = 1L)$perturb_level - - # Iterate upwards to perturb_level 1 - for (curr_perturb_level in rev(seq_len(model_perturb_level))) { - - # Generate a run table index - ensemble_run_list <- append( - ensemble_run_list, - lapply( - seq_len(length(run_list)), - function(ii, run_list, curr_perturb_level) { - - # Extract the table row corresponding to the current perturbation - # level for each entry in the run list - dt <- run_list[[ii]]$run_table[perturb_level >= curr_perturb_level] - - # Extract whether the current table row has validation data - dt[, "has_validation" := !is.null(project_list$iter_list[[as.character(data_id)]]$run[[as.character(run_id)]]$valid_samples), - by = c("data_id", "run_id")] - - # Get model data - dt_model <- tail(run_list[[ii]]$run_table, n = 1L) - - # Extract the data_id and run_id of each entry - dt[, ":="( - "model_data_id" = dt_model$data_id[1], - "model_run_id" = dt_model$run_id[1])] - - # Get pooling data - dt_pool <- run_list[[ii]]$run_table[perturb_level == curr_perturb_level] - - # Add a pool_data_id and pool_run_id entry, which determines at which - # level data is pooled - dt[, ":="( - "pool_data_id" = dt_pool$data_id[1], - "pool_run_id" = dt_pool$run_id[1], - "pool_perturb_level" = curr_perturb_level)] - - data.table::setnames( - dt, - old = c("data_id", "run_id", "perturb_level"), - new = c("ensemble_data_id", "ensemble_run_id", "data_perturb_level")) - - return(dt) - }, - curr_perturb_level = curr_perturb_level, - run_list = run_list)) - } - - # Combine different ensembles - ensemble_table <- data.table::rbindlist(ensemble_run_list) - - # Select the perturbation levels which have associated validation data, if - # any. Only itmes that can process are considered. This excludes bootstraps. - perturbation_levels <- head(sort(unique(ensemble_table[ - has_validation == TRUE & can_pre_process == TRUE]$data_perturb_level)), n = 2L) - - # Create the resulting data sets. - if (length(perturbation_levels) == 0) { - # Development pool - internal_development_pool <- ensemble_table[ - pool_perturb_level == 1 & can_pre_process == TRUE] - internal_development_pool[, ":="( - "descriptor" = "internal_development_pool", - "is_ensemble" = data_perturb_level == pool_perturb_level, - "is_validation" = FALSE)] - - data_sets <- list(internal_development_pool) - - } else { - # Internal development ensemble - internal_development_ensemble <- ensemble_table[ - data_perturb_level == tail(perturbation_levels, n = 1L) & pool_perturb_level != 1L] - internal_development_ensemble[, ":="( - "descriptor" = "internal_development_ensemble", - "is_ensemble" = data_perturb_level == pool_perturb_level, - "is_validation" = FALSE)] - - # Internal validation ensemble -- check if internal validation exists - if (!is_empty(ensemble_table[ - data_perturb_level == tail(perturbation_levels, n = 1L) & - data_perturb_level != 1L & - has_validation == TRUE & - pool_perturb_level != 1L])) { - - internal_validation_ensemble <- data.table::copy(internal_development_ensemble) - - # Update descriptors - internal_validation_ensemble[, ":="( - "descriptor" = "internal_validation_ensemble", - "is_validation" = TRUE)] - - } else { - internal_validation_ensemble <- head(internal_development_ensemble, n = 0L) - } - - # External validation ensemble -- check if external validation data exists - if (!is_empty(ensemble_table[ - data_perturb_level == 1L & - has_validation == TRUE & - pool_perturb_level == 1L])) { - - external_validation_ensemble <- data.table::copy(internal_development_ensemble) - - # Update descriptors - external_validation_ensemble[, ":="( - "descriptor" = "external_validation_ensemble", - "data_perturb_level" = 1L, - "pool_data_id" = 1L, - "pool_run_id" = 1L, - "pool_perturb_level" = 1L, - "is_ensemble" = TRUE, - "is_validation" = TRUE)] - - } else { - external_validation_ensemble <- head(internal_development_ensemble, n = 0L) - } - - # Development pool - internal_development_pool <- ensemble_table[ - data_perturb_level == tail(perturbation_levels, n = 1L) & pool_perturb_level == 1L] - internal_development_pool[, ":="( - "descriptor" = "internal_development_pool", - "ensemble_data_id" = 1L, - "ensemble_run_id" = 1, - "is_ensemble" = data_perturb_level == pool_perturb_level, - "is_validation" = FALSE)] - - # Internal validation pool - internal_validation_pool <- ensemble_table[ - data_perturb_level == tail(perturbation_levels, n = 1L) & - data_perturb_level != 1L & - has_validation == TRUE & - pool_perturb_level == 1L] - internal_validation_pool[, ":="( - "descriptor" = "internal_validation_pool", - "ensemble_data_id" = 1L, - "ensemble_run_id" = 1, - "is_ensemble" = data_perturb_level == pool_perturb_level, - "is_validation" = TRUE)] - - # External validation pool - external_validation_pool <- ensemble_table[ - data_perturb_level == 1L & has_validation == TRUE & pool_perturb_level == 1L] - external_validation_pool[, ":="( - "descriptor" = "external_validation_pool", - "is_ensemble" = data_perturb_level == pool_perturb_level, - "is_validation" = TRUE)] - - if (only_pooling) { - # List of datasets that operate on the top level (pooling level). - data_sets <- c( - list(internal_development_pool), - list(internal_validation_pool), - list(external_validation_pool)) - - } else { - # List of datasets - data_sets <- c( - split(internal_development_ensemble, by = "ensemble_run_id"), - split(internal_validation_ensemble, by = "ensemble_run_id"), - split(external_validation_ensemble, by = "ensemble_run_id"), - list(internal_development_pool), - list(internal_validation_pool), - list(external_validation_pool)) - } - } - - return(data_sets) -} - - -.create_familiar_ensemble_runtime <- function(ensemble_table, dir_path) { - # Creates a familiarEnsemble and extracts the corresponding data - # Note that data for development and validation data is extracted separately. - # This function is called during the validation step. - - # Generate a skeleton familiarEnsemble - fam_ensemble <- methods::new( - "familiarEnsemble", - model_list = as.list(ensemble_table$fam_model), - learner = ensemble_table$learner[1], - fs_method = ensemble_table$fs_method[1]) - - # Add package version. - fam_ensemble <- add_package_version(object = fam_ensemble) - - # Load models and prevent auto-detaching. - fam_ensemble <- load_models( - object = fam_ensemble, - dir_path = dir_path, - suppress_auto_detach = TRUE) - - # Create a run table - fam_ensemble@run_table <- list( - "run_table" = lapply( - fam_ensemble@model_list, - function(fam_model) fam_model@run_table), - "ensemble_data_id" = ensemble_table$ensemble_data_id[1], - "ensemble_run_id" = ensemble_table$ensemble_run_id[1]) - - # Complete the ensemble using information provided by the model - fam_ensemble <- complete_familiar_ensemble(object = fam_ensemble) - - # Detach models - fam_ensemble <- detach_models(object = fam_ensemble) - - save(list = fam_ensemble, file = dir_path) - - return(invisible(TRUE)) -} - - - -.create_familiar_data_runtime <- function( - cl = NULL, - pool_data_table, - dir_path, - message_indent = 0L, - verbose = TRUE) { - # Creates a familiarData object. - - logger_message( - paste0( - "\nEvaluation: Processing dataset ", pool_data_table$iteration_id, - " of ", pool_data_table$n_sets, "."), - indent = message_indent, - verbose = verbose) - - # Load the familiarEnsemble - fam_ensemble <- load_familiar_object(pool_data_table$fam_ensemble) - - # Define a dataObject with delayed reading. This enables the proper selection - # of development and training data for each familiarModel used in the - # ensemble. - data_obj <- methods::new( - "dataObject", - data = NULL, - preprocessing_level = "none", - outcome_type = fam_ensemble@outcome_type, - delay_loading = TRUE, - perturb_level = pool_data_table$data_perturb_level[1], - load_validation = pool_data_table$is_validation, - aggregate_on_load = FALSE) - - # Retrieve settings from the backend - settings <- get_settings() - - # Create a familiarData object - fam_data <- extract_data( - object = fam_ensemble, - data = data_obj, - cl = cl, - data_element = settings$eval$evaluation_data_elements, - time_max = settings$eval$time_max, - evaluation_times = settings$eval$eval_times, - sample_limit = settings$eval$sample_limit, - detail_level = settings$eval$detail_level, - estimation_type = settings$eval$estimation_type, - aggregate_results = settings$eval$aggregate_results, - aggregation_method = settings$eval$aggregation, - rank_threshold = settings$eval$aggr_rank_threshold, - ensemble_method = settings$eval$ensemble_method, - stratification_method = settings$eval$strat_method, - metric = settings$eval$metric, - feature_cluster_method = settings$eval$feature_cluster_method, - feature_cluster_cut_method = settings$eval$feature_cluster_cut_method, - feature_linkage_method = settings$eval$feature_linkage_method, - feature_similarity_metric = settings$eval$feature_similarity_metric, - feature_similarity_threshold = settings$eval$feature_similarity_threshold, - sample_cluster_method = settings$eval$sample_cluster_method, - sample_linkage_method = settings$eval$sample_linkage_method, - sample_similarity_metric = settings$eval$sample_similarity_metric, - confidence_level = settings$eval$confidence_level, - bootstrap_ci_method = settings$eval$bootstrap_ci_method, - dynamic_model_loading = settings$eval$auto_detach, - icc_type = settings$eval$icc_type, - message_indent = message_indent + 1L, - verbose = verbose) - - # Update the pooling table - fam_data@pooling_table <- fam_data@pooling_table[, ":="( - "pool_data_id" = pool_data_table$pool_data_id, - "pool_run_id" = pool_data_table$pool_run_id, - "pool_perturb_level" = pool_data_table$pool_perturb_level)] - - # Set a placeholder name for the familiarData object - fam_data <- set_object_name(x = fam_data) - - # Save the familiarData object - save(list = fam_data, file = dir_path) - - logger_message( - paste0( - "Evaluation: familiarData object ", get_object_name(object = fam_data), " was created."), - indent = message_indent, - verbose = verbose) - - return(invisible(TRUE)) -} - - - -.collect_collection_info <- function(data_set) { - - # Suppress NOTES due to non-standard evaluation in data.table - descriptor <- NULL - - # Determine whether any internal and external validation is present. - has_internal_validation <- any(data_set$descriptor %in% c( - "internal_validation_ensemble", "internal_validation_pool")) - has_external_validation <- any(data_set$descriptor %in% c( - "external_validation_ensemble", "external_validation_pool")) - - # Set development name - data_set[descriptor %in% c("internal_development_ensemble", "internal_development_pool"), - "fam_data_name" := "development"] - - # Set internal validation name - if (has_internal_validation && !has_external_validation) { - data_set[descriptor %in% c("internal_validation_ensemble", "internal_validation_pool"), - "fam_data_name" := "validation"] - - } else if (has_internal_validation && has_external_validation) { - data_set[descriptor %in% c("internal_validation_ensemble", "internal_validation_pool"), - "fam_data_name" := "int. validation"] - } - - # External validation name - if (!has_internal_validation && has_external_validation) { - data_set[descriptor %in% c("external_validation_ensemble", "external_validation_pool"), - "fam_data_name" := "validation"] - - } else if (has_internal_validation && has_external_validation) { - data_set[descriptor %in% c("external_validation_ensemble", "external_validation_pool"), - "fam_data_name" := "ext. validation"] - } - - # Determine whether the collection represents a pool or an ensemble. - is_pool <- any(data_set$descriptor == "internal_development_pool") - - # Set the collection name. - if (is_pool) { - collection_name <- "pooled_data" - - } else { - collection_name <- paste0("ensemble_data_", data_set$ensemble_run_id[1]) - } - - # Return collection info that is required to form a collection. - return(list( - "collection_name" = collection_name, - "fam_data" = as.list(data_set$fam_data), - "fam_data_names" = droplevels(factor( - x = data_set$fam_data_name, - levels = c("development", "int. validation", "ext. validation", "validation"))))) -} - - - -.create_familiar_collection_runtime <- function( - collection_info, - file_paths, - message_indent = 0L, - verbose = TRUE) { - - # Create the expected file path to the familiarCollection object. - fam_collection_file <- file.path( - file_paths$fam_coll_dir, - paste0(collection_info$collection_name, ".RDS")) - - # Check if the familiarCollection already exists. - if (!file.exists(fam_collection_file)) { - logger_message( - paste0("\nEvaluation: Creating collection ", collection_info$collection_name), - indent = message_indent, - verbose = verbose) - - # Create a collection using the available input data - fam_collection <- suppressWarnings( - as_familiar_collection( - object = collection_info$fam_data, - familiar_data_names = collection_info$fam_data_names, - collection_name = collection_info$collection_name)) - - # Save to drive. - save( - list = fam_collection, - file = file_paths$fam_coll_dir) - - } else { - # Read from drive. - fam_collection <- load_familiar_object(fam_collection_file) - } - - return(fam_collection) -} - - - -.process_collections <- function( - collection_info, - file_paths, - message_indent = 0L, - verbose = TRUE) { - - # Create or load familiarCollection object. - fam_collection <- .create_familiar_collection_runtime( - collection_info = collection_info, - file_paths = file_paths, - message_indent = message_indent, - verbose = verbose) - - logger_message( - paste0("\nEvaluation: Exporting data from collection ", collection_info$collection_name), - indent = message_indent, - verbose = verbose) - - # Export to csv - export_all( - object = fam_collection, - dir_path = file_paths$results_dir) - - # Export to plot - plot_all( - object = fam_collection, - dir_path = file_paths$results_dir) - - return(invisible(TRUE)) -} diff --git a/R/ExperimentData.R b/R/ExperimentData.R index b0a8e212..f0d5cc0b 100644 --- a/R/ExperimentData.R +++ b/R/ExperimentData.R @@ -13,7 +13,8 @@ load_experiment_data <- function(x, file_paths) { project_id <- gsub( x = basename(x), pattern = "[[:alpha:]]|[.]RDS$|[_]", - replacement = "") + replacement = "" + ) # Read from file system. x <- readRDS(x) @@ -26,15 +27,20 @@ load_experiment_data <- function(x, file_paths) { "experimentData", iteration_list = x$iteration_list, experiment_setup = x$experiment_setup, - project_id = project_id) + project_id = project_id + ) } } # Expect that the file is an experimentData object. if (!is(x, "experimentData")) { - stop(paste0( - "An experimentData object was expected. Found: a ", - paste_s(class(x)), " object.")) + ..error( + paste0( + "An experimentData object was expected. Found: a ", + paste_s(class(x)), " object." + ), + error_class = "input_argument_error" + ) } # Update the experimentData object. @@ -47,7 +53,8 @@ load_experiment_data <- function(x, file_paths) { # Set file name file_name <- .get_iteration_file_name( file_paths = file_paths, - project_id = x@project_id) + project_id = x@project_id + ) # Check if the directory exists, and create it otherwise. if (!dir.exists(file_paths$iterations_dir)) { @@ -55,38 +62,62 @@ load_experiment_data <- function(x, file_paths) { } # Save both files to the expected location. - saveRDS(list( - "iteration_list" = x@iteration_list, - "experiment_setup" = x@experiment_setup), - file = file_name) + saveRDS( + list( + "iteration_list" = x@iteration_list, + "experiment_setup" = x@experiment_setup + ), + file = file_name + ) } # Start writing feature information. if (!is.null(x@feature_info)) { - # Set file name - file_name <- .get_feature_info_file_name( - file_paths = file_paths, - project_id = x@project_id) - - # Check if the directory exists, and create it otherwise. - if (!dir.exists(dirname(file_name))) { - dir.create(dirname(file_name), recursive = TRUE) - } + for (feature_info_name in names(x@feature_info)) { + feature_info <- x@feature_info[[feature_info_name]] + + # Set file name. + if (feature_info_name == "generic") { + file_name <- get_object_file_name( + object_type = "genericFeatureInfo", + project_id = feature_info[[1L]]@project_id, + dir_path = file_paths$process_data_dir + ) + + } else { + file_name <- get_object_file_name( + object_type = "featureInfo", + project_id = feature_info[[1L]]@project_id, + data_id = feature_info[[1L]]@data_id, + run_id = feature_info[[1L]]@run_id, + dir_path = file_paths$process_data_dir + ) + } + + # Check if the directory exists, and create it otherwise. + if (!dir.exists(file_paths$process_data_dir)) { + dir.create(file_paths$process_data_dir, recursive = TRUE) + } - # Write to file. - saveRDS(x@feature_info, file = file_name) + # Write to file. + saveRDS(feature_info, file = file_name) + } } # Write variable importance information. if (!is.null(x@vimp_table_list)) { - for (vimp_method in names(x@vimp_table_list)) { + for (vimp_table in x@vimp_table_list) { # Set file name - file_name <- .get_feature_selection_data_filename( - project_id = x@project_id, - fs_method = vimp_method, - file_paths = file_paths) + file_name <- get_object_file_name( + object_type = "vimpTable", + data_id = vimp_table@data_id, + run_id = vimp_table@run_id, + vimp_method = vimp_table@vimp_method, + project_id = vimp_table@project_id, + dir_path = file_paths$vimp_dir + ) # Check if the directory exists, and create it otherwise. if (!dir.exists(dirname(file_name))) { @@ -94,7 +125,7 @@ load_experiment_data <- function(x, file_paths) { } # Write to file. - saveRDS(x@vimp_table_list[[vimp_method]], file = file_name) + saveRDS(vimp_table, file = file_name) } } @@ -103,32 +134,32 @@ load_experiment_data <- function(x, file_paths) { -create_experiment_data <- function( +set_experiment_data <- function( + x = NULL, project_id, - experiment_setup, - iteration_list, + experiment_setup = NULL, + iteration_list = NULL, feature_info = NULL, - vimp_table_list = NULL) { - + vimp_hyperparameter_list = NULL, + vimp_table_list = NULL +) { + # Create new object. - x <- methods::new( - "experimentData", - experiment_setup = experiment_setup, - iteration_list = iteration_list, - project_id = project_id) - - # Add package version - x <- add_package_version(x) - - # Attach feature info, if present. - if (is.null(feature_info)) return(x) - - x@feature_info <- feature_info - - # Attach variable importance tables, if present. - if (is.null(vimp_table_list)) return(x) + if (!is(x, "experimentData")) { + x <- methods::new( + "experimentData", + project_id = project_id + ) + + # Add package version + x <- add_package_version(x) + } - x@vimp_table_list <- vimp_table_list + if (is.null(x@experiment_setup) && !is.null(experiment_setup)) x@experiment_setup <- experiment_setup + if (is.null(x@iteration_list) && !is.null(iteration_list)) x@iteration_list <- iteration_list + if (is.null(x@feature_info) && !is.null(feature_info)) x@feature_info <- feature_info + if (!is.null(vimp_hyperparameter_list)) x@vimp_hyperparameter_list <- vimp_hyperparameter_list + if (!is.null(vimp_table_list)) x@vimp_table_list <- vimp_table_list return(x) } @@ -149,15 +180,17 @@ setMethod( # Check if feature info is present. if (!is.null(object@feature_info)) { - if (length(object@feature_info) > 1) { + if (length(object@feature_info) > 1L) { content_str <- c( content_str, - "basic and extended feature information") + "basic and extended feature information" + ) } else { content_str <- c( content_str, - "basic feature information") + "basic feature information" + ) } } @@ -165,12 +198,14 @@ setMethod( if (!is.null(object@vimp_table_list)) { content_str <- c( content_str, - paste0("variable importance (", paste_s(names(object@vimp_table_list)), ")")) + paste0("variable importance (", paste_s(names(object@vimp_table_list)), ")") + ) } cat(paste0( "Experiment data object (", .familiar_version_string(object), ") with project id ", - object@project_id, " containing ", paste_s(content_str), ".\n")) + object@project_id, " containing ", paste_s(content_str), ".\n" + )) } ) diff --git a/R/ExperimentSetup.R b/R/ExperimentSetup.R index 70f30459..c0dd6ecf 100644 --- a/R/ExperimentSetup.R +++ b/R/ExperimentSetup.R @@ -15,12 +15,13 @@ extract_experimental_setup <- function( experimental_design, file_dir, message_indent = 0L, - verbose = TRUE) { + verbose = TRUE +) { if (.experimental_design_is_file( file_dir = file_dir, - experimental_design = experimental_design)) { - + experimental_design = experimental_design + )) { return(waiver()) } @@ -28,27 +29,37 @@ extract_experimental_setup <- function( experimental_design <- gsub( pattern = " ", replacement = "", - x = experimental_design) + x = experimental_design + ) # Generate a section table section_table <- .get_experimental_design_section_table( - experimental_design = experimental_design) + experimental_design = experimental_design + ) # Identify the subsampler algorithms section_table <- .complete_experimental_design_section_table( section_table = section_table, - experimental_design = experimental_design) + experimental_design = experimental_design + ) # Check consistency of the table, e.g. feature selection should only appear # once, etc. .check_experimental_design_section_table( - section_table = section_table) + section_table = section_table + ) + + # Identify the experimental levels where pre-processing could occur. + .set_experimental_design_preprocessing( + section_table = section_table + ) # Report experimental design to the user. .report_experimental_design( section_table = section_table, message_indent = message_indent, - verbose = verbose) + verbose = verbose + ) return(section_table) } @@ -57,14 +68,17 @@ extract_experimental_setup <- function( .experimental_design_is_file <- function( file_dir, - experimental_design) { + experimental_design +) { # Check if the experimental design argument is actually a path to a file. if (is.null(file_dir)) return(FALSE) # Check if the file exists at all. - if (!file.exists(file.path(file_dir, experimental_design)) && - !file.exists(experimental_design)) { + if ( + !file.exists(file.path(file_dir, experimental_design)) && + !file.exists(experimental_design) + ) { return(FALSE) } @@ -81,23 +95,25 @@ extract_experimental_setup <- function( left_parenthesis <- gregexpr( pattern = "(", text = experimental_design, - fixed = TRUE)[[1]] + fixed = TRUE + )[[1L]] right_parenthesis <- gregexpr( pattern = ")", text = experimental_design, - fixed = TRUE)[[1]] + fixed = TRUE + )[[1L]] - if (left_parenthesis[1] == -1) left_parenthesis <- integer(0) - if (right_parenthesis[1] == -1) right_parenthesis <- integer(0) + if (left_parenthesis[1L] == -1L) left_parenthesis <- integer(0L) + if (right_parenthesis[1L] == -1L) right_parenthesis <- integer(0L) # Subsequently generate the corresponding experimental levels experiment_levels <- integer(nchar(experimental_design)) for (ii in right_parenthesis) { - experiment_levels[1:ii] <- experiment_levels[1:ii] + 1 + experiment_levels[1L:ii] <- experiment_levels[1L:ii] + 1L } for (ii in left_parenthesis) { - experiment_levels[1L:(ii - 1L)] <- experiment_levels[1L:(ii - 1L)] - 1 + experiment_levels[1L:(ii - 1L)] <- experiment_levels[1L:(ii - 1L)] - 1L } # Generate setup sections @@ -112,22 +128,27 @@ extract_experimental_setup <- function( data.table::setnames( x = section_table, old = c("values", "end", "start"), - new = c("exp_level_id", "sect_end", "sect_start")) + new = c("exp_level_id", "sect_end", "sect_start") + ) # Set up columns to be filled section_table[, ":="( - "ref_data_id" = 0, - "main_data_id" = 0, - "feat_sel" = FALSE, - "model_building" = FALSE, + "ref_data_id" = 0L, + "main_data_id" = 0L, + "vimp" = FALSE, + "train" = FALSE, + "internal_validation" = FALSE, "external_validation" = FALSE, "perturb_method" = "none", - "perturb_n_rep" = 0, - "perturb_n_folds" = 0)] + "perturb_n_rep" = 0L, + "perturb_n_folds" = 0L + )] return(section_table) } + + .get_available_subsample_methods <- function() { return(c( "main", @@ -135,30 +156,102 @@ extract_experimental_setup <- function( "full_bootstrap", "cross_val", "loocv", - "imbalance_partition")) + "imbalance_partition" + )) } + +.set_experimental_design_preprocessing <- function(section_table) { + # Suppress NOTES due to non-standard evaluation in data.table + perturb_method <- NULL + + # Add can_preprocess column. + section_table[, "can_pre_process" := TRUE] + + # Set can_pre_process to FALSE for select perturbation methods. + section_table[ + perturb_method %in% c("limited_bootstrap"), + ":="(can_pre_process = FALSE, internal_validation = FALSE) + ] + + return(section_table) +} + + + +.set_experimental_design_n_runs <- function( + section_table, + iteration_list +) { + # Determine the number of runs for each level in the experimental design based + # on the actually realised iterations. This ensures that the number of runs + # is consistent with the iteration list. Some perturbation methods, such as + # LOOCV, don't have a number of runs that can be determined without inspecting + # the data. Hence we set n_runs based off the iteration list. + + # Suppress NOTES due to non-standard evaluation in data.table + main_data_id <- NULL + + ...get_n_samples <- function(x, type) { + if (is_empty(x[[type]])) return(0L) + + return(nrow(x[[type]])) + } + + # Add perturbation level. + section_table[, "perturbation_level" := 1L] + for (data_id in section_table$main_data_id) { + section_table[main_data_id == data_id, "perturbation_level" := tail(iteration_list[[as.character(data_id)]]$run[["1"]]$run_table, n = 1L)$perturb_level] + } + + # Add number of runs. + section_table[, "n_runs" := 1L] + for (data_id in section_table$main_data_id) { + section_table[main_data_id == data_id, "n_runs" := length(iteration_list[[as.character(data_id)]]$run)] + } + + # Determine the number of instances available for development and validation. + for (data_id in section_table$main_data_id) { + + n_run_training_samples <- sapply(iteration_list[[as.character(data_id)]]$run, ...get_n_samples, type = "train_samples") + n_run_validation_samples <- sapply(iteration_list[[as.character(data_id)]]$run, ...get_n_samples, type = "valid_samples") + + section_table[main_data_id == data_id, ":="( + "min_training_instances" = min(n_run_training_samples), + "max_training_instances" = max(n_run_training_samples), + "min_validation_instances" = min(n_run_validation_samples), + "max_validation_instances" = max(n_run_validation_samples) + )] + } + + return(section_table) +} + + + .complete_experimental_design_section_table <- function( section_table, - experimental_design) { + experimental_design +) { # Suppress NOTES due to non-standard evaluation in data.table - exp_level_id <- sect_start <- perturb_method <- NULL + exp_level_id <- sect_start <- perturb_method <- train <- main_data_id <- NULL # Iterator - main_data_id_iter <- 1 + main_data_id_iter <- 1L #Identify samplers------------------------------------------------------------ # Iterate over sections to set main_data_id for (ii in seq_len(nrow(section_table))) { # Check if ip, bt, lv or cv preceeds the current section - if (section_table$sect_start[ii] > 2) { + if (section_table$sect_start[ii] > 2L) { sampler_str <- substr( x = experimental_design, start = section_table$sect_start[ii] - 2L, - stop = section_table$sect_start[ii] - 1L) + stop = section_table$sect_start[ii] - 1L + ) # Check for imbalance partition (ip), limited bootstrap (bt), full # bootstrap (bs), cross-validation (cv) and leave-one-out-cross-validation @@ -166,34 +259,34 @@ extract_experimental_setup <- function( if (sampler_str == "bt") { section_table$perturb_method[ii] <- "limited_bootstrap" section_table$main_data_id[ii] <- main_data_id_iter - main_data_id_iter <- main_data_id_iter + 1 + main_data_id_iter <- main_data_id_iter + 1L } else if (sampler_str == "bs") { section_table$perturb_method[ii] <- "full_bootstrap" section_table$main_data_id[ii] <- main_data_id_iter - main_data_id_iter <- main_data_id_iter + 1 + main_data_id_iter <- main_data_id_iter + 1L } else if (sampler_str == "cv") { section_table$perturb_method[ii] <- "cross_val" section_table$main_data_id[ii] <- main_data_id_iter - main_data_id_iter <- main_data_id_iter + 1 + main_data_id_iter <- main_data_id_iter + 1L } else if (sampler_str == "lv") { section_table$perturb_method[ii] <- "loocv" section_table$main_data_id[ii] <- main_data_id_iter - main_data_id_iter <- main_data_id_iter + 1 + main_data_id_iter <- main_data_id_iter + 1L } else if (sampler_str == "ip") { section_table$perturb_method[ii] <- "imbalance_partition" section_table$main_data_id[ii] <- main_data_id_iter - main_data_id_iter <- main_data_id_iter + 1 + main_data_id_iter <- main_data_id_iter + 1L } rm(sampler_str) } else { section_table$perturb_method[ii] <- "main" section_table$main_data_id[ii] <- main_data_id_iter - main_data_id_iter <- main_data_id_iter + 1 + main_data_id_iter <- main_data_id_iter + 1L } } @@ -204,11 +297,13 @@ extract_experimental_setup <- function( # Iterate over sections to set main_data_id (where missing) and ref_data_id for (ii in seq_len(nrow(section_table))) { - if (section_table$main_data_id[ii] == 0) { + if (section_table$main_data_id[ii] == 0L) { # Make subselection of data at the same level and select only preceding sections dt_sub <- section_table[ exp_level_id == section_table$exp_level_id[ii] & - sect_start < section_table$sect_start[ii], ] + sect_start < section_table$sect_start[ii] + , + ] # Set data id from nearest preceding lower level section section_table$main_data_id[ii] <- dt_sub$main_data_id[nrow(dt_sub)] @@ -217,15 +312,17 @@ extract_experimental_setup <- function( } # Set reference data id - if (section_table$exp_level_id[ii] == 0) { + if (section_table$exp_level_id[ii] == 0L) { # At the lowest level (main) there is no reference - section_table$ref_data_id[ii] <- 0 + section_table$ref_data_id[ii] <- 0L } else { # Make subselection of data one level higher and select only preceding sections dt_sub <- section_table[ - exp_level_id == section_table$exp_level_id[ii] - 1 & - sect_start < section_table$sect_start[ii], ] + exp_level_id == section_table$exp_level_id[ii] - 1L & + sect_start < section_table$sect_start[ii] + , + ] # Set data id from nearest preceding lower level section section_table$ref_data_id[ii] <- dt_sub$main_data_id[nrow(dt_sub)] @@ -248,7 +345,9 @@ extract_experimental_setup <- function( substr( x = experimental_design, start = section_table$sect_start[jj], - stop = section_table$sect_end[jj])) + stop = section_table$sect_end[jj] + ) + ) } curr_data_id_str <- paste0(curr_data_id_str, collapse = "") @@ -257,48 +356,60 @@ extract_experimental_setup <- function( curr_data_id_str <- gsub( pattern = "\\(|\\)", replacement = "", - x = curr_data_id_str) + x = curr_data_id_str + ) curr_data_id_str <- strsplit( x = curr_data_id_str, split = ",", - fixed = TRUE)[[1]] + fixed = TRUE + )[[1L]] # Check if feature selection is included in the current section - if (grepl(pattern = "fs", x = curr_data_id_str[1])) { - section_table$feat_sel[ii] <- TRUE + if (grepl(pattern = "fs", x = curr_data_id_str[1L])) { + section_table$vimp[ii] <- TRUE } # Check if model building is included in the current section - if (grepl(pattern = "mb", x = curr_data_id_str[1])) { - section_table$model_building[ii] <- TRUE + if (grepl(pattern = "mb", x = curr_data_id_str[1L])) { + section_table$train[ii] <- TRUE } # Check if external validation is included in the current section - if (grepl(pattern = "ev", x = curr_data_id_str[1])) { + if (grepl(pattern = "ev", x = curr_data_id_str[1L])) { section_table$external_validation[ii] <- TRUE } # Read bootstrap data if (section_table$perturb_method[ii] %in% c("limited_bootstrap", "full_bootstrap")) { - if (length(curr_data_id_str) < 2) { - stop(paste0( - "The number of bootstraps should be indicated when using the bt ", - "(bootstrap) subsampler. None was found.")) + if (length(curr_data_id_str) < 2L) { + ..error( + paste0( + "The number of bootstraps should be indicated when using the bt ", + "(bootstrap) subsampler. None was found." + ), + error_class = "input_argument_error" + ) } # Determine the number of bootstraps n_reps <- .perform_type_conversion( - x = curr_data_id_str[2], + x = curr_data_id_str[2L], to_type = "integer", var_name = "The number of bootstraps", - req_length = 1L) + req_length = 1L + ) # Check whether the number of bootstraps is at least 1 .check_number_in_valid_range( x = n_reps, var_name = "The number of bootstraps", - range = c(1L, Inf)) - + range = c(1L, Inf) + ) + + if (section_table$perturb_method[ii] == "full_bootstrap") { + section_table$internal_validation[ii] <- TRUE + } + # Add the number of bootstraps to the section table section_table$perturb_n_rep[ii] <- n_reps } @@ -306,41 +417,52 @@ extract_experimental_setup <- function( # Read cross-validation settings if (section_table$perturb_method[ii] == "cross_val") { if (length(curr_data_id_str) < 2L) { - stop(paste0( - "The number of folds should be indicated when using the cv ", - "(cross-validation) subsampler. None was found.")) + ..error( + paste0( + "The number of folds should be indicated when using the cv ", + "(cross-validation) subsampler. None was found." + ), + error_class = "input_argument_error" + ) } # Determine the number of folds n_folds <- .perform_type_conversion( - x = curr_data_id_str[2], + x = curr_data_id_str[2L], to_type = "integer", var_name = "The number of cross-validation folds", - req_length = 1L) + req_length = 1L + ) # Check whether the number of folds is at least 2 .check_number_in_valid_range( x = n_folds, var_name = "The number of cross-validations folds", - range = c(2L, Inf)) + range = c(2L, Inf) + ) + + # Set internal validation. + section_table$internal_validation[ii] <- TRUE # Add number of folds to the section_table section_table$perturb_n_folds[ii] <- n_folds # Check the number of repetitions - if (length(curr_data_id_str) >= 3) { + if (length(curr_data_id_str) >= 3L) { n_reps <- .perform_type_conversion( - x = curr_data_id_str[3], + x = curr_data_id_str[3L], to_type = "integer", var_name = "The number of cross-validation repetitions", - req_length = 1L) + req_length = 1L + ) # Check whether the number of CV repetitions is at least 1 .check_number_in_valid_range( x = n_folds, var_name = "The number of cross-validations repetitions", - range = c(1L, Inf)) + range = c(1L, Inf) + ) # Add number of repetitions to the section table section_table$perturb_n_rep[ii] <- n_reps @@ -353,6 +475,9 @@ extract_experimental_setup <- function( # Read leave-one-out-cross-validation settings if (section_table$perturb_method[ii] == "loocv") { + # Set internal validation. + section_table$internal_validation[ii] <- TRUE + section_table$perturb_n_folds[ii] <- -1L section_table$perturb_n_rep[ii] <- 1L } @@ -361,12 +486,36 @@ extract_experimental_setup <- function( } } - # Remove unnessary rows and columns + # Remove unnecessary rows and columns section_table <- section_table[perturb_method != "none", ] section_table[, ":="( "exp_level_id" = NULL, "sect_end" = NULL, - "sect_start" = NULL)] + "sect_start" = NULL + )] + + # Internal validation can only be at the same level as train, or above. + if (any(section_table$internal_validation)) { + internal_validation_data_id <- 0L + data_id <- section_table[train == TRUE]$main_data_id[1L] + while (data_id > 1L) { + if (section_table[main_data_id == data_id]$internal_validation[1L] == TRUE) { + # Update internal_validation_data_id if internal validation could occur + # at the current level. This gets overridden by lower (i.e. + # higher-level) data ids. + internal_validation_data_id <- data_id + } + + # Go to the next level. + data_id <- section_table[main_data_id == data_id]$ref_data_id[1L] + } + + # Set all internal_validation to FALSE. + section_table[, "internal_validation" := FALSE] + if (internal_validation_data_id > 0L) { + section_table[main_data_id == internal_validation_data_id, "internal_validation" := TRUE] + } + } return(section_table) } @@ -376,198 +525,262 @@ extract_experimental_setup <- function( .report_experimental_design <- function( section_table, message_indent = 0L, - verbose = TRUE) { + verbose = TRUE +) { # Suppress NOTES due to non-standard evaluation in data.table - feat_sel <- model_building <- main_data_id <- NULL + vimp <- train <- main_data_id <- NULL # Report on validation data: if (any(section_table$external_validation)) { logger_message( "Setup report: Validation is external.", indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else { logger_message( "Setup report: Validation is internal only.", indent = message_indent, - verbose = verbose) + verbose = verbose + ) } # Report on model building and feature selection - if (any(section_table$feat_sel * section_table$model_building)) { + if (any(section_table$vimp * section_table$train)) { main_message <- "Setup report: Feature selection and model building on" # Iteratively append message - dt_sub <- section_table[feat_sel == TRUE & model_building == TRUE, ] - curr_ref_data_id <- dt_sub$main_data_id[1] - while (curr_ref_data_id > 0) { + dt_sub <- section_table[vimp == TRUE & train == TRUE, ] + curr_ref_data_id <- dt_sub$main_data_id[1L] + while (curr_ref_data_id > 0L) { dt_sub <- section_table[main_data_id == curr_ref_data_id, ] - if (dt_sub$perturb_method[1] == "main") { + if (dt_sub$perturb_method[1L] == "main") { main_message <- c( main_message, - "the training data.") + "the training data." + ) - } else if (dt_sub$perturb_method[1] %in% c("limited_bootstrap", "full_bootstrap")) { + } else if (dt_sub$perturb_method[1L] %in% c("limited_bootstrap", "full_bootstrap")) { main_message <- c( main_message, - paste0(dt_sub$perturb_n_rep[1], " bootstraps of")) + paste0(dt_sub$perturb_n_rep[1L], " bootstraps of") + ) - } else if (dt_sub$perturb_method[1] == "cross_val") { + } else if (dt_sub$perturb_method[1L] == "cross_val") { main_message <- c( main_message, paste0( - dt_sub$perturb_n_rep[1], " repetitions of ", - dt_sub$perturb_n_folds, "-fold cross validation of")) + dt_sub$perturb_n_rep[1L], " repetitions of ", + dt_sub$perturb_n_folds, "-fold cross validation of" + ) + ) - } else if (dt_sub$perturb_method[1] == "loocv") { + } else if (dt_sub$perturb_method[1L] == "loocv") { main_message <- c( main_message, - "folds of leave-one-out-cross-validation of") + "folds of leave-one-out-cross-validation of" + ) - } else if (dt_sub$perturb_method[1] == "imbalance_partition") { + } else if (dt_sub$perturb_method[1L] == "imbalance_partition") { main_message <- c( main_message, - "class-balanced partitions of") + "class-balanced partitions of" + ) } - curr_ref_data_id <- dt_sub$ref_data_id[1] + curr_ref_data_id <- dt_sub$ref_data_id[1L] } logger_message( paste0(main_message, collapse = " "), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else { - # Feature selection first - main_message <- "Setup report: Feature selection on" - - # Iteratively append message - dt_sub <- section_table[feat_sel == TRUE, ] - curr_ref_data_id <- dt_sub$main_data_id[1] - while (curr_ref_data_id > 0) { + if (any(section_table$vimp)) { + # Feature selection first + main_message <- "Setup report: Feature selection on" - dt_sub <- section_table[main_data_id == curr_ref_data_id, ] + # Iteratively append message + dt_sub <- section_table[vimp == TRUE, ] + curr_ref_data_id <- dt_sub$main_data_id[1L] - if (dt_sub$perturb_method[1] == "main") { - main_message <- c( - main_message, - "the training data.") + while (curr_ref_data_id > 0L) { - } else if (dt_sub$perturb_method[1] %in% c("limited_bootstrap", "full_bootstrap")) { - main_message <- c( - main_message, - paste0(dt_sub$perturb_n_rep[1], " bootstraps of")) - - } else if (dt_sub$perturb_method[1] == "cross_val") { - main_message <- c( - main_message, - paste0( - dt_sub$perturb_n_rep[1], " repetitions of ", - dt_sub$perturb_n_folds, "-fold cross validation of")) + dt_sub <- section_table[main_data_id == curr_ref_data_id, ] - } else if (dt_sub$perturb_method[1] == "loocv") { - main_message <- c( - main_message, - "folds of leave-one-out-cross-validation of") + if (dt_sub$perturb_method[1L] == "main") { + main_message <- c( + main_message, + "the training data." + ) + + } else if (dt_sub$perturb_method[1L] %in% c("limited_bootstrap", "full_bootstrap")) { + main_message <- c( + main_message, + paste0(dt_sub$perturb_n_rep[1L], " bootstraps of") + ) + + } else if (dt_sub$perturb_method[1L] == "cross_val") { + main_message <- c( + main_message, + paste0( + dt_sub$perturb_n_rep[1L], " repetitions of ", + dt_sub$perturb_n_folds, "-fold cross validation of" + ) + ) + + } else if (dt_sub$perturb_method[1L] == "loocv") { + main_message <- c( + main_message, + "folds of leave-one-out-cross-validation of" + ) + + } else if (dt_sub$perturb_method[1L] == "imbalance_partition") { + main_message <- c( + main_message, + "class-balanced partitions of" + ) + } - } else if (dt_sub$perturb_method[1] == "imbalance_partition") { - main_message <- c( - main_message, - "class-balanced partitions of") + curr_ref_data_id <- dt_sub$ref_data_id[1L] } - curr_ref_data_id <- dt_sub$ref_data_id[1] + logger_message( + paste0(main_message, collapse = " "), + indent = message_indent, + verbose = verbose + ) } - logger_message( - paste0(main_message, collapse = " "), - indent = message_indent, - verbose = verbose) - # Model building second main_message <- "Setup report: Model building on" # Iteratively append message - dt_sub <- section_table[model_building == TRUE, ] - curr_ref_data_id <- dt_sub$main_data_id[1] + dt_sub <- section_table[train == TRUE, ] + curr_ref_data_id <- dt_sub$main_data_id[1L] - while (curr_ref_data_id > 0) { + while (curr_ref_data_id > 0L) { dt_sub <- section_table[main_data_id == curr_ref_data_id, ] - if (dt_sub$perturb_method[1] == "main") { + if (dt_sub$perturb_method[1L] == "main") { main_message <- c( main_message, - "the training data.") + "the training data." + ) - } else if (dt_sub$perturb_method[1] %in% c("limited_bootstrap", "full_bootstrap")) { + } else if (dt_sub$perturb_method[1L] %in% c("limited_bootstrap", "full_bootstrap")) { main_message <- c( main_message, - paste0(dt_sub$perturb_n_rep[1], " bootstraps of")) + paste0(dt_sub$perturb_n_rep[1L], " bootstraps of") + ) - } else if (dt_sub$perturb_method[1] == "cross_val") { + } else if (dt_sub$perturb_method[1L] == "cross_val") { main_message <- c( main_message, paste0( - dt_sub$perturb_n_rep[1], " repetitions of ", - dt_sub$perturb_n_folds, "-fold cross validation of")) + dt_sub$perturb_n_rep[1L], " repetitions of ", + dt_sub$perturb_n_folds, "-fold cross validation of" + ) + ) - } else if (dt_sub$perturb_method[1] == "loocv") { + } else if (dt_sub$perturb_method[1L] == "loocv") { main_message <- c( main_message, - "folds of leave-one-out-cross-validation of") + "folds of leave-one-out-cross-validation of" + ) - } else if (dt_sub$perturb_method[1] == "imbalance_partition") { + } else if (dt_sub$perturb_method[1L] == "imbalance_partition") { main_message <- c( main_message, - "class-balanced partitions of") + "class-balanced partitions of" + ) } - curr_ref_data_id <- dt_sub$ref_data_id[1] + curr_ref_data_id <- dt_sub$ref_data_id[1L] } logger_message( paste0(main_message, collapse = " "), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } } + .check_experimental_design_section_table <- function(section_table) { - if (sum(section_table$feat_sel) > 1) { - stop(paste0( - "The fs component for feature selection may only be used once ", - "in the experimental design.")) + if (sum(section_table$vimp) > 1L) { + ..error( + paste0( + "The fs component for variable importance computation may only be used once ", + "in the experimental design." + ), + error_class = "input_argument_error" + ) } - if (sum(section_table$feat_sel) == 0) { - stop(paste0( - "The fs component for feature selection must appear in the ", - "experimental design. It was not found.")) + if (sum(section_table$train) > 1L) { + ..error( + paste0( + "The mb component for training may only be used once ", + "in the experimental design." + ), + error_class = "input_argument_error" + ) } - if (sum(section_table$model_building) > 1) { - stop(paste0( - "The mb component for model building may only be used once ", - "in the experimental design.")) + if (sum(section_table$train) == 0L) { + ..error( + paste0( + "The mb component for training must appear in the ", + "experimental design. It was not found." + ), + error_class = "input_argument_error" + ) } - if (sum(section_table$model_building) == 0) { - stop(paste0( - "The mb component for model building must appear in the ", - "experimental design. It was not found.")) + if (sum(section_table$external_validation) > 1L) { + ..error( + paste0( + "The ev component for external validation can only appear once ", + "in the experimental design." + ), + error_class = "input_argument_error" + ) } - if (sum(section_table$external_validation) > 1) { - stop(paste0( - "The ev component for external validation can only appear once ", - "in the experimental design.")) + return(invisible(TRUE)) +} + + + +.get_run_table_from_experiment_setup <- function( + data_id, + experiment_setup +) { + + # Suppress NOTES due to non-standard evaluation in data.table + perturbation_level <- main_data_id <- NULL + + # Get the data id chain. + data_id_chain <- reference_data_id <- data_id + while (reference_data_id != 0L) { + reference_data_id <- experiment_setup[main_data_id == reference_data_id, ]$ref_data_id + if (reference_data_id == 0L) break + data_id_chain <- c(data_id_chain, reference_data_id) } - return(invisible(TRUE)) + # Reconstruct run table. + run_table <- data.table::copy( + experiment_setup[main_data_id %in% data_id_chain, ] + )[order(perturbation_level)] + + return(run_table) } diff --git a/R/Familiar.R b/R/Familiar.R index 1994b35c..949e085c 100644 --- a/R/Familiar.R +++ b/R/Familiar.R @@ -23,7 +23,7 @@ #' @importFrom stats predict coef vcov #' @importFrom survival Surv coxph survreg #' @importFrom utils head tail -#' @importFrom rlang quo quos enquo enquos sym syms ensym ensyms parse_expr parse_exprs +#' @importFrom rlang quo quos enquo enquos sym syms ensym ensyms parse_expr parse_exprs %<~% "_PACKAGE" @@ -50,7 +50,9 @@ #' `RData` files. See documentation for the `data_files` argument for more #' information. #' -#' @param experiment_data Experimental data may provided in the form of +#' @param experiment_data Experimental data may provided in the form of the +#' output of `precompute_data_assignment`, `precompute_feature_info` or +#' `precompute_vimp`. This allows for warm-starting experiments. #' #' @param cl Cluster created using the `parallel` package. This cluster is then #' used to speed up computation through parallelisation. When a cluster is not @@ -70,12 +72,14 @@ #' @param verbose Indicates verbosity of the results. Default is TRUE, and all #' messages and warnings are returned. #' @param .stop_after Variable for internal use. +#' @param .force_output Generates output even if results have been written to +#' the file system. #' #' @inheritDotParams .parse_file_paths -config -verbose #' @inheritDotParams .parse_experiment_settings -config #' @inheritDotParams .parse_setup_settings -config #' @inheritDotParams .parse_preprocessing_settings -config -data -parallel -outcome_type -#' @inheritDotParams .parse_feature_selection_settings -config -data -parallel -outcome_type +#' @inheritDotParams .parse_variable_importance_settings -config -data -parallel -outcome_type #' @inheritDotParams .parse_model_development_settings -config -data -parallel -outcome_type #' @inheritDotParams .parse_hyperparameter_optimisation_settings -config -parallel -outcome_type #' @inheritDotParams .parse_evaluation_settings -config -data -parallel -outcome_type -hpo_metric -development_batch_id -vimp_aggregation_rank_threshold -vimp_aggregation_method -prep_cluster_method -prep_cluster_linkage_method -prep_cluster_cut_method -prep_cluster_similarity_threshold -prep_cluster_similarity_metric @@ -97,12 +101,14 @@ summon_familiar <- function( config = NULL, config_id = 1L, verbose = TRUE, - .stop_after = "evaluation", - ...) { + .stop_after = "export", + .force_output = FALSE, + ... +) { # Set options. # Disable randomForestSRC OpenMP core use. - options(rf.cores = as.integer(1)) + options(rf.cores = 1L) on.exit(options(rf.cores = -1L), add = TRUE) # Disable multithreading on data.table to prevent reduced performance due to @@ -114,13 +120,15 @@ summon_familiar <- function( .check_parameter_value_is_valid( x = .stop_after, var_name = ".stop_after", - values = c("setup", "preprocessing", "vimp", "training", "evaluation")) + values = c("setup", "preprocessing", "vimp", "training", "evaluation", "export") + ) # Load configuration file ---------------------------------------------------- config <- .load_configuration_file( config = config, - config_id = config_id) + config_id = config_id + ) # Test arguments provided by ... and config ---------------------------------- @@ -134,7 +142,9 @@ summon_familiar <- function( .parse_file_paths, args = c( list("config" = config, "verbose" = verbose), - list(...))) + list(...) + ) + ) # Set paths to data if (!is.null(file_paths$data) && is.null(data)) { @@ -145,7 +155,8 @@ summon_familiar <- function( if (file_paths$is_temporary) { on.exit( unlink(file_paths$experiment_dir, recursive = TRUE), - add = TRUE) + add = TRUE + ) } # Load data ------------------------------------------------------------------ @@ -159,7 +170,8 @@ summon_familiar <- function( # Parse experiment and data settings settings <- do.call( .parse_initial_settings, - args = c(list("config" = config), dots)) + args = c(list("config" = config), dots) + ) if (is(data, "dataObject")) { # Reconstitute settings from the data. @@ -175,13 +187,15 @@ summon_familiar <- function( # Load data. data <- do.call( .load_data, - args = c(list("data" = data), settings$data)) + args = c(list("data" = data), settings$data) + ) # Update settings settings <- .update_initial_settings( formula = formula, data = data, - settings = settings) + settings = settings + ) } # Parse data @@ -197,8 +211,70 @@ summon_familiar <- function( censoring_indicator = settings$data$censoring_indicator, event_indicator = settings$data$event_indicator, competing_risk_indicator = settings$data$competing_risk_indicator, - reference_method = settings$data$reference_method) + reference_method = settings$data$reference_method + ) + # Initialise workers --------------------------------------------------------- + # Identify if an external cluster is provided, and required. + is_external_cluster <- FALSE + if (settings$run$parallel) { + is_external_cluster <- inherits(cl, "cluster") + } + + # Assign parallel options to global familiar environment. + .assign_backend_options_to_global( + backend_type = settings$run$backend_type, + server_port = settings$run$server_port + ) + .assign_parallel_options_to_global( + is_external_cluster = is_external_cluster, + restart_cluster = settings$run$restart_cluster, + n_cores = settings$run$parallel_nr_cores, + cluster_type = settings$run$cluster_type + ) + + # Make sure that backend server will close after the process finishes. + on.exit( + shutdown_backend_server( + backend_type = settings$run$backend_type, + server_port = settings$run$server_port + ), + add = TRUE + ) + + # Start workers, if required. + if ( + settings$run$parallel && + !settings$run$restart_cluster && + !is_external_cluster + ) { + # Start local cluster in the overall process. Note that at this point we + # cannot assign anything relevant -- this will be handled later. + cl <- .restart_cluster(cl = NULL, assign = "none") + on.exit(.terminate_cluster(cl), add = TRUE) + + } else if ( + settings$run$parallel && + settings$run$restart_cluster && + !is_external_cluster + ) { + # Start processes locally. + cl <- waiver() + + } else if (!settings$run$parallel) { + # No cluster is created when + cl <- NULL + } + + # Data plausibility checks --------------------------------------------------- + + # Check data plausibility. + .check_data_plausibility( + data = data, + settings = settings, + verbose = verbose, + cl = cl + ) # Load experiment data ------------------------------------------------------- if (!is.null(experiment_data)) { @@ -206,36 +282,40 @@ summon_familiar <- function( # Write experiment data to the file system experiment_data <- load_experiment_data( experiment_data, - file_paths = file_paths) + file_paths = file_paths + ) # Force the use of existing experiment data. settings$data$exp_design <- .get_iteration_file_name( project_id = experiment_data@project_id, - file_paths = file_paths) + file_paths = file_paths + ) } - rm(experiment_data) - # Experimental setup and settings -------------------------------------------- # Derive experimental design experiment_setup <- extract_experimental_setup( experimental_design = settings$data$exp_design, file_dir = file_paths$iterations_dir, - verbose = verbose) + verbose = verbose + ) # Check experiment settings settings <- .update_experimental_design_settings( section_table = experiment_setup, data = data, - settings = settings) + settings = settings, + verbose = verbose + ) # Import remaining settings settings <- .parse_general_settings( config = config, data = data, settings = settings, - ...) + ... + ) # Create a generic outcome object outcome_info <- create_outcome_info(settings = settings) @@ -246,7 +326,8 @@ summon_familiar <- function( data = data, experiment_setup = experiment_setup, settings = settings, - verbose = verbose) + verbose = verbose + ) # In case the iterations are loaded from a iterations file provided by the # user, perform some checks on the experimental design given the current data @@ -260,18 +341,18 @@ summon_familiar <- function( settings <- .update_experimental_design_settings( section_table = experiment_setup, data = data, - settings = settings) + settings = settings, + verbose = verbose + ) } - # Backend and parallellisation ----------------------------------------------- + # Update the number of runs based on the iteration list. + experiment_setup <- .set_experimental_design_n_runs( + section_table = experiment_setup, + iteration_list = project_info$iter_list + ) - # Identify if an external cluster is provided, and required. - if (settings$run$parallel) { - is_external_cluster <- inherits(cl, "cluster") - - } else { - is_external_cluster <- FALSE - } + # Backend and parallellisation ----------------------------------------------- # Assign objects that should be accessible everywhere to the familiar global # environment. Note that .assign_data_to_backend will also start backend @@ -280,117 +361,155 @@ summon_familiar <- function( .assign_file_paths_to_global(file_paths = file_paths) .assign_project_info_to_global(project_info = project_info) .assign_outcome_info_to_global(outcome_info = outcome_info) - .assign_backend_options_to_global( - backend_type = settings$run$backend_type, - server_port = settings$run$server_port) .assign_data_to_backend( data = data, backend_type = settings$run$backend_type, - server_port = settings$run$server_port) + server_port = settings$run$server_port + ) - .assign_parallel_options_to_global( - is_external_cluster = is_external_cluster, - restart_cluster = settings$run$restart_cluster, - n_cores = settings$run$parallel_nr_cores, - cluster_type = settings$run$cluster_type) - - # Make sure that backend server will close after the process finishes. - on.exit( - shutdown_backend_server( - backend_type = settings$run$backend_type, - server_port = settings$run$server_port), - add = TRUE) - - if (settings$run$parallel && - !settings$run$restart_cluster && - !is_external_cluster) { - # Start local cluster in the overall process. - cl <- .restart_cluster(cl = NULL, assign = "all") - on.exit(.terminate_cluster(cl), add = TRUE) - - } else if (settings$run$parallel && - settings$run$restart_cluster && - !is_external_cluster) { - # Start processes locally. - cl <- waiver() - - } else if (settings$run$parallel && is_external_cluster) { - # Make sure that everything is present on the external cluster. + if (settings$run$parallel) { + # Make sure that everything is present on the cluster. cl <- .update_cluster(cl = cl, assign = "all") - - } else if (!settings$run$parallel) { - # No cluster is created when - cl <- NULL - } + } # Clean familiar environment on exit. This is run last to avoid cleaning up # the familiar environment prior to shutting down the socket server process. on.exit(.clean_familiar_environment(), add = TRUE) + + experiment_data <- set_experiment_data( + x = experiment_data, + project_id = project_info$project_id, + experiment_setup = experiment_setup, + iteration_list = project_info$iter_list + ) if (.stop_after %in% c("setup")) { - return(create_experiment_data( - project_id = project_info$project_id, - experiment_setup = experiment_setup, - iteration_list = project_info$iter_list)) + return(experiment_data) + } + + # Setup tasks + if (.stop_after == "training") { + tasks <- .generate_trainer_tasks( + experiment_data = experiment_data, + optimisation_determine_vimp = settings$hpo$hpo_determine_vimp, + vimp_methods = settings$vimp$vimp_methods, + learners = settings$mb$learners, + file_paths = file_paths + ) + + } else if (.stop_after == "vimp") { + tasks <- .generate_vimp_tasks( + experiment_data = experiment_data, + vimp_methods = settings$vimp$vimp_methods, + file_paths = file_paths + ) + + } else if (.stop_after == "preprocessing") { + tasks <- c( + .generate_vimp_data_preprocessing_tasks( + experiment_data = experiment_data, + file_paths = file_paths + ), + .generate_learner_data_preprocessing_tasks( + experiment_data = experiment_data, + file_paths = file_paths + ) + ) + + } else { + tasks <- .generate_evaluation_tasks( + experiment_data = experiment_data, + optimisation_determine_vimp = settings$hpo$hpo_determine_vimp, + vimp_methods = settings$vimp$vimp_methods, + learners = settings$mb$learners, + pool_only = settings$eval$pool_only, + file_paths = file_paths + ) } + + # Select and sort unique tasks. + tasks <- .sort_tasks(tasks) # Pre-processing ------------------------------------------------------------- - feature_info <- NULL - - # Start pre-processing - run_preprocessing( + .run_preprocessing( cl = cl, - feature_info_list = feature_info, - project_info = project_info, + tasks = tasks, + experiment_data = experiment_data, settings = settings, + outcome_info = outcome_info, file_paths = file_paths, - verbose = verbose) + verbose = verbose + ) # Check if the process should be stopped at this point. if (.stop_after %in% c("preprocessing")) { - return(create_experiment_data( - project_id = project_info$project_id, - experiment_setup = experiment_setup, - iteration_list = project_info$iter_list, + return(set_experiment_data( + x = experiment_data, feature_info = get_feature_info_from_backend( data_id = waiver(), - run_id = waiver()))) + run_id = waiver() + ) + )) } # Variable importance -------------------------------------------------------- - - # Start feature selection - run_feature_selection( + .run_variable_importance_computation( cl = cl, - project_list = project_info, + tasks = tasks, + experiment_data = experiment_data, settings = settings, + outcome_info = outcome_info, file_paths = file_paths, - verbose = verbose) + verbose = verbose + ) # Check if the process should be stopped at this point. if (.stop_after %in% c("vimp")) { - return(create_experiment_data( - project_id = project_info$project_id, - experiment_setup = experiment_setup, - iteration_list = project_info$iter_list, - feature_info = get_feature_info_from_backend( + feature_info <- NULL + if (!is_empty(tasks$feature_info)) { + feature_info <- get_feature_info_from_backend( data_id = waiver(), - run_id = waiver()), - vimp_table_list = .retrieve_feature_selection_data( - fs_method = settings$fs$fs_method, - project_list = project_info, - file_paths = file_paths))) + run_id = waiver() + ) + } + + vimp_hyperparameters <- NULL + if (!is_empty(tasks$hyperparameters_vimp)) { + vimp_hyperparameters <- lapply( + tasks$hyperparameters_vimp, + function(x) readRDS(x@file) + ) + } + + vimp_tables <- NULL + if (!is_empty(tasks$vimp)) { + vimp_tables <- lapply( + tasks$vimp, + function(x) readRDS(x@file) + ) + } + + experiment_data <- set_experiment_data( + x = experiment_data, + feature_info = feature_info, + vimp_hyperparameter_list = vimp_hyperparameters, + vimp_table_list = vimp_tables + ) + + return(experiment_data) } # Training ------------------------------------------------------------------- - # Start model building - run_model_development( + .run_learner( cl = cl, - project_list = project_info, + tasks = tasks, + experiment_data = experiment_data, settings = settings, + outcome_info = outcome_info, file_paths = file_paths, - verbose = verbose) + verbose = verbose + ) # Check if the process should be stopped at this point. if (.stop_after %in% c("training")) { @@ -399,25 +518,34 @@ summon_familiar <- function( # Explanation and evaluation ------------------------------------------------- - # Start evaluation - run_evaluation( + .run_evaluation( cl = cl, - project_list = project_info, + tasks = tasks, + experiment_data = experiment_data, settings = settings, + outcome_info = outcome_info, file_paths = file_paths, - verbose = verbose) + verbose = verbose + ) - if (file_paths$is_temporary) { - # Collect all familiarModels, familiarEnsemble, familiarData and - # familiarCollection objects. - familiar_list <- .import_all_familiar_objects(file_paths = file_paths) - - # Return list with objects - return(familiar_list) - - } else { - return(invisible(TRUE)) + # Check if the process should be stopped at this point. + if (.stop_after %in% c("evaluation") || file_paths$is_temporary) { + return(.import_all_familiar_objects(file_paths = file_paths)) + } + + # Export --------------------------------------------------------------------- + + .run_export( + tasks = tasks, + file_paths = file_paths, + verbose = verbose + ) + + if (.force_output) { + return(.import_all_familiar_objects(file_paths = file_paths)) } + + return(invisible(TRUE)) } @@ -428,10 +556,12 @@ summon_familiar <- function( #' #' @param experimental_design (**required**) Defines what the experiment looks #' like, e.g. `cv(bt(fs,20)+mb,3,2)` for 2 times repeated 3-fold -#' cross-validation with nested feature selection on 20 bootstraps and -#' model-building. The basic workflow components are: +#' cross-validation with nested variable importance computation on 20 +#' bootstraps and model-building. The basic workflow components are: #' -#' * `fs`: (required) feature selection step. +#' * `fs`: (optional) variable importance computation step. If not explicitly +#' declared, feature selection will be done just in time for hyperparameter +#' optimisation. #' #' * `mb`: (required) model building step. #' @@ -476,7 +606,7 @@ summon_familiar <- function( #' training set. #' #' @inheritParams summon_familiar -#' @inheritParams .parse_feature_selection_settings +#' @inheritParams .parse_variable_importance_settings #' @inheritDotParams .parse_experiment_settings -config #' @inheritDotParams .parse_setup_settings -config #' @inheritDotParams .parse_preprocessing_settings -config -data -parallel @@ -500,14 +630,15 @@ precompute_data_assignment <- function( cl = NULL, experimental_design = "fs+mb", verbose = TRUE, - ...) { + ... +) { # Isolate dots. dots <- list(...) - # Drop skip_evaluation_elements, fs_method and learner if present. + # Drop skip_evaluation_elements, vimp_method and learner if present. dots$skip_evaluation_elements <- NULL - dots$fs_method <- NULL + dots$vimp_method <- NULL dots$learner <- NULL # Summon a familiar and compute everything up to variable importance data. @@ -520,12 +651,15 @@ precompute_data_assignment <- function( "experiment_data" = experiment_data, "cl" = cl, "experimental_design" = experimental_design, - "fs_method" = "none", + "vimp_method" = "none", "learner" = "glm", "skip_evaluation_elements" = "all", "verbose" = verbose, - ".stop_after" = "setup"), - dots)) + ".stop_after" = "setup" + ), + dots + ) + ) # Extract familiar models. return(experiment_data) @@ -540,10 +674,12 @@ precompute_data_assignment <- function( #' #' @param experimental_design (**required**) Defines what the experiment looks #' like, e.g. `cv(bt(fs,20)+mb,3,2)` for 2 times repeated 3-fold -#' cross-validation with nested feature selection on 20 bootstraps and -#' model-building. The basic workflow components are: +#' cross-validation with nested variable importance computation on 20 +#' bootstraps and model-building. The basic workflow components are: #' -#' * `fs`: (required) feature selection step. +#' * `fs`: (optional) variable importance computation step. If not explicitly +#' declared, feature selection will be done just in time for hyperparameter +#' optimisation. #' #' * `mb`: (required) model building step. #' @@ -590,7 +726,7 @@ precompute_data_assignment <- function( #' This argument is ignored if the `experiment_data` argument is set. #' #' @inheritParams summon_familiar -#' @inheritParams .parse_feature_selection_settings +#' @inheritParams .parse_variable_importance_settings #' @inheritDotParams .parse_experiment_settings -config #' @inheritDotParams .parse_setup_settings -config #' @inheritDotParams .parse_preprocessing_settings -config -data -parallel @@ -614,14 +750,15 @@ precompute_feature_info <- function( cl = NULL, experimental_design = "fs+mb", verbose = TRUE, - ...) { + ... +) { # Isolate dots. dots <- list(...) - # Drop skip_evaluation_elements, fs_method and learner if present. + # Drop skip_evaluation_elements, vimp_method and learner if present. dots$skip_evaluation_elements <- NULL - dots$fs_method <- NULL + dots$vimp_method <- NULL dots$learner <- NULL # Summon a familiar and compute everything up to variable importance data. @@ -634,12 +771,15 @@ precompute_feature_info <- function( "experiment_data" = experiment_data, "cl" = cl, "experimental_design" = experimental_design, - "fs_method" = "none", + "vimp_method" = "none", "learner" = "glm", "skip_evaluation_elements" = "all", "verbose" = verbose, - ".stop_after" = "preprocessing"), - dots)) + ".stop_after" = "preprocessing" + ), + dots + ) + ) # Extract familiar models. return(experiment_data) @@ -654,10 +794,13 @@ precompute_feature_info <- function( #' #' @param experimental_design (**required**) Defines what the experiment looks #' like, e.g. `cv(bt(fs,20)+mb,3,2)` for 2 times repeated 3-fold -#' cross-validation with nested feature selection on 20 bootstraps and -#' model-building. The basic workflow components are: +#' cross-validation with nested variable importance computation on 20 +#' bootstraps and model-building. The basic workflow components are: #' -#' * `fs`: (required) feature selection step. +#' * `fs`: (required) variable importance computation step. No variable +#' importances will be prepared if this step is not explicitly used, instead, +#' feature selection will be done just in time for hyperparameter +#' optimisation. #' #' * `mb`: (required) model building step. Though models are not learned by #' `precompute_vimp`, this element is still required to prevent issues when @@ -701,13 +844,11 @@ precompute_feature_info <- function( #' This argument is ignored if the `experiment_data` argument is set. #' #' @inheritParams summon_familiar -#' @inheritParams .parse_feature_selection_settings +#' @inheritParams .parse_variable_importance_settings #' @inheritDotParams .parse_experiment_settings -config #' @inheritDotParams .parse_setup_settings -config -#' @inheritDotParams .parse_preprocessing_settings -config -data -parallel -#' -outcome_type -#' @inheritDotParams .parse_feature_selection_settings -#' parallel_feature_selection +#' @inheritDotParams .parse_preprocessing_settings -config -data -parallel -outcome_type +#' @inheritDotParams .parse_variable_importance_settings -parallel_vimp #' #' @details This is a thin wrapper around `summon_familiar`, and functions like #' it, but automatically skips learning and subsequent evaluation steps. @@ -728,34 +869,37 @@ precompute_vimp <- function( experiment_data = NULL, cl = NULL, experimental_design = "fs+mb", - fs_method = NULL, - fs_method_parameter = NULL, + vimp_method = NULL, + vimp_method_parameter = NULL, verbose = TRUE, - ...) { + ... +) { # Check that a single learner is present. - fs_method <- .parse_arg( + vimp_method <- .parse_arg( x_config = NULL, - x_var = fs_method, - var_name = "fs_method", + x_var = vimp_method, + var_name = "vimp_method", type = "character_list", - optional = FALSE) + optional = FALSE + ) # Hyperparameters may be interpreted as belonging to the specified learner. - fs_method_parameter <- .parse_arg( + vimp_method_parameter <- .parse_arg( x_config = NULL, - x_var = fs_method_parameter, - var_name = "fs_method_parameter", + x_var = vimp_method_parameter, + var_name = "vimp_method_parameter", type = "list", optional = TRUE, - default = list()) + default = list() + ) # Encode hyperparameter as expected by parsing it to a nested list. - if (length(fs_method_parameter) > 0 && length(fs_method) == 1) { - if (is.null(fs_method_parameter[[fs_method]])) { - fs_method_parameter_list <- list() - fs_method_parameter_list[[fs_method]] <- fs_method_parameter - fs_method_parameter <- fs_method_parameter_list + if (length(vimp_method_parameter) > 0L && length(vimp_method) == 1L) { + if (is.null(vimp_method_parameter[[vimp_method]])) { + vimp_method_parameter_list <- list() + vimp_method_parameter_list[[vimp_method]] <- vimp_method_parameter + vimp_method_parameter <- vimp_method_parameter_list } } @@ -776,13 +920,16 @@ precompute_vimp <- function( "experiment_data" = experiment_data, "cl" = cl, "experimental_design" = experimental_design, - "fs_method" = fs_method, - "fs_method_parameter" = fs_method_parameter, + "vimp_method" = vimp_method, + "vimp_method_parameter" = vimp_method_parameter, "learner" = "glm", "skip_evaluation_elements" = "all", "verbose" = verbose, - ".stop_after" = "vimp"), - dots)) + ".stop_after" = "vimp" + ), + dots + ) + ) # Extract familiar models. return(experiment_data) @@ -796,10 +943,12 @@ precompute_vimp <- function( #' #' @param experimental_design (**required**) Defines what the experiment looks #' like, e.g. `cv(bt(fs,20)+mb,3,2)` for 2 times repeated 3-fold -#' cross-validation with nested feature selection on 20 bootstraps and -#' model-building. The basic workflow components are: +#' cross-validation with nested variable importance computation on 20 +#' bootstraps and model-building. The basic workflow components are: #' -#' * `fs`: (required) feature selection step. +#' * `fs`: (optional) variable importance computation step. If not explicitly +#' declared, feature selection will be done just in time for hyperparameter +#' optimisation. #' #' * `mb`: (required) model building step. #' @@ -836,8 +985,8 @@ precompute_vimp <- function( #' As shown in the example above, sampling algorithms can be nested. #' #' The simplest valid experimental design is `fs+mb`. This is the default in -#' `train_familiar`, and will create one model for each feature selection -#' method in `fs_method`. To create more models, a subsampling method should +#' `train_familiar`, and will create one model for each variable importance +#' method in `vimp_method`. To create more models, a subsampling method should #' be introduced, e.g. `bs(fs+mb,20)` to create 20 models based on bootstraps #' of the data. #' @@ -866,7 +1015,7 @@ precompute_vimp <- function( #' @inheritDotParams .parse_experiment_settings -config #' @inheritDotParams .parse_setup_settings -config #' @inheritDotParams .parse_preprocessing_settings -config -data -parallel -outcome_type -#' @inheritDotParams .parse_feature_selection_settings -config -data -parallel -outcome_type +#' @inheritDotParams .parse_variable_importance_settings -config -data -parallel -outcome_type #' @inheritDotParams .parse_model_development_settings -config -data -parallel -outcome_type #' @inheritDotParams .parse_hyperparameter_optimisation_settings -config -parallel -outcome_type #' @@ -886,7 +1035,8 @@ train_familiar <- function( learner = NULL, hyperparameter = NULL, verbose = TRUE, - ...) { + ... +) { # Check that a single learner is present. learner <- .parse_arg( @@ -894,7 +1044,8 @@ train_familiar <- function( x_var = learner, var_name = "learner", type = "character", - optional = FALSE) + optional = FALSE + ) # Hyperparameters may be interpreted as belonging to the specified learner. hyperparameter <- .parse_arg( @@ -903,10 +1054,11 @@ train_familiar <- function( var_name = "hyperparameter", type = "list", optional = TRUE, - default = list()) + default = list() + ) # Encode hyperparameter as expected by parsing it to a nested list. - if (length(hyperparameter) > 0 && is.null(hyperparameter[[learner]])) { + if (length(hyperparameter) > 0L && is.null(hyperparameter[[learner]])) { hyperparameter_list <- list() hyperparameter_list[[learner]] <- hyperparameter hyperparameter <- hyperparameter_list @@ -923,7 +1075,7 @@ train_familiar <- function( # Summon a familiar. familiar_models <- do.call( summon_familiar, - args = (c( + args = c( list( "formula" = formula, "data" = data, @@ -936,8 +1088,11 @@ train_familiar <- function( "project_dir" = NULL, "skip_evaluation_elements" = "all", "verbose" = verbose, - ".stop_after" = "training"), - dots))) + ".stop_after" = "training" + ), + dots + ) + ) # Extract familiar models. return(familiar_models) @@ -947,20 +1102,25 @@ train_familiar <- function( .is_absolute_path <- function(x) { return(dir.exists(paste0( - unlist(strsplit(x, split = .Platform$file.sep))[1], - .Platform$file.sep))) + unlist(strsplit(x, split = .Platform$file.sep))[1L], + .Platform$file.sep + ))) } -.load_configuration_file <- function(config, config_id = 1) { +.load_configuration_file <- function(config, config_id = 1L) { if (!is.null(config)) { if (is.character(config)) { - if (length(config) > 1) { - stop(paste0( - "Configuration: the path to the configuration file is expected ", - "to be a single character string. Multiple strings were found.")) + if (length(config) > 1L) { + ..error( + paste0( + "Configuration: the path to the configuration file is expected ", + "to be a single character string. Multiple strings were found." + ), + error_class = "input_argument_error" + ) } # Normalise file paths @@ -970,12 +1130,12 @@ train_familiar <- function( require_package("xml2", "to configure familiar using a configuration file") # Read xml file, parse to list and remove comments - config <- xml2::as_list(xml2::read_xml(config))[[1]][[config_id]] + config <- xml2::as_list(xml2::read_xml(config))[[1L]][[config_id]] config <- .clean_configuration_comments(config = config) } else { if (!is.list(config) || !is.recursive(config)) { - stop("Configuration: the input configuration data is not a list of lists.") + ..error("Configuration: the input configuration data is not a list of lists.") } } } else { @@ -996,7 +1156,7 @@ train_familiar <- function( if (is.list(conf_list)) { # Retain only those list entries that are not comments "[ comment ]". - conf_list <- Filter(Negate(function(x) ((is.character(x[1]) & x[1] == "[ comment ]"))), conf_list) + conf_list <- Filter(Negate(function(x) ((is.character(x[1L]) & x[1L] == "[ comment ]"))), conf_list) # Go one level deeper by applying this function to the list entries of the current list conf_list <- lapply(conf_list, cleaning_cycle) @@ -1039,7 +1199,8 @@ get_xml_config <- function(dir_path) { file.copy( from = system.file("config.xml", package = "familiar"), to = dir_path, - overwrite = FALSE) + overwrite = FALSE + ) return(invisible(TRUE)) } @@ -1051,7 +1212,8 @@ get_xml_config <- function(dir_path) { assign( x = "settings", value = settings, - envir = familiar_global_env) + envir = familiar_global_env + ) return(invisible(TRUE)) } @@ -1069,14 +1231,14 @@ get_settings <- function() { data_env <- .GlobalEnv } else { - stop("Settings not found in backend.") + ..error("Settings not found in backend.") } } else if (exists("settings", where = .GlobalEnv)) { data_env <- .GlobalEnv } else { - stop("Settings not found in backend.") + ..error("Settings not found in backend.") } return(get("settings", envir = data_env)) @@ -1089,7 +1251,8 @@ get_settings <- function() { assign( x = "file_paths", value = file_paths, - envir = familiar_global_env) + envir = familiar_global_env + ) return(invisible(TRUE)) } @@ -1107,14 +1270,14 @@ get_file_paths <- function() { data_env <- .GlobalEnv } else { - stop("File paths were not found in backend.") + ..error("File paths were not found in backend.") } } else if (exists("file_paths", where = .GlobalEnv)) { data_env <- .GlobalEnv } else { - stop("File paths were not found in backend.") + ..error("File paths were not found in backend.") } return(get("file_paths", envir = data_env)) @@ -1127,7 +1290,8 @@ get_file_paths <- function() { assign( x = "project_info_list", value = project_info, - envir = familiar_global_env) + envir = familiar_global_env + ) return(invisible(TRUE)) } @@ -1145,19 +1309,20 @@ get_project_list <- function() { data_env <- .GlobalEnv } else { - stop("Project list not found in backend.") + ..error("Project list not found in backend.") } } else if (exists("project_info_list", where = .GlobalEnv)) { data_env <- .GlobalEnv } else { - stop("Project list not found in backend.") + ..error("Project list not found in backend.") } return(get("project_info_list", envir = data_env)) } + .import_all_familiar_objects <- function(file_paths) { familiar_list <- list() @@ -1165,50 +1330,24 @@ get_project_list <- function() { model_files <- list.files( path = file_paths$mb_dir, pattern = "model.RDS", - recursive = TRUE) - model_files <- sapply( - model_files, - function(x, dir_path) (file.path(dir_path, x)), - dir_path = file_paths$mb_dir) - - # Load familiarModel files and add to list + full.names = TRUE + ) familiar_list$familiarModel <- load_familiar_object(model_files) - # Find familiarEnsemble files - ensemble_files <- list.files( - path = file_paths$mb_dir, - pattern = "ensemble.RDS", - recursive = TRUE) - ensemble_files <- sapply( - ensemble_files, - function(x, dir_path) (file.path(dir_path, x)), - dir_path = file_paths$mb_dir) - - # Load familiarEnsemble files and add to list - familiar_list$familiarEnsemble <- load_familiar_object(ensemble_files) - # Find familiarData files data_files <- list.files( path = file_paths$fam_data_dir, - pattern = "data.RDS") - data_files <- sapply( - data_files, - function(x, dir_path) (file.path(dir_path, x)), - dir_path = file_paths$fam_data_dir) - - # Load familiarData files and add to list + pattern = "data.RDS", + full.names = TRUE + ) familiar_list$familiarData <- load_familiar_object(data_files) # Find familiarCollection files coll_files <- list.files( path = file_paths$fam_coll_dir, - pattern = "ensemble_data_|pooled_data.RDS") - coll_files <- sapply( - coll_files, - function(x, dir_path) (file.path(dir_path, x)), - dir_path = file_paths$fam_coll_dir) - - # Load familiarCollection files and add to list + pattern = "collection.RDS", + full.names = TRUE + ) familiar_list$familiarCollection <- load_familiar_object(coll_files) return(familiar_list) @@ -1221,7 +1360,8 @@ get_project_list <- function() { if (exists("familiar_global_env")) { rm( list = ls(envir = familiar_global_env), - envir = familiar_global_env) + envir = familiar_global_env + ) } return(invisible(TRUE)) diff --git a/R/FamiliarCollection.R b/R/FamiliarCollection.R index ea4a317d..00769ee9 100644 --- a/R/FamiliarCollection.R +++ b/R/FamiliarCollection.R @@ -4,8 +4,6 @@ NULL - - # set_data_set_names ----------------------------------------------------------- #' @title Name datasets for plotting and export @@ -42,14 +40,16 @@ setMethod( x, old = NULL, new = NULL, - order = NULL) { + order = NULL + ) { x <- .set_labels( x = x, old_label = old, new_label = new, new_order = order, - upd_slot = "data_set_labels") + upd_slot = "data_set_labels" + ) return(x) } @@ -85,14 +85,16 @@ setMethod( x, old = NULL, new = NULL, - order = NULL) { + order = NULL + ) { x <- .set_labels( x = x, old_label = old, new_label = new, new_order = order, - upd_slot = "learner_labels") + upd_slot = "learner_labels" + ) return(x) } @@ -100,43 +102,45 @@ setMethod( -# set_fs_method_names ---------------------------------------------------------- +# set_vimp_method_names ---------------------------------------------------------- -#' @title Rename feature selection methods for plotting and export +#' @title Rename variable importance methods for plotting and export #' #' @description Tabular exports and figures created from a familiarCollection -#' object can be customised by providing names for the feature selection +#' object can be customised by providing names for the variable importance #' methods. #' -#' @details Labels convert the internal naming for feature selection methods to -#' the requested label at export or when plotting. This enables the use of +#' @details Labels convert the internal naming for variable importance methods +#' to the requested label at export or when plotting. This enables the use of #' more specific naming, e.g. changing \code{mim} to \code{Mutual Information #' Maximisation}. Currently assigned labels can be found using the -#' \code{get_fs_method_names} method. +#' \code{get_vimp_method_names} method. #' #' @inheritParams set_data_set_names,familiarCollection-method #' @return A familiarCollection object with updated labels. #' @export -#' @aliases set_fs_method_names +#' @aliases set_vimp_method_names #' @seealso * \linkS4class{familiarCollection} for information concerning the -#' familiarCollection class. * \code{\link{get_fs_method_names}} for obtaining +#' familiarCollection class. * \code{\link{get_vimp_method_names}} for obtaining #' currently assigned labels. #' @md setMethod( - "set_fs_method_names", + "set_vimp_method_names", signature(x = "familiarCollection"), function( x, old = NULL, new = NULL, - order = NULL) { + order = NULL + ) { x <- .set_labels( x = x, old_label = old, new_label = new, new_order = order, - upd_slot = "fs_method_labels") + upd_slot = "vimp_method_labels" + ) return(x) } @@ -171,14 +175,16 @@ setMethod( x, old = NULL, new = NULL, - order = NULL) { + order = NULL + ) { x <- .set_labels( x = x, old_label = old, new_label = new, new_order = order, - upd_slot = "feature_labels") + upd_slot = "feature_labels" + ) return(x) } @@ -214,14 +220,16 @@ setMethod( x, old = NULL, new = NULL, - order = NULL) { + order = NULL + ) { x <- .set_labels( x = x, old_label = old, new_label = new, new_order = order, - upd_slot = "km_group_labels") + upd_slot = "km_group_labels" + ) return(x) } @@ -256,14 +264,16 @@ setMethod( x, old = NULL, new = NULL, - order = NULL) { + order = NULL + ) { x <- .set_labels( x = x, old_label = old, new_label = new, new_order = order, - upd_slot = "class_labels") + upd_slot = "class_labels" + ) return(x) } @@ -299,7 +309,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "data_set_labels", - get_levels = FALSE)) + get_levels = FALSE + )) } ) @@ -333,42 +344,44 @@ setMethod( return(.get_labels( x = x, upd_slot = "learner_labels", - get_levels = FALSE)) + get_levels = FALSE + )) } ) -# get_fs_method_names ---------------------------------------------------------- +# get_vimp_method_names ---------------------------------------------------------- -#' @title Get current feature selection method name labels -#' -#' @description Feature selection methods in familiarCollection objects can have -#' custom names for export and plotting. This function retrieves the currently -#' assigned names. +#' @title Get current variable importance method name labels #' -#' @details Labels convert internal naming of feature selection methods to the +#' @description Variable importance methods in familiarCollection objects can +#' have custom names for export and plotting. This function retrieves the +#' currently assigned names. +#' +#' @details Labels convert internal naming of variable importance methods to the #' requested label at export or when plotting. Labels can be changed using the -#' \code{set_fs_method_names} method. +#' \code{set_vimp_method_names} method. #' #' @inheritParams get_data_set_names,familiarCollection-method #' -#' @return An ordered array of feature selection method name labels. +#' @return An ordered array of variable importance method name labels. #' @export -#' @aliases get_fs_method_names +#' @aliases get_vimp_method_names #' @seealso #' * \linkS4class{familiarCollection} for information concerning the familiarCollection class. -#' * \code{\link{set_fs_method_names}} for updating the name of feature selection methods and their ordering. +#' * \code{\link{set_vimp_method_names}} for updating the name of variable importance methods and their ordering. #' @md setMethod( - "get_fs_method_names", + "get_vimp_method_names", signature(x = "familiarCollection"), function(x) { return(.get_labels( x = x, - upd_slot = "fs_method_labels", - get_levels = FALSE)) + upd_slot = "vimp_method_labels", + get_levels = FALSE + )) } ) @@ -402,7 +415,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "feature_labels", - get_levels = FALSE)) + get_levels = FALSE + )) } ) @@ -437,7 +451,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "km_group_labels", - get_levels = FALSE)) + get_levels = FALSE + )) } ) @@ -472,7 +487,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "class_labels", - get_levels = FALSE)) + get_levels = FALSE + )) } ) @@ -487,7 +503,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "data_set_labels", - get_levels = TRUE)) + get_levels = TRUE + )) } ) @@ -502,22 +519,24 @@ setMethod( return(.get_labels( x = x, upd_slot = "learner_labels", - get_levels = TRUE)) + get_levels = TRUE + )) } ) -# get_fs_method_name_levels ---------------------------------------------------- +# get_vimp_method_name_levels ---------------------------------------------------- setMethod( - "get_fs_method_name_levels", + "get_vimp_method_name_levels", signature(x = "familiarCollection"), function(x) { return(.get_labels( x = x, - upd_slot = "fs_method_labels", - get_levels = TRUE)) + upd_slot = "vimp_method_labels", + get_levels = TRUE + )) } ) @@ -532,7 +551,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "feature_labels", - get_levels = TRUE)) + get_levels = TRUE + )) } ) @@ -547,7 +567,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "km_group_labels", - get_levels = TRUE)) + get_levels = TRUE + )) } ) @@ -562,7 +583,8 @@ setMethod( return(.get_labels( x = x, upd_slot = "class_labels", - get_levels = TRUE)) + get_levels = TRUE + )) } ) @@ -585,7 +607,8 @@ setMethod( "save", signature( list = "familiarCollection", - file = "character"), + file = "character" + ), function(list, file) { .save(object = list, dir_path = file) } @@ -599,7 +622,8 @@ setMethod( signature(object = "familiarCollection"), function( object, - abbreviated = FALSE) { + abbreviated = FALSE + ) { # Get the full name of the object object_name <- object@name @@ -622,11 +646,13 @@ setMethod( # Create an initial descriptor. cat(paste0( "A collection of datasets (", object@name, "; ", - .familiar_version_string(object), "):\n")) + .familiar_version_string(object), "):\n" + )) lapply( object@data_sets, - function(x) cat(paste0(" ", x, "\n"))) + function(x) cat(paste0(" ", x, "\n")) + ) # Outcome details cat("\nThe collection contains data for the following outcome:\n") @@ -645,7 +671,8 @@ setMethod( old_label, new_label, new_order, - upd_slot) { + upd_slot + ) { # Suppress NOTES due to non-standard evaluation in data.table label <- NULL @@ -668,13 +695,16 @@ setMethod( if (!is.null(new_label)) { # Check that the length of new_label is not 0 - if (length(new_label) == 0) { - stop("The number of \"new\" labels should be larger than 0.") + if (length(new_label) == 0L) { + ..error( + "The number of \"new\" labels should be larger than 0.", + error_class = "input_argument_error" + ) } # Check for duplicates in new_label if (anyDuplicated(new_label)) { - warning("The \"new\" labels contain duplicate values.") + ..warning("The \"new\" labels contain duplicate values.") } # Get old labels, if they were not provided. @@ -682,9 +712,13 @@ setMethod( # Check if we can safely assume that the new labels are matching if (length(new_label) != nrow(label_table)) { - stop(paste0( - "If \"old\" is not provided explicitly, \"new\" should have the ", - "same length as the currently existing labels.")) + ..error( + paste0( + "If \"old\" is not provided explicitly, \"new\" should have the ", + "same length as the currently existing labels." + ), + error_class = "input_argument_error" + ) } # Assume that old is the currently known label @@ -693,33 +727,45 @@ setMethod( # Check for duplicates in old_label if (anyDuplicated(old_label)) { - stop("The provided \"old\" labels contain duplicate values.") + ..error( + "The provided \"old\" labels contain duplicate values.", + error_class = "input_argument_error" + ) } # Check that length of new_label and old_label are the same if (length(new_label) != length(old_label)) { - stop("The same number of \"old\" and \"new\" labels should be provided.") + ..error( + "The same number of \"old\" and \"new\" labels should be provided.", + error_class = "input_argument_error" + ) } # Check if all old_label entries are actually existing labels. unrecognised_labels <- old_label[!old_label %in% label_table$label] - if (length(unrecognised_labels) > 0) { - stop(paste0( - "The following old labels were not found: ", - paste_s(unrecognised_labels))) + if (length(unrecognised_labels) > 0L) { + ..error( + paste0( + "The following old labels were not found: ", + paste_s(unrecognised_labels) + ), + error_class = "input_argument_error" + ) } # Generate a data.table using old_label and new_label replacement_table <- data.table::data.table( "label" = old_label, - "new_label" = new_label) + "new_label" = new_label + ) # Merge both tables label_table <- merge( x = label_table, y = replacement_table, by = "label", - all.x = TRUE) + all.x = TRUE + ) # Copy old labels to the new_label column for labels that were not # provided previously @@ -729,7 +775,8 @@ setMethod( data.table::setnames( x = label_table, old = c("label", "new_label"), - new = c("old_label", "label")) + new = c("old_label", "label") + ) # Drop the "old_label" column as it is no longer required label_table[, "old_label" := NULL] @@ -741,34 +788,46 @@ setMethod( # Check that new_order has the same length as the label_table if (length(new_order) != length(unique(label_table$label))) { - stop("\"order\" should match the number of labels.") + ..error( + "\"order\" should match the number of labels.", + error_class = "input_argument_error" + ) } # Check that there are no duplicates in new_order. if (anyDuplicated(new_order)) { - warning("\"order\" contains duplicate entries.") + ..warning("\"order\" contains duplicate entries.") } # Check that new_order has the same class the label. if (!is_any(new_order, class(label_table$label))) { - stop(paste0( - "\"order should have the same class as the label, i.e. ", - paste(class(label_table$label), collapse = " or "), ".")) + ..error( + paste0( + "\"order\" should have the same class as the label, i.e. ", + paste(class(label_table$label), collapse = " or "), "." + ), + error_class = "input_argument_error" + ) } # Check that there are no elements of new_order that do not appear as a label unrecognised_labels <- new_order[!new_order %in% label_table$label] - if (length(unrecognised_labels) > 0) { - stop(paste0( - "The following labels were not found for ordering: ", - paste_s(unrecognised_labels))) + if (length(unrecognised_labels) > 0L) { + ..error( + paste0( + "The following labels were not found for ordering: ", + paste_s(unrecognised_labels) + ), + error_class = "input_argument_error" + ) } # Find the order by matching the label column in the label table with the # provided labels in new_order new_label_order <- match( label_table$label, - new_order) + new_order + ) # Update the label order label_table[, "label_order" := new_label_order] @@ -800,31 +859,38 @@ setMethod( } else if (upd_slot == "learner_labels") { data <- slot(x, "learner") - } else if (upd_slot == "fs_method_labels") { - data <- slot(x, "fs_method") + } else if (upd_slot == "vimp_method_labels") { + data <- slot(x, "vimp_method") } else if (upd_slot == "feature_labels") { data <- unique(c( slot(x, "required_features"), - x@fs_vimp$vimp_table$name)) + x@fs_vimp$vimp_table$name + )) } else if (upd_slot == "km_group_labels") { - data <- unique(c( - "low", "moderate", "high", - unlist(lapply(x@km_data, function(x) (levels(x@data$risk_group)))))) + data <- unique(unlist(lapply(x@km_data, function(x) (levels(x@data$group))))) + if (all(data %in% c("low", "moderate", "high"))) { + # Standard labels for 2 or three groups. + data <- c("low", "moderate", "high") + } else { + # Custom labels are sorted alphabetically. + data <- sort(data) + } } else if (upd_slot == "class_labels") { data <- get_outcome_class_levels(x) } else { - stop("Slot is not available for familiarCollection objects.") + ..error("Slot is not available for familiarCollection objects.") } # Add the new label table to the slot slot(x, upd_slot) <- data.table::data.table( "internal" = data, "label" = data, - "label_order" = seq_len(length(data))) + "label_order" = seq_along(data) + ) return(x) } @@ -839,7 +905,8 @@ setMethod( function( x, upd_slot, - get_levels = FALSE) { + get_levels = FALSE + ) { # Get ordered levels (i.e. internal column from the label table) from the # specific slot diff --git a/R/FamiliarCollectionExport.R b/R/FamiliarCollectionExport.R index 3e762aa8..1d14baa0 100644 --- a/R/FamiliarCollectionExport.R +++ b/R/FamiliarCollectionExport.R @@ -17,7 +17,7 @@ NULL #'@param aggregate_results Flag that signifies whether results should be #' aggregated for export. #' -#'@inheritDotParams extract_data +#'@inheritDotParams .extract_data #'@inheritDotParams as_familiar_collection #' #'@details Data, such as model performance and calibration information, is @@ -38,7 +38,15 @@ NULL #'@rdname export_all-methods setGeneric( "export_all", - function(object, dir_path = NULL, aggregate_results = waiver(), ...) standardGeneric("export_all")) + function( + object, + dir_path = NULL, + aggregate_results = waiver(), + ... + ) { + standardGeneric("export_all") + } +) ## export_all (collection) ----------------------------------------------------- @@ -51,7 +59,8 @@ setMethod( object, dir_path = NULL, aggregate_results = waiver(), - ...) { + ... + ) { if (is.waive(aggregate_results)) aggregate_results <- TRUE @@ -61,121 +70,150 @@ setMethod( # Export feature selection variable importance fs_vimp <- export_fs_vimp( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export feature selection variable importance using stability. fs_vimp_occurrence <- export_fs_vimp( object = object, dir_path = dir_path, - aggregation_method = "stability") + aggregation_method = "stability" + ) # Export model variable importance model_vimp <- export_model_vimp( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export model variable importance using stability. model_vimp_occurrence <- export_model_vimp( object = object, dir_path = dir_path, - aggregation_method = "stability") + aggregation_method = "stability" + ) # Export permutation variable importance. permutation_vimp <- export_permutation_vimp( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) # Export model hyperparameters hyperparameters <- export_hyperparameters( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) # Export prediction tables prediction_data <- export_prediction_data( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export decision curve analysis data dca_data <- export_decision_curve_analysis_data( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) # Export calibration information calibration_info <- export_calibration_info( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export calibration data calibration_data <- export_calibration_data( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) # Export model performance model_performance <- export_model_performance( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) # Export confusion matrix confusion_matrix <- export_confusion_matrix_data( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export kaplan-meier info km_info <- export_risk_stratification_info( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export stratification data km_data <- export_risk_stratification_data( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export AUC data auc_data <- export_auc_data( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) # Export data from the univariate analysis univariate_analysis <- export_univariate_analysis_data( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export data from feature expressions feature_expressions <- export_feature_expressions( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export mutual-correlation data feature_similarity <- export_feature_similarity( object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Export partial dependence data pd_data <- export_partial_dependence_data( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) # Export individual conditional expectation data ice_data <- export_ice_data( object = object, dir_path = dir_path, - aggregate_results = aggregate_results) + aggregate_results = aggregate_results + ) + + # Export SHAP data. + shap_data <- export_shap( + object = object, + dir_path = dir_path, + aggregate_results = aggregate_results + ) if (is.null(dir_path)) { return(list( "fs_vimp" = list( "default" = fs_vimp, - "occurrence" = fs_vimp_occurrence), + "occurrence" = fs_vimp_occurrence + ), "model_vimp" = list( "default" = model_vimp, - "occurrence" = model_vimp_occurrence), + "occurrence" = model_vimp_occurrence + ), "permutation_vimp" = permutation_vimp, "hyperparameters" = hyperparameters, "prediction_data" = prediction_data, @@ -191,7 +229,9 @@ setMethod( "feature_expressions" = feature_expressions, "feature_similarity" = feature_similarity, "pd_data" = pd_data, - "ice_data" = ice_data)) + "ice_data" = ice_data, + "shap_data" = shap_data + )) } } ) @@ -208,7 +248,8 @@ setMethod( object, dir_path = NULL, aggregate_results = waiver(), - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -216,8 +257,11 @@ setMethod( args = c( list( "object" = object, - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_all, @@ -225,8 +269,11 @@ setMethod( list( "object" = object, "dir_path" = dir_path, - "aggregate_results" = aggregate_results), - list(...)))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + )) } ) @@ -240,25 +287,28 @@ setMethod( signature( data = "familiarDataElement", object = "familiarCollection", - dir_path = "character"), + dir_path = "character" + ), function( data, object, dir_path, type, - subtype = NULL) { + subtype = NULL + ) { if (is_empty(data)) return(NULL) # Check if any identifiers remain, and add to the subtype. - if (length(data@identifiers) > 0) subtype <- c(subtype, unlist(data@identifiers)) + if (length(data@identifiers) > 0L) subtype <- c(subtype, unlist(data@identifiers)) return(.export_to_file( data = data@data, object = object, dir_path = dir_path, type = type, - subtype = subtype)) + subtype = subtype + )) } ) @@ -269,13 +319,15 @@ setMethod( signature( data = "list", object = "familiarCollection", - dir_path = "character"), + dir_path = "character" + ), function( data, object, dir_path, type, - subtype = NULL) { + subtype = NULL + ) { # Check if data exists if (is_empty(data)) return(NULL) @@ -286,7 +338,8 @@ setMethod( object = object, dir_path = dir_path, type = type, - subtype = subtype)) + subtype = subtype + )) } ) @@ -298,23 +351,25 @@ setMethod( signature( data = "data.table", object = "familiarCollection", - dir_path = "character"), + dir_path = "character" + ), function( data, object, dir_path, type, - subtype = NULL) { + subtype = NULL + ) { # Check if data exists. if (is_empty(data)) return(NULL) # Check if directory exists. - file_dir <- normalizePath(file.path(dir_path, object@name, type), mustWork = FALSE) + file_dir <- normalizePath(file.path(dir_path, type), mustWork = FALSE) if (!dir.exists(file_dir)) dir.create(file_dir, recursive = TRUE) # Generate file name. - if (length(subtype) == 0) { + if (length(subtype) == 0L) { base_file_name <- type } else { @@ -328,7 +383,8 @@ setMethod( x = data, file = file_name, sep = ";", - dec = ".") + dec = "." + ) return(invisible(NULL)) } @@ -342,23 +398,25 @@ setMethod( signature( data = "character", object = "familiarCollection", - dir_path = "character"), + dir_path = "character" + ), function( data, object, dir_path, type, - subtype = NULL) { + subtype = NULL + ) { # Check if data exists if (is_empty(data)) return(NULL) # Check if directory exists - file_dir <- normalizePath(file.path(dir_path, object@name, type), mustWork = FALSE) + file_dir <- normalizePath(file.path(dir_path, type), mustWork = FALSE) if (!dir.exists(file_dir)) dir.create(file_dir, recursive = TRUE) # Generate file name - if (length(subtype) == 0) { + if (length(subtype) == 0L) { base_file_name <- type } else { @@ -372,7 +430,8 @@ setMethod( x = data, file = file_name, append = FALSE, - sep = ifelse(.Platform$OS.type == "windows", "\r\n", "\n")) + sep = ifelse(.Platform$OS.type == "windows", "\r\n", "\n") + ) return(NULL) } @@ -387,7 +446,8 @@ setMethod( ".apply_labels", signature( data = "familiarDataElement", - object = "familiarCollection"), + object = "familiarCollection" + ), function(data, object) { # Return NULL for empty input @@ -405,14 +465,14 @@ setMethod( # Determine whether certain columns are present. has_data_set <- "data_set" %in% columns has_learner <- "learner" %in% columns - has_fs_method <- "fs_method" %in% columns - has_feature <- any(c("name", "feature_name_1", "feature_name_2", "feature") %in% columns) - has_risk_group <- any(c("risk_group", "risk_group_1", "risk_group_2", "reference_group") %in% columns) - has_multiclass_outcome <- any(c("pos_class", "positive_class", "outcome") %in% columns) && + has_vimp_method <- "vimp_method" %in% columns + has_feature <- any(c("name", "feature_name", "feature_name_1", "feature_name_2", "feature", "feature_x", "feature_y") %in% columns) + has_risk_group <- any(c("reference_group", "group", "group_1", "group_2") %in% columns) + has_multiclass_outcome <- any(c("pos_class", "positive_class", "outcome", "shap_outcome") %in% columns) && object@outcome_type == "multinomial" has_categorical_outcome <- any(c("observed_outcome", "expected_outcome") %in% columns) && object@outcome_type %in% c("binomial", "multinomial") - has_evaluation_time <- any(c("evaluation_time", "eval_time") %in% columns) && + has_evaluation_time <- any(c("evaluation_time", "eval_time", "shap_outcome") %in% columns) && object@outcome_type %in% c("survival", "competing_risk") has_performance_metric <- any(c("metric") %in% columns) has_model_name <- any(c("ensemble_model_name", "model_name") %in% columns) @@ -425,7 +485,9 @@ setMethod( value = factor( x = x$data_set, levels = get_data_set_name_levels(x = object), - labels = get_data_set_names(x = object))) + labels = get_data_set_names(x = object) + ) + ) } if (has_learner) { @@ -435,22 +497,25 @@ setMethod( value = factor( x = x$learner, levels = get_learner_name_levels(x = object), - labels = get_learner_names(x = object))) + labels = get_learner_names(x = object) + ) + ) } - if (has_fs_method) { + if (has_vimp_method) { data.table::set( x, - j = "fs_method", + j = "vimp_method", value = factor( - x = x$fs_method, - levels = get_fs_method_name_levels(x = object), - labels = get_fs_method_names(x = object))) + x = x$vimp_method, + levels = get_vimp_method_name_levels(x = object), + labels = get_vimp_method_names(x = object) + ) + ) } if (has_feature) { - for (current_column_name in c( - "name", "feature_name_1", "feature_name_2", "feature")) { + for (current_column_name in c("name", "feature_name", "feature_name_1", "feature_name_2", "feature", "feature_x", "feature_y")) { if (!is.null(x[[current_column_name]])) { # Check if all feature names are actually in the object. Some features @@ -463,7 +528,9 @@ setMethod( value = factor( x = x[[current_column_name]], levels = get_feature_name_levels(x = object), - labels = get_feature_names(x = object))) + labels = get_feature_names(x = object) + ) + ) } else { data.table::set( @@ -471,7 +538,9 @@ setMethod( j = current_column_name, value = factor( x = x[[current_column_name]], - levels = unique(x[[current_column_name]]))) + levels = unique(x[[current_column_name]]) + ) + ) } } } @@ -479,7 +548,8 @@ setMethod( if (has_risk_group) { for (current_column_name in c( - "risk_group", "risk_group_1", "risk_group_2", "reference_group")) { + "reference_group", "group", "group_1", "group_2" + )) { if (!is.null(x[[current_column_name]])) { data.table::set( @@ -488,14 +558,15 @@ setMethod( value = factor( x = x[[current_column_name]], levels = get_risk_group_name_levels(x = object), - labels = get_risk_group_names(x = object))) + labels = get_risk_group_names(x = object) + ) + ) } } } if (has_multiclass_outcome) { - for (current_column_name in c( - "pos_class", "positive_class", "outcome")) { + for (current_column_name in c("pos_class", "positive_class", "outcome", "shap_outcome")) { if (!is.null(x[[current_column_name]])) { data.table::set( @@ -504,15 +575,16 @@ setMethod( value = factor( x = x[[current_column_name]], levels = get_class_name_levels(x = object), - labels = get_class_names(x = object))) + labels = get_class_names(x = object) + ) + ) } } } if (has_categorical_outcome) { # For confusion matrices. - for (current_column_name in c( - "observed_outcome", "expected_outcome")) { + for (current_column_name in c("observed_outcome", "expected_outcome")) { if (!is.null(x[[current_column_name]])) { data.table::set( @@ -521,14 +593,15 @@ setMethod( value = factor( x = x[[current_column_name]], levels = get_class_name_levels(x = object), - labels = get_class_names(x = object))) + labels = get_class_names(x = object) + ) + ) } } } if (has_evaluation_time) { - for (current_column_name in c( - "evaluation_time", "eval_time")) { + for (current_column_name in c("evaluation_time", "eval_time", "shap_outcome")) { if (!is.null(x[[current_column_name]])) { data.table::set( @@ -536,7 +609,9 @@ setMethod( j = current_column_name, value = factor( x = x[[current_column_name]], - levels = sort(unique(x[[current_column_name]])))) + levels = sort(unique(x[[current_column_name]])) + ) + ) } } } @@ -549,21 +624,24 @@ setMethod( j = current_column_name, value = factor( x = x[[current_column_name]], - levels = sort(unique(x[[current_column_name]])))) + levels = sort(unique(x[[current_column_name]])) + ) + ) } } } if (has_model_name) { - for (current_column_name in c( - "ensemble_model_name", "model_name")) { + for (current_column_name in c("ensemble_model_name", "model_name")) { if (!is.null(x[[current_column_name]])) { data.table::set( x, j = current_column_name, value = factor( x = x[[current_column_name]], - levels = sort(unique(x[[current_column_name]])))) + levels = sort(unique(x[[current_column_name]])) + ) + ) } } } @@ -572,12 +650,13 @@ setMethod( # columns appear on the right. First we identify the grouping # columns. Note that not all grouping_columns <- c( - "data_set", "fs_method", "learner", + "data_set", "vimp_method", "learner", "ensemble_model_name", "model_name", "evaluation_time", "eval_time", - "name", "feature_name_1", "feature_name_2", "feature", + "name", "feature_name", "feature_name_1", "feature_name_2", "feature", "pos_class", "positive_class", - "metric") + "metric" + ) # Find the grouping columns actually present grouping_columns <- intersect(grouping_columns, columns) @@ -592,7 +671,8 @@ setMethod( # Order columns. data.table::setcolorder( x = x, - neworder = c(grouping_columns, remaining_columns, value_columns)) + neworder = c(grouping_columns, remaining_columns, value_columns) + ) # Drop unused levels. x <- droplevels(x) @@ -611,13 +691,15 @@ setMethod( ".apply_labels", signature( data = "list", - object = "familiarCollection"), + object = "familiarCollection" + ), function(data, object) { return(lapply( data, .apply_labels, - object = object)) + object = object + )) } ) @@ -628,7 +710,8 @@ setMethod( ".apply_labels", signature( data = "ANY", - object = "familiarCollection"), + object = "familiarCollection" + ), function(data, object) { # This is the fall-back option for empty data. diff --git a/R/FamiliarData.R b/R/FamiliarData.R index 353a18dc..54111b1e 100644 --- a/R/FamiliarData.R +++ b/R/FamiliarData.R @@ -13,28 +13,20 @@ setMethod( object <- update_object(object = object) # Create an initial descriptor. - data_str <- paste0( + cat(paste0( "A dataset (", object@name, "; ", - .familiar_version_string(object), ")") - - # Add the generating ensemble, if available. - if (length(object@generating_ensemble) > 0) { - data_str <- paste0( - data_str, " created using ", - object@generating_ensemble, ".\n") - - } else { - data_str <- paste0(data_str, ".\n") - } - cat(data_str) + .familiar_version_string(object), + ").\n" + )) # Details concerning the generating ensemble. cat(paste0( "\nThe ensemble that created this dataset contained of one or more ", object@learner, " models with variable importance computed by the ", - object@fs_method, - " variable importance method.\n")) + object@vimp_method, + " variable importance method.\n" + )) # Outcome details cat("\nThe following outcome was modelled:\n") @@ -49,7 +41,8 @@ setMethod( "save", signature( list = "familiarData", - file = "character"), + file = "character" + ), function(list, file) { .save(object = list, dir_path = file) } @@ -57,54 +50,6 @@ setMethod( -# get_object_name (familiarData) ----------------------------------------------- -setMethod( - "get_object_name", - signature(object = "familiarData"), - function(object, abbreviated = FALSE) { - - # Extract data and run id - ensemble_data_id <- tail(object@pooling_table, n = 1L)$ensemble_data_id - ensemble_run_id <- tail(object@pooling_table, n = 1L)$ensemble_run_id - pool_data_id <- tail(object@pooling_table, n = 1L)$pool_data_id - pool_run_id <- tail(object@pooling_table, n = 1L)$pool_run_id - - data_pooling <- ifelse( - tail(object@pooling_table, n = 1L)$data_perturb_level == - tail(object@pooling_table, n = 1L)$pool_perturb_level, - "ensemble", - "pool") - - if (abbreviated) { - # Create an abbreviated name - object_name <- paste( - data_pooling, - ensemble_data_id, - ensemble_run_id, - ifelse(object@is_validation, "validation", "development"), - "data", - sep = ".") - - } else { - # Create the full name of the object - object_name <- get_object_file_name( - learner = object@learner, - fs_method = object@fs_method, - project_id = object@project_id, - data_id = ensemble_data_id, - run_id = ensemble_run_id, - pool_data_id = pool_data_id, - pool_run_id = pool_run_id, - object_type = "familiarData", - is_ensemble = data_pooling == "ensemble", - is_validation = object@is_validation, - with_extension = FALSE) - } - - return(object_name) - } -) - # add_package_version (familiarData) ------------------------------------------- @@ -125,25 +70,28 @@ setMethod( "add_identifiers", signature( data = "ANY", - object = "familiarData"), + object = "familiarData" + ), function( data, object, - more_identifiers = NULL) { + more_identifiers = NULL + ) { # Adds identifying columns to a table if (is_empty(data)) return(NULL) if (!inherits(data, "data.table")) { - stop("\"data\" should be a data.table.") + ..error_reached_unreachable_code("\"data\" should be a data.table.") } # Check which identifiers should be added if (is.null(more_identifiers)) { - if (!all(more_identifiers %in% c("fs_method", "learner"))) { - stop(paste0( - "Only feature selection methods (\"fs_method\") and learners (\"learner\") ", - "can be added as additional identifiers.")) + if (!all(more_identifiers %in% c("vimp_method", "learner"))) { + ..error_reached_unreachable_code(paste0( + "Only variable importance methods (\"vimp_method\") and learners (\"learner\") ", + "can be added as additional identifiers." + )) } } id_order <- c("data_set", more_identifiers) @@ -156,28 +104,26 @@ setMethod( # Insert "model_name" column data[, "data_set" := data_set] - if (any(id_order == "fs_method")) data[, "fs_method" := object@fs_method] + if (any(id_order == "vimp_method")) data[, "vimp_method" := object@vimp_method] if (any(id_order == "learner")) data[, "learner" := object@learner] # Reorder columns and move model_name to the front - data.table::setcolorder( - data, - neworder = id_order) + data.table::setcolorder(data, neworder = id_order) return(data) } else { # In case the table is empty, return an empty table with the model name # attached. - empty_table <- data.table::data.table("data_set" = character(0)) + empty_table <- data.table::data.table("data_set" = character(0L)) - if (any(id_order == "fs_method")) { - empty_table[, "fs_method" := character(0)] + if (any(id_order == "vimp_method")) { + empty_table[, "vimp_method" := character(0L)] } if (any(id_order == "learner")) { - empty_table[, "learner" := character(0)] + empty_table[, "learner" := character(0L)] } return(cbind(empty_table, data)) @@ -203,14 +149,15 @@ setMethod( signature(x = "familiarData"), function(x, new = NULL) { - if (x@project_id == 0 && is.null(new)) { + 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 chracters 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)) + "_", rstring(n = 20L) + ) } else if (is.null(new)) { # Generate a sensible object name. diff --git a/R/FamiliarDataComputation.R b/R/FamiliarDataComputation.R index ee34a56e..2e23ee98 100644 --- a/R/FamiliarDataComputation.R +++ b/R/FamiliarDataComputation.R @@ -3,175 +3,146 @@ NULL -.get_available_data_elements <- function( - check_has_estimation_type = FALSE, - check_has_detail_level = FALSE, - check_has_sample_limit = FALSE) { - - # All data elements. - all_data_elements <- c( - "auc_data", "calibration_data", "calibration_info", "confusion_matrix", - "decision_curve_analyis", "feature_expressions", - "fs_vimp", "hyperparameters", "model_performance", - "model_vimp", "permutation_vimp", "prediction_data", - "risk_stratification_data", "risk_stratification_info", - "univariate_analysis", "feature_similarity", "sample_similarity", "ice_data") - - # Data elements that allow setting an estimation type. - can_set_estimation_type <- c( - "auc_data", "calibration_data", "decision_curve_analyis", - "model_performance", "permutation_vimp", "prediction_data", "ice_data") - - # Data elements that allow setting a detail level. - can_set_detail_level <- c( - can_set_estimation_type, "calibration_info", "confusion_matrix", - "risk_stratification_data", "risk_stratification_info") - - # Data elements that allow for setting an estimation type but not detail - # level. - can_set_estimation_type <- c(can_set_estimation_type, "feature_similarity") - - # Data elements that allow for setting a sample limit. - can_set_sample_limit <- c("sample_similarity", "ice_data") - - if (check_has_sample_limit) { - all_data_elements <- intersect(all_data_elements, can_set_sample_limit) - } - - if (check_has_estimation_type) { - all_data_elements <- intersect(all_data_elements, can_set_estimation_type) - } - - if (check_has_detail_level) { - all_data_elements <- intersect(all_data_elements, can_set_detail_level) - } - - return(all_data_elements) -} - - - -.parse_detail_level <- function( - x, - object, - default, - data_element) { - - if (is.waive(x)) x <- object@settings$detail_level - - if (is.null(x)) return(default) - - # detail level is stored in a list, by data_element. - if (is.list(x)) x <- x[[data_element]] - - if (is.null(x)) return(default) - - .check_parameter_value_is_valid( - x = x, - var_name = "detail_level", - values = c("ensemble", "hybrid", "model")) - - return(x) -} +# extract_data (generic) ------------------------------------------------------- +setGeneric( + "extract_data", + function(object, ...) standardGeneric("extract_data") +) -.parse_estimation_type <- function( - x, +# extract_data (familiarEnsemble) ---------------------------------------------- +setMethod( + "extract_data", + signature(object = "familiarEnsemble"), + function( object, - default, - data_element, - detail_level, - has_internal_bootstrap) { - - # Change to default to point if the detail_level is model. - if (detail_level == "model") default <- "point" - - # In case there is no internal bootstrap, we can only determine point - # estimates for ensemble and model detail levels (but potentially more for - # hybrid). - if (!has_internal_bootstrap && - detail_level %in% c("ensemble", "model") && - default != "point") { - default <- "point" + data, + data_element = waiver(), + is_pre_processed = FALSE, + dynamic_model_loading = FALSE, + ... + ) { + # Generates a familiarData object from the ensemble. + + if (is.waive(data_element)) data_element <- .get_available_data_elements() + + # Check the data_element argument. + if (length(data_element) > 0L) { + .check_parameter_value_is_valid( + x = data_element, + var_name = "data_element", + values = .get_available_data_elements() + ) + } + + # Check the dynamic_model_loading argument because it is used here. + .check_parameter_value_is_valid( + x = dynamic_model_loading, + var_name = "dynamic_model_loading", + values = c(FALSE, TRUE) + ) + + # Set auto-detach here. Note that, if TRUE, load_models may reset it to + # FALSE if models cannot be detached. + object@auto_detach <- dynamic_model_loading + + # Check whether data is a dataObject, and create one otherwise. + if (!is(data, "dataObject")) { + data <- as_data_object( + data = data, + object = object, + check_stringency = "external_warn" + ) + + # Set pre-processing level. + data@preprocessing_level <- ifelse(is_pre_processed, "clustering", "none") + } + + # Load models, and drop any models that were not trained. + object <- load_models(object = object, drop_untrained = TRUE) + + # Pass to .extract_data + return(.extract_data( + object = object, + data = data, + data_element = data_element, + ... + )) } - - if (is.waive(x)) x <- object@settings$estimation_type - - if (is.null(x)) return(default) - - # detail level is stored in a list, by data_element. - if (is.list(x)) x <- x[[data_element]] - - if (is.null(x)) return(default) - - .check_parameter_value_is_valid( - x = x, - var_name = "estimation_type", - values = c( - "point", "bias_correction", "bc", - "bootstrap_confidence_interval", "bci")) - - return(x) -} - +) -.parse_aggregate_results <- function( - x, - object, - default, - data_element) { - - if (is.waive(x)) x <- object@settings$aggregate_results - - if (is.null(x)) return(default) - - # detail level is stored in a list, by data_element. - if (is.list(x)) x <- x[[data_element]] - - if (is.null(x)) return(default) - - x <- tolower(x) - .check_parameter_value_is_valid( - x = x, - var_name = "aggregate_results", - values = c("true", "false", "none", "all", "default")) - - if (x == "default") return(default) - if (x %in% c("true", "all")) return(TRUE) - - return(FALSE) -} +# extract_data (prediction table) ---------------------------------------------- +setMethod( + "extract_data", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + data_element = waiver(), + is_pre_processed = FALSE, + ... + ) { + # Generates a familiarData object from a prediction table. + + if (is.waive(data_element)) { + data_element <- .get_available_data_elements(check_from_prediction_table = TRUE) + } + + # Check the data_element argument. + if (length(data_element) > 0L) { + .check_parameter_value_is_valid( + x = data_element, + var_name = "data_element", + values = .get_available_data_elements(check_from_prediction_table = TRUE) + ) + } + + # Pass to .extract_data + return(.extract_data( + object = object, + data_element = data_element, + ... + )) + } +) -.parse_sample_limit <- function( - x, +# extract_data (dataObject) ---------------------------------------------------- +setMethod( + "extract_data", + signature(object = "dataObject"), + function( object, - default, - data_element) { - - if (is.waive(x)) x <- object@settings$sample_limit - - if (is.null(x)) return(default) - - # detail level is stored in a list, by data_element. - if (is.list(x)) x <- x[[data_element]] - - if (is.null(x)) return(default) - - if (x == "default") return(default) - - .check_number_in_valid_range( - x = x, - var_name = "sample_limit", - range = c(20L, Inf)) - - return(x) -} + data_element = waiver(), + is_pre_processed = TRUE, + ... + ) { + # Generates a familiarData object from a dataObject. + if (is.waive(data_element)) { + data_element <- .get_available_data_elements(check_from_data_object = TRUE) + } + + # Check the data_element argument. + if (length(data_element) > 0L) { + .check_parameter_value_is_valid( + x = data_element, + var_name = "data_element", + values = .get_available_data_elements(check_from_data_object = TRUE) + ) + } + + # Pass to .extract_data + return(.extract_data( + object = object, + data_element = data_element, + ... + )) + } +) + -# extract_data (generic) ------------------------------------------------------- #'@title Internal function to create a familiarData object. #' @@ -179,8 +150,9 @@ NULL #' from the provided dataset and `familiarEnsemble` object and store it as a #' `familiarData` object. #' -#'@param object A `familiarEnsemble` object, which is an ensemble of one or more -#' `familiarModel` objects. +#'@param object A `familiarEnsemble`, which is an ensemble of one or more +#' `familiarModel` objects, or a `familiarDataElementPredictionTable` object +#' that contains prediction data. #'@param data A `dataObject` object, `data.table` or `data.frame` that #' constitutes the data that are assessed. #'@param is_pre_processed Flag that indicates whether the data was already @@ -193,8 +165,8 @@ NULL #' index. If not provided explicitly, this parameter is read from settings used #' at creation of the underlying `familiarModel` objects. Only used for #' `survival` outcomes. -#'@param evaluation_times One or more time points that are used for in analysis of -#' survival problems when data has to be assessed at a set time, e.g. +#'@param evaluation_times One or more time points that are used for in analysis +#' of survival problems when data has to be assessed at a set time, e.g. #' calibration. If not provided explicitly, this parameter is read from #' settings used at creation of the underlying `familiarModel` objects. Only #' used for `survival` outcomes. @@ -225,7 +197,7 @@ NULL #' #' * `mean`: Use the mean of the predicted values as the ensemble value for a #' sample. -#' +#' #'@param metric One or more metrics for assessing model performance. See the #' vignette on performance metrics for the available metrics. If not provided #' explicitly, this parameter is read from settings used at creation of the @@ -334,54 +306,10 @@ NULL #' assessing rater reliability. Psychol. Bull. 86, 420–428 (1979). #'@md #'@keywords internal -setGeneric( - "extract_data", - function( - object, - data, - data_element = waiver(), - is_pre_processed = FALSE, - cl = NULL, - time_max = waiver(), - aggregation_method = waiver(), - rank_threshold = waiver(), - ensemble_method = waiver(), - stratification_method = waiver(), - evaluation_times = waiver(), - metric = waiver(), - feature_cluster_method = waiver(), - feature_cluster_cut_method = waiver(), - feature_linkage_method = waiver(), - feature_similarity_metric = waiver(), - feature_similarity_threshold = waiver(), - sample_cluster_method = waiver(), - sample_linkage_method = waiver(), - sample_similarity_metric = waiver(), - sample_limit = waiver(), - detail_level = waiver(), - estimation_type = waiver(), - aggregate_results = waiver(), - confidence_level = waiver(), - bootstrap_ci_method = waiver(), - icc_type = waiver(), - dynamic_model_loading = FALSE, - message_indent = 0L, - verbose = FALSE, - ...) { - standardGeneric("extract_data") - } -) - - - -# extract_data (familiarEnsemble) ---------------------------------------------- -setMethod( - "extract_data", - signature(object = "familiarEnsemble"), - function( +.extract_data <- function( object, - data, - data_element = waiver(), + data = NULL, + data_element, is_pre_processed = FALSE, cl = NULL, time_max = waiver(), @@ -400,393 +328,390 @@ setMethod( sample_linkage_method = waiver(), sample_similarity_metric = waiver(), sample_limit = waiver(), + n_important_features = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), confidence_level = waiver(), bootstrap_ci_method = waiver(), icc_type = waiver(), - dynamic_model_loading = FALSE, message_indent = 0L, verbose = FALSE, - ...) { - # Generates a familiarData object from the ensemble. - - if (is.waive(data_element)) data_element <- .get_available_data_elements() - - # Check the data_element argument. - if (length(data_element) > 0) { - .check_parameter_value_is_valid( - x = data_element, - var_name = "data_element", - values = .get_available_data_elements()) - } - - # Check the dynamic_model_loading argument because it is used here. - .check_parameter_value_is_valid( - x = dynamic_model_loading, - var_name = "dynamic_model_loading", - values = c(FALSE, TRUE)) + ... +) { + + ## Compute distance between features ----------------------------------------- + feature_similarity <- NULL + if (any(c("model_vimp", "feature_similarity", "univariate_analysis", + "feature_expressions", "permutation_vimp") %in% data_element)) { + # Not for the fs_vimp data elements. This is because the subset of + # features in the ensemble is generally smaller than that assessed within + # feature selection.. - # Set auto-detach here. Note that, if TRUE, load_models may reset it to - # FALSE if models cannot be detached. - object@auto_detach <- dynamic_model_loading - - # Check whether data is a dataObject, and create one otherwise. - if (!is(data, "dataObject")) { - data <- as_data_object( - data = data, - object = object, - check_stringency = "external_warn") - - # Set pre-processing level. - data@preprocessing_level <- ifelse(is_pre_processed, "clustering", "none") - } - - # Load models, and drop any models that were not trained. - object <- load_models( + # Compute a table containing the pairwise distance between features. + feature_similarity <- extract_feature_similarity( object = object, - drop_untrained = TRUE) - - ## Compute distance between features --------------------------------------- - feature_similarity <- NULL - if (any(c("model_vimp", "feature_similarity", "univariate_analysis", - "feature_expressions", "permutation_vimp") %in% data_element)) { - # Not for the fs_vimp data elements. This is because the subset of - # features in the ensemble is generally smaller than that assessed within - # feature selection.. - - # Compute a table containg the pairwise distance between features. - feature_similarity <- extract_feature_similarity( - object = object, - data = data, - cl = cl, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method, - is_pre_processed = is_pre_processed, - feature_cluster_method = feature_cluster_method, - feature_linkage_method = feature_linkage_method, - feature_cluster_cut_method = feature_cluster_cut_method, - feature_similarity_threshold = feature_similarity_threshold, - feature_similarity_metric = feature_similarity_metric, - verbose = verbose, - message_indent = message_indent) - } - - ## Compute distance between samples ---------------------------------------- - sample_similarity <- NULL - if (any(c("sample_similarity", "feature_expressions") %in% data_element)) { - - # Compute a table containing the pairwise distance between samples. - sample_similarity <- extract_sample_similarity( - object = object, - data = data, - cl = cl, - is_pre_processed = is_pre_processed, - sample_limit = sample_limit, - sample_similarity_metric = sample_similarity_metric, - sample_cluster_method = sample_cluster_method, - sample_linkage_method = sample_linkage_method, - verbose = verbose, - message_indent = message_indent) - } - - ## Aggregate feature selection variable importance ------------------------- - fs_vimp_info <- NULL - if (any(c("fs_vimp") %in% data_element)) { - fs_vimp_info <- extract_fs_vimp( - object = object, - aggregation_method = aggregation_method, - rank_threshold = rank_threshold, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute model-specific variable importance ------------------------------ - model_vimp_info <- NULL - if (any(c("model_vimp") %in% data_element)) { - model_vimp_info <- extract_model_vimp( - object = object, - data = data, - aggregation_method = aggregation_method, - rank_threshold = rank_threshold, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute permutation variable importance --------------------------------- - permutation_vimp <- NULL - if (any(c("permutation_vimp") %in% data_element)) { - permutation_vimp <- extract_permutation_vimp( - object = object, - data = data, - cl = cl, - feature_similarity = feature_similarity, - metric = metric, - ensemble_method = ensemble_method, - evaluation_times = evaluation_times, - detail_level = detail_level, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute feature expression heatmap -------------------------------------- - expression_info <- NULL - if (any(c("feature_expressions") %in% data_element)) { - expression_info <- extract_feature_expression( - object = object, - data = data, - feature_similarity = feature_similarity, - sample_similarity = sample_similarity, - feature_cluster_method = feature_cluster_method, - feature_linkage_method = feature_linkage_method, - feature_similarity_metric = feature_similarity_metric, - sample_cluster_method = sample_cluster_method, - sample_linkage_method = sample_linkage_method, - sample_similarity_metric = sample_similarity_metric, - evaluation_times = evaluation_times, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute univariate feature importance ----------------------------------- - univar_info <- NULL - if (any(c("univariate_analysis") %in% data_element)) { - univar_info <- extract_univariate_analysis( - object = object, - data = data, - cl = cl, - icc_type = icc_type, - feature_similarity = feature_similarity, - feature_cluster_method = feature_cluster_method, - feature_cluster_cut_method = feature_cluster_cut_method, - feature_linkage_method = feature_linkage_method, - feature_similarity_threshold = feature_similarity_threshold, - feature_similarity_metric = feature_similarity_metric, - message_indent = message_indent, - verbose = verbose) - } - - ## Aggregate model hyper-parameters ---------------------------------------- - hyperparameter_info <- NULL - if (any(c("hyperparameters") %in% data_element)) { - hyperparameter_info <- extract_hyperparameters( - object = object, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute model predictions ----------------------------------------------- - prediction_data <- NULL - if (any(c("prediction_data") %in% data_element)) { - prediction_data <- extract_predictions( - object = object, - data = data, - cl = cl, - ensemble_method = ensemble_method, - detail_level = detail_level, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - confidence_level = confidence_level, - evaluation_times = evaluation_times, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute model performance metrics --------------------------------------- - model_performance_data <- NULL - if (any(c("model_performance") %in% data_element)) { - model_performance_data <- extract_performance( - object = object, - data = data, - cl = cl, - metric = metric, - ensemble_method = ensemble_method, - evaluation_times = evaluation_times, - detail_level = detail_level, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute decision curve analysis data ------------------------------------ - decision_curve_data <- NULL - if (any(c("decision_curve_analyis") %in% data_element)) { - decision_curve_data <- extract_decision_curve_data( - object = object, - data = data, - cl = cl, - ensemble_method = ensemble_method, - evaluation_times = evaluation_times, - detail_level = detail_level, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method, - message_indent = message_indent, - verbose = verbose) - } - - ## Aggregate stratification data ------------------------------------------- - stratification_info <- NULL - if (any(c("risk_stratification_info") %in% data_element)) { - stratification_info <- extract_risk_stratification_info( - object = object, - detail_level = detail_level, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute risk group stratification --------------------------------------- - stratification_data <- NULL - if (any(c("risk_stratification_data") %in% data_element)) { - stratification_data <- extract_risk_stratification_data( - object = object, - data = data, - cl = cl, - ensemble_method = ensemble_method, - stratification_method = stratification_method, - detail_level = detail_level, - confidence_level = confidence_level, - message_indent = message_indent, - verbose = verbose) - } - - ## Aggregate calibration information --------------------------------------- - calibration_info <- NULL - if (any(c("calibration_info") %in% data_element)) { - calibration_info <- extract_calibration_info( - object = object, - detail_level = detail_level, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute calibration data ------------------------------------------------ - calibration_data <- NULL - if (any(c("calibration_data") %in% data_element)) { - calibration_data <- extract_calibration_data( - object = object, - data = data, - cl = cl, - ensemble_method = ensemble_method, - evaluation_times = evaluation_times, - detail_level = detail_level, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute AUC-ROC and AUC-PR ---------------------------------------------- - auc_data <- NULL - if (any(c("auc_data") %in% data_element)) { - auc_data <- extract_auc_data( - object = object, - data = data, - cl = cl, - ensemble_method = ensemble_method, - detail_level = detail_level, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - bootstrap_ci_method = bootstrap_ci_method, - confidence_level = confidence_level, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute confusion matrix ------------------------------------------------ - confusion_matrix_info <- NULL - if (any(c("confusion_matrix") %in% data_element)) { - confusion_matrix_info <- extract_confusion_matrix( - object = object, - data = data, - cl = cl, - ensemble_method = ensemble_method, - detail_level = detail_level, - message_indent = message_indent, - verbose = verbose) - } - - ## Compute individual conditional expectation ------------------------------ - ice_data <- NULL - if (any(c("ice_data") %in% data_element)) { - ice_data <- extract_ice( - object = object, - data = data, - cl = cl, - ensemble_method = ensemble_method, - evaluation_times = evaluation_times, - sample_limit = sample_limit, - detail_level = detail_level, - estimation_type = estimation_type, - aggregate_results = aggregate_results, - confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method, - is_pre_processed = is_pre_processed, - message_indent = message_indent, - verbose = verbose, - ...) - } - - - # Set up a placehold pooling table. This may need to be adapted. - pooling_table <- data.table::data.table( - "ensemble_data_id" = object@run_table$ensemble_data_id, - "ensemble_run_id" = object@run_table$ensemble_run_id, - "data_perturb_level" = ifelse(is.na(data@perturb_level), 0, data@perturb_level), - "pool_data_id" = 0L, - "pool_run_id" = 0, - "pool_perturb_level" = 0) + data = data, + cl = cl, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method, + is_pre_processed = is_pre_processed, + feature_cluster_method = feature_cluster_method, + feature_linkage_method = feature_linkage_method, + feature_cluster_cut_method = feature_cluster_cut_method, + feature_similarity_threshold = feature_similarity_threshold, + feature_similarity_metric = feature_similarity_metric, + verbose = verbose, + message_indent = message_indent + ) + } + + ## Compute distance between samples ---------------------------------------- + sample_similarity <- NULL + if (any(c("sample_similarity", "feature_expressions") %in% data_element)) { - # Create a familiarData object - fam_data <- methods::new( - "familiarData", - outcome_type = object@outcome_type, - outcome_info = object@outcome_info, - fs_vimp = fs_vimp_info, - model_vimp = model_vimp_info, - permutation_vimp = permutation_vimp, - hyperparameters = hyperparameter_info, - hyperparameter_data = NULL, - required_features = object@required_features, - model_features = object@model_features, - learner = object@learner, - fs_method = object@fs_method, - pooling_table = pooling_table, - prediction_data = prediction_data, - confusion_matrix = confusion_matrix_info, - decision_curve_data = decision_curve_data, - calibration_info = calibration_info, - calibration_data = calibration_data, - model_performance = model_performance_data, - km_info = stratification_info, - km_data = stratification_data, - auc_data = auc_data, - univariate_analysis = univar_info, - feature_expressions = expression_info, + # Compute a table containing the pairwise distance between samples. + sample_similarity <- extract_sample_similarity( + object = object, + data = data, + cl = cl, + is_pre_processed = is_pre_processed, + sample_limit = sample_limit, + sample_similarity_metric = sample_similarity_metric, + sample_cluster_method = sample_cluster_method, + sample_linkage_method = sample_linkage_method, + verbose = verbose, + message_indent = message_indent + ) + } + + ## Aggregate feature selection variable importance ------------------------- + fs_vimp_info <- NULL + if (any(c("fs_vimp") %in% data_element)) { + fs_vimp_info <- extract_fs_vimp( + object = object, + aggregation_method = aggregation_method, + rank_threshold = rank_threshold, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute model-specific variable importance ------------------------------ + model_vimp_info <- NULL + if (any(c("model_vimp") %in% data_element)) { + model_vimp_info <- extract_model_vimp( + object = object, + data = data, + aggregation_method = aggregation_method, + rank_threshold = rank_threshold, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute permutation variable importance --------------------------------- + permutation_vimp <- NULL + if (any(c("permutation_vimp") %in% data_element)) { + permutation_vimp <- extract_permutation_vimp( + object = object, + data = data, + cl = cl, + feature_similarity = feature_similarity, + metric = metric, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + n_important_features = n_important_features, + sample_limit = sample_limit, + detail_level = detail_level, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute feature expression heatmap -------------------------------------- + expression_info <- NULL + if (any(c("feature_expressions") %in% data_element)) { + expression_info <- extract_feature_expression( + object = object, + data = data, feature_similarity = feature_similarity, sample_similarity = sample_similarity, - ice_data = ice_data, - is_validation = data@load_validation, - generating_ensemble = get_object_name(object = object, abbreviated = FALSE), - project_id = object@project_id) - - # Add package version to the data set - fam_data <- add_package_version(object = fam_data) + feature_cluster_method = feature_cluster_method, + feature_linkage_method = feature_linkage_method, + feature_similarity_metric = feature_similarity_metric, + sample_cluster_method = sample_cluster_method, + sample_linkage_method = sample_linkage_method, + sample_similarity_metric = sample_similarity_metric, + evaluation_times = evaluation_times, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute univariate feature importance ----------------------------------- + univar_info <- NULL + if (any(c("univariate_analysis") %in% data_element)) { + univar_info <- extract_univariate_analysis( + object = object, + data = data, + cl = cl, + icc_type = icc_type, + feature_similarity = feature_similarity, + feature_cluster_method = feature_cluster_method, + feature_cluster_cut_method = feature_cluster_cut_method, + feature_linkage_method = feature_linkage_method, + feature_similarity_threshold = feature_similarity_threshold, + feature_similarity_metric = feature_similarity_metric, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Aggregate model hyper-parameters ---------------------------------------- + hyperparameter_info <- NULL + if (any(c("hyperparameters") %in% data_element)) { + hyperparameter_info <- extract_hyperparameters( + object = object, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute model predictions ----------------------------------------------- + prediction_data <- NULL + if (any(c("prediction_data") %in% data_element)) { + prediction_data <- extract_predictions( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + detail_level = detail_level, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + confidence_level = confidence_level, + evaluation_times = evaluation_times, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute model performance metrics --------------------------------------- + model_performance_data <- NULL + if (any(c("model_performance") %in% data_element)) { + model_performance_data <- extract_performance( + object = object, + data = data, + cl = cl, + metric = metric, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + detail_level = detail_level, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute decision curve analysis data ------------------------------------ + decision_curve_data <- NULL + if (any(c("decision_curve_analyis") %in% data_element)) { + decision_curve_data <- extract_decision_curve_data( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + detail_level = detail_level, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Aggregate stratification data ------------------------------------------- + stratification_info <- NULL + if (any(c("risk_stratification_info") %in% data_element)) { + stratification_info <- extract_risk_stratification_info( + object = object, + detail_level = detail_level, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute risk group stratification --------------------------------------- + stratification_data <- NULL + if (any(c("risk_stratification_data") %in% data_element)) { + stratification_data <- extract_risk_stratification_data( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + stratification_method = stratification_method, + detail_level = detail_level, + confidence_level = confidence_level, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + ## Aggregate calibration information --------------------------------------- + calibration_info <- NULL + if (any(c("calibration_info") %in% data_element)) { + calibration_info <- extract_calibration_info( + object = object, + detail_level = detail_level, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute calibration data ------------------------------------------------ + calibration_data <- NULL + if (any(c("calibration_data") %in% data_element)) { + calibration_data <- extract_calibration_data( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + detail_level = detail_level, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute AUC-ROC and AUC-PR ---------------------------------------------- + auc_data <- NULL + if (any(c("auc_data") %in% data_element)) { + auc_data <- extract_auc_data( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + detail_level = detail_level, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + bootstrap_ci_method = bootstrap_ci_method, + confidence_level = confidence_level, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute confusion matrix ------------------------------------------------ + confusion_matrix_info <- NULL + if (any(c("confusion_matrix") %in% data_element)) { + confusion_matrix_info <- extract_confusion_matrix( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + detail_level = detail_level, + message_indent = message_indent, + verbose = verbose + ) + } + + ## Compute individual conditional expectation ------------------------------ + ice_data <- NULL + if (any(c("ice_data") %in% data_element)) { + ice_data <- extract_ice( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + sample_limit = sample_limit, + n_important_features = n_important_features, + detail_level = detail_level, + estimation_type = estimation_type, + aggregate_results = aggregate_results, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method, + is_pre_processed = is_pre_processed, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + ## Compute SHAP values for features ------------------------------------------ + shap_data <- NULL + if ("shap" %in% data_element) { - # Return data - return(fam_data) + shap_data <- extract_shap( + object = object, + data = data, + cl = cl, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + sample_limit = sample_limit, + detail_level = detail_level, + aggregate_results = aggregate_results, + n_important_features = n_important_features, + is_pre_processed = is_pre_processed, + verbose = verbose, + message_indent = message_indent, + ... + ) } -) + + # Set up outcome information object. + outcome_info <- .create_outcome_info(object) + + # Create a familiarData object + fam_data <- methods::new( + "familiarData", + outcome_type = object@outcome_type, + outcome_info = outcome_info, + fs_vimp = fs_vimp_info, + model_vimp = model_vimp_info, + permutation_vimp = permutation_vimp, + hyperparameters = hyperparameter_info, + hyperparameter_data = NULL, + required_features = .optional_from_slot(object, "required_features", alternative = NULL), + model_features = .optional_from_slot(object, "model_features", alternative = NULL), + learner = .optional_from_slot(object, "learner", alternative = "none"), + vimp_method = .optional_from_slot(object, "vimp_method", alternative = "none"), + prediction_data = prediction_data, + confusion_matrix = confusion_matrix_info, + decision_curve_data = decision_curve_data, + calibration_info = calibration_info, + calibration_data = calibration_data, + model_performance = model_performance_data, + km_info = stratification_info, + km_data = stratification_data, + auc_data = auc_data, + univariate_analysis = univar_info, + feature_expressions = expression_info, + feature_similarity = feature_similarity, + sample_similarity = sample_similarity, + ice_data = ice_data, + shap_data = shap_data + ) + + # Add package version to the data set + fam_data <- add_package_version(object = fam_data) + + # Return data + return(fam_data) +} diff --git a/R/FamiliarDataComputationAUCCurves.R b/R/FamiliarDataComputationAUCCurves.R index 52583183..006d259f 100644 --- a/R/FamiliarDataComputationAUCCurves.R +++ b/R/FamiliarDataComputationAUCCurves.R @@ -1,5 +1,6 @@ #' @include FamiliarS4Generics.R #' @include FamiliarS4Classes.R +#' @include PredictionTable.R NULL # familiarDataElementAUCCurve object definition -------------------------------- @@ -9,7 +10,9 @@ setClass( contains = "familiarDataElement", prototype = methods::prototype( value_column = "y", - grouping_column = "x")) + grouping_column = "x" + ) +) @@ -19,7 +22,7 @@ setClass( #' #'@description Computes the ROC curve from a `familiarEnsemble`. #'' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@details This function also computes credibility intervals for the ROC curve #' for the ensemble model, at the level of `confidence_level`. In the case of @@ -47,14 +50,15 @@ setGeneric( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_auc_data") } ) -#extract_auc_data (familiarEnsemble) ------------------------------------------- +# extract_auc_data (familiarEnsemble) ------------------------------------------ setMethod( "extract_auc_data", signature(object = "familiarEnsemble"), @@ -71,7 +75,8 @@ setMethod( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # Extract data for plotting AUC curves. # AUC data can only be prepared for binomial and multinomial outcomes @@ -81,67 +86,143 @@ setMethod( logger_message( paste0("Computing receiver-operating characteristic curves."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) - # Obtain ensemble method from stored settings, if required. if (is.waive(ensemble_method)) ensemble_method <- object@settings$ensemble_method - - # Obtain confidence level from the settings file stored with the - # familiarEnsemble object. if (is.waive(confidence_level)) confidence_level <- object@settings$confidence_level + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- object@settings$bootstrap_ci_method - # Check alpha - .check_number_in_valid_range( - x = confidence_level, - var_name = "confidence_level", - range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) - - # Load the bootstrap method - if (is.waive(bootstrap_ci_method)) { - bootstrap_ci_method <- object@settings$bootstrap_ci_method - } + # Check whether results should be aggregated. + aggregate_results <- .parse_aggregate_results( + x = aggregate_results, + object = object, + default = TRUE, + data_element = "auc_data" + ) - .check_parameter_value_is_valid( - x = bootstrap_ci_method, - var_name = "bootstrap_ci_method", - values = .get_available_bootstrap_confidence_interval_methods()) + proto_data_element <- .create_extract_auc_data_object( + object = object, + ensemble_method = ensemble_method, + detail_level = detail_level, + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) # Check the level detail. detail_level <- .parse_detail_level( x = detail_level, object = object, default = "hybrid", - data_element = "auc_data") + data_element = "auc_data" + ) + + # Determine whether a single curve is obtained for point estimates. + # When more than one model exists, these may be averaged for hybrid + # estimation types. + is_single_curve <- detail_level == "ensemble" || length(object@model_list) == 1L - # Check the estimation type. - estimation_type <- .parse_estimation_type( - x = estimation_type, + # Generate elements to send to dispatch. + roc_data <- extract_dispatcher( + FUN = .extract_roc_curve_data, + has_internal_bootstrap = TRUE, + cl = cl, object = object, - default = "bootstrap_confidence_interval", - data_element = "auc_data", - detail_level = detail_level, - has_internal_bootstrap = TRUE) + data = data, + proto_data_element = proto_data_element, + is_pre_processed = is_pre_processed, + ensemble_method = ensemble_method, + aggregate_results = aggregate_results, + is_single_curve = is_single_curve, + message_indent = message_indent + 1L, + verbose = verbose + ) + + return(roc_data) + } +) + + + +# extract_auc_data (prediction table) ------------------------------------------ + +setMethod( + "extract_auc_data", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + data, + cl = NULL, + ensemble_method = waiver(), + detail_level = waiver(), + estimation_type = waiver(), + aggregate_results = waiver(), + confidence_level = waiver(), + bootstrap_ci_method = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE, + ... + ) { + # Extract data for plotting AUC curves. + + if (is_empty(object)) return(NULL) + + # AUC data can only be prepared for binomial and multinomial outcomes + if (!is(object, "predictionTableClassification")) { + ..warning_no_data_extraction_from_prediction_table("AUC curve data") + + return(NULL) + } + + # Reference labels should be present. + if (!.has_reference_data(object)) { + ..warning_prediction_table_lacks_reference("AUC curve data") + return(NULL) + } + + # Message start of auc computations + logger_message( + paste0("Computing receiver-operating characteristic curves."), + indent = message_indent, + verbose = verbose + ) + + if (is.waive(ensemble_method)) { + ensemble_method <- "median" + if (methods::.hasSlot(object, "ensemble_method")) ensemble_method <- object@ensemble_method + } + + # Default Values. + if (is.waive(detail_level)) detail_level <- "ensemble" + if (is.waive(estimation_type)) estimation_type <- "bootstrap_confidence_interval" + if (is.waive(confidence_level)) confidence_level <- 0.95 + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- "bc" + if (is.waive(aggregate_results)) aggregate_results <- TRUE # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = TRUE, - data_element = "auc_data") + data_element = "auc_data" + ) - # Generate a prototype data element. - proto_data_element <- new( - "familiarDataElementAUCCurve", + # Copy object to prevent changing the provided object by reference. + object <- .copy(object) + + proto_data_element <- .create_extract_auc_data_object( + object = object, + ensemble_method = ensemble_method, detail_level = detail_level, estimation_type = estimation_type, confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method) + bootstrap_ci_method = bootstrap_ci_method + ) # Determine whether a single curve is obtained for point estimates. - # When more than one model exists, these may be averaged for hybrid - # estimation types. - is_single_curve <- detail_level == "ensemble" || length(object@model_list) == 1L + is_single_curve <- TRUE # Generate elements to send to dispatch. roc_data <- extract_dispatcher( @@ -156,7 +237,8 @@ setMethod( aggregate_results = aggregate_results, is_single_curve = is_single_curve, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(roc_data) } @@ -164,15 +246,75 @@ setMethod( +.create_extract_auc_data_object <- function( + object, + ensemble_method, + detail_level, + estimation_type, + confidence_level, + bootstrap_ci_method +) { + # Check confidence_level input argument. + .check_number_in_valid_range( + x = confidence_level, + var_name = "confidence_level", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + + # Check bootstrap_ci_method argument. + .check_parameter_value_is_valid( + x = bootstrap_ci_method, + var_name = "bootstrap_ci_method", + values = .get_available_bootstrap_confidence_interval_methods() + ) + + # Check ensemble_method argument. + .check_parameter_value_is_valid( + x = ensemble_method, + var_name = "ensemble_method", + values = .get_available_ensemble_prediction_methods() + ) + + # Check the level detail. + detail_level <- .parse_detail_level( + x = detail_level, + object = object, + default = "hybrid", + data_element = "auc_data" + ) + + # Check the estimation type. + estimation_type <- .parse_estimation_type( + x = estimation_type, + object = object, + default = "bootstrap_confidence_interval", + data_element = "auc_data", + detail_level = detail_level, + has_internal_bootstrap = TRUE + ) + + # Generate a prototype data element. + proto_data_element <- new( + "familiarDataElementAUCCurve", + detail_level = detail_level, + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) + + return(proto_data_element) +} + + + .extract_roc_curve_data <- function( object, - data, proto_data_element, - cl = NULL, - ensemble_method, - is_pre_processed, is_single_curve, - ...) { + cl = NULL, + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -180,7 +322,8 @@ setMethod( # Add model name. proto_data_element <- add_model_name( proto_data_element, - object = object) + object = object + ) # Update is_single_curve is_single_curve <- proto_data_element@estimation_type == "point" && is_single_curve @@ -189,53 +332,131 @@ setMethod( ..error_outcome_type_not_implemented(object@outcome_type) } - # Predict class probabilities. - prediction_data <- .predict( + return(..extract_roc_curve_data( object = object, - data = data, - ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed) - - # Check if any predictions are valid. - if (!all_predictions_valid( - prediction_data, - outcome_type = object@outcome_type)) { - return(NULL) - } - - # Remove data with missing outcomes. - prediction_data <- remove_missing_outcomes( - data = prediction_data, - outcome_type = object@outcome_type) - - # Check that any prediction data remain. - if (is_empty(prediction_data)) return(NULL) - - # Determine class levels - outcome_class_levels <- get_outcome_class_levels(object) - - # Select only one outcome type for binomial outcomes. - if (object@outcome_type == "binomial") outcome_class_levels <- outcome_class_levels[2] - - # Add positive class as an identifier. - data_elements <- add_data_element_identifier( - x = proto_data_element, - positive_class = outcome_class_levels) - - # Compute ROC data. - roc_data <- lapply( - data_elements, - .compute_auc_data_categorical, - data = prediction_data, - cl = cl, + data_element = proto_data_element, is_single_curve = is_single_curve, - ...) - - return(roc_data) + cl = cl, + ... + )) } +# ..extract_roc_curve_data (generic) ------------------------------------------- +setGeneric( + "..extract_roc_curve_data", + function(object, ...) standardGeneric("..extract_roc_curve_data") +) + + + +# ..extract_roc_curve_data (character) ----------------------------------------- +setMethod( + "..extract_roc_curve_data", + signature(object = "character"), + function( + object, + ... + ){ + # Ensure that the object is loaded + object <- load_familiar_object(object) + + return(..extract_roc_curve_data(object = object, ...)) + } +) + + + +# ..extract_roc_curve_data (model, ensemble) ----------------------------------- +setMethod( + "..extract_roc_curve_data", + signature(object = "familiarModelUnion"), + function( + object, + data, + ensemble_method, + is_pre_processed, + ... + ) { + + # Predict class probabilities. + prediction_data <- .predict( + object = object, + data = data, + ensemble_method = ensemble_method, + is_pre_processed = is_pre_processed + ) + + return(..extract_roc_curve_data( + object = prediction_data, + ... + )) + } +) + + + +# ..extract_roc_curve_data (classification) ------------------------------------ +setMethod( + "..extract_roc_curve_data", + signature(object = "predictionTableClassification"), + function( + object, + data_element, + cl, + is_single_curve, + ... + ) { + + # Check if any predictions are valid. + if (!all_predictions_valid(object)) return(NULL) + + # Remove data with missing outcomes. + object <- filter_missing_outcome(object) + + # Check that any prediction data remain. + if (is_empty(object)) return(NULL) + + # Determine class levels + outcome_class_levels <- get_outcome_class_levels(object) + + # Select only one outcome type for binomial outcomes. + if (object@outcome_type == "binomial") outcome_class_levels <- outcome_class_levels[2L] + + # Add positive class as an identifier. + data_elements <- add_data_element_identifier( + x = data_element, + positive_class = outcome_class_levels + ) + + # Compute ROC data. + roc_data <- lapply( + data_elements, + .compute_auc_data_categorical, + data = object, + cl = cl, + is_single_curve = is_single_curve, + ... + ) + + return(roc_data) + } +) + + + +# ..extract_roc_curve_data (NULL) ---------------------------------------------- +setMethod( + "..extract_roc_curve_data", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) + + + .compute_auc_data_categorical <- function( data_element, data, @@ -245,30 +466,35 @@ setMethod( progress_bar = FALSE, verbose = FALSE, message_indent = 0L, - ...) { + ... +) { # Check if the data has more than 1 row. - if (nrow(data) <= 1) return(NULL) + if (get_n_samples(data) <= 1L) return(NULL) - if (length(data_element@identifiers$positive_class) > 0 && progress_bar) { + if (length(data_element@identifiers$positive_class) > 0L && progress_bar) { logger_message( paste0( "Computing ROC and Precision-Recall curves for the \"", - data_element@identifiers$positive_class, "\" class."), + data_element@identifiers$positive_class, "\" class." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } # Set test probabilities threshold_probabilities <- seq( from = 0.000, to = 1.000, - by = 0.005) + by = 0.005 + ) # Add bootstrap data. bootstrap_data <- add_data_element_bootstrap( x = data_element, - ...) + ... + ) # Iterate over elements. data_elements <- fam_mapply( @@ -281,9 +507,11 @@ setMethod( MoreArgs = list( "data" = data, "x" = threshold_probabilities, - "is_single_curve" = is_single_curve), - progress_bar = progress_bar, - chopchop = TRUE) + "is_single_curve" = is_single_curve + ), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) # Merge data elements data_elements <- merge_data_elements(data_elements) @@ -300,7 +528,8 @@ setMethod( x, is_single_curve, bootstrap, - bootstrap_seed) { + bootstrap_seed +) { # Suppress NOTES due to non-standard evaluation in data.table outcome <- probability <- ppv <- tpr <- fpr <- is_positive <- NULL @@ -313,15 +542,17 @@ setMethod( if (bootstrap) { data <- get_bootstrap_sample( data = data, - seed = bootstrap_seed) + seed = bootstrap_seed + ) } # Make a local copy - data <- data.table::copy(data) + data <- data.table::copy(.as_data_table(data)) data.table::setnames( x = data, - old = get_class_probability_name(positive_class), - new = "probability") + old = positive_class, + new = "probability" + ) # Determine the number of positive and negative outcomes. n_positive <- sum(data$outcome == positive_class) @@ -341,7 +572,8 @@ setMethod( "n_true_positive" = cumsum(is_positive), "n_false_positive" = cumsum(!is_positive), "n_true_negative" = n_negative - cumsum(!is_positive), - "n_false_negative" = n_positive - cumsum(is_positive))] + "n_false_negative" = n_positive - cumsum(is_positive) + )] # Insert initial values. data <- data.table::rbindlist( @@ -350,20 +582,25 @@ setMethod( "n_true_positive" = 0L, "n_false_positive" = 0L, "n_true_negative" = n_negative, - "n_false_negative" = n_positive), - data), + "n_false_negative" = n_positive + ), + data + ), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) # Select unique data. data <- unique( data, by = c( "n_true_positive", "n_false_positive", - "n_true_negative", "n_false_negative")) + "n_true_negative", "n_false_negative" + ) + ) # Compute TPR / recall (sensitivity) - if (n_positive > 0) { + if (n_positive > 0L) { data[, "tpr" := n_true_positive / n_positive] } else { @@ -371,7 +608,7 @@ setMethod( } # Compute FPR (1-specificity) - if (max(data$n_false_positive) > 0) { + if (max(data$n_false_positive) > 0L) { data[, "fpr" := n_false_positive / n_negative] } else { @@ -379,11 +616,11 @@ setMethod( } # Compute precision / positive predictive value - if (max(data$n_true_positive + data$n_false_positive) > 0) { + if (max(data$n_true_positive + data$n_false_positive) > 0L) { data[, "ppv" := n_true_positive / (n_true_positive + n_false_positive)] # By convention, the initial value is 1.0. - data[n_true_positive + n_false_positive == 0, "ppv" := 1.0] + data[n_true_positive + n_false_positive == 0L, "ppv" := 1.0] } else { data[, "ppv" := 0.0] } @@ -402,8 +639,10 @@ setMethod( list( data.table::data.table("tpr" = 0.0, "fpr" = 0.0), data_auc_roc, - data.table::data.table("tpr" = 1.0, "fpr" = 1.0)), - use.names = TRUE) + data.table::data.table("tpr" = 1.0, "fpr" = 1.0) + ), + use.names = TRUE + ) # Select minimum and maximum sensitivity at each fpr. data_auc_roc <- unique(data_auc_roc[, list("tpr" = c(min(tpr), max(tpr))), by = "fpr"]) @@ -415,7 +654,8 @@ setMethod( data_auc_roc <- merge( x = data_auc_roc, y = data[, mget(c("tpr", "fpr", "sorting_index"))], - by = c("tpr", "fpr")) + by = c("tpr", "fpr") + ) # Fill out potentially missing sorting indices. data_auc_roc[tpr == 0.0 & fpr == 0.0 & is.na(sorting_index), "sorting_index" := 0L] @@ -444,18 +684,21 @@ setMethod( yleft = 0.0, yright = 1.0, method = "linear", - ties = "ordered")$y) + ties = "ordered" + )$y) } # Set ROC curve data. data_element_roc@data <- data.table::data.table( "x" = x, - "y" = y_auc_roc) + "y" = y_auc_roc + ) # Add curve type as an identifier. data_element_roc <- add_data_element_identifier( data_element_roc, - curve_type = "roc") + curve_type = "roc" + ) # Copy the data element as prototype for precisions-recall curve data. data_element_pr <- data_element @@ -471,7 +714,8 @@ setMethod( data_auc_pr <- merge( x = data_auc_pr, y = data[, mget(c("tpr", "ppv", "sorting_index"))], - by = c("tpr", "ppv")) + by = c("tpr", "ppv") + ) # Order data by sorting index. data_auc_pr <- data_auc_pr[order(sorting_index)] @@ -493,22 +737,26 @@ setMethod( yleft = 1.0, yright = n_positive / (n_positive + n_negative), method = "linear", - ties = "ordered")$y) + ties = "ordered" + )$y) } # Set PR curve data. data_element_pr@data <- data.table::data.table( "x" = x, - "y" = y_auc_pr) + "y" = y_auc_pr + ) # Add curve type as an identifier. data_element_pr <- add_data_element_identifier( data_element_pr, - curve_type = "pr") + curve_type = "pr" + ) return(c( data_element_roc, - data_element_pr)) + data_element_pr + )) } @@ -553,7 +801,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_auc_data") } ) @@ -571,7 +820,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -583,7 +833,8 @@ setMethod( aggregate_results = aggregate_results, type = "performance", subtype = "auc_curves", - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -598,7 +849,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -607,8 +859,11 @@ setMethod( list( "object" = object, "data_element" = "auc_data", - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_auc_data, @@ -617,7 +872,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationCalibrationData.R b/R/FamiliarDataComputationCalibrationData.R index 331aca1d..5a69024d 100644 --- a/R/FamiliarDataComputationCalibrationData.R +++ b/R/FamiliarDataComputationCalibrationData.R @@ -1,27 +1,32 @@ #' @include FamiliarS4Generics.R #' @include FamiliarS4Classes.R +#' @include PredictionTable.R NULL # familiarDataElementCalibrationData object ------------------------------------ setClass( "familiarDataElementCalibrationData", - contains = "familiarDataElement") + contains = "familiarDataElement" +) # familiarDataElementCalibrationLinearFit object ------------------------------- setClass( "familiarDataElementCalibrationLinearFit", - contains = "familiarDataElement") + contains = "familiarDataElement" +) # familiarDataElementCalibrationGoodnessOfFit object --------------------------- setClass( "familiarDataElementCalibrationGoodnessOfFit", - contains = "familiarDataElement") + contains = "familiarDataElement" +) # familiarDataElementCalibrationDensity object --------------------------------- setClass( "familiarDataElementCalibrationDensity", - contains = "familiarDataElement") + contains = "familiarDataElement" +) @@ -37,7 +42,7 @@ setClass( #' outcomes, the Nam-D'Agostino and Greenwood-Nam-D'Agostino tests are #' performed. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list with data.tables containing calibration test information for #' the ensemble model. @@ -59,13 +64,14 @@ setGeneric( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_calibration_data") } ) -#### extract_calibration_data -------------------------------------------------- +# extract_calibration_data (ensemble) ------------------------------------------ setMethod( "extract_calibration_data", signature(object = "familiarEnsemble"), @@ -83,97 +89,139 @@ setMethod( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # Message extraction start logger_message( paste0("Assessing model calibration."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) + + require_package( + x = "harmonicmeanp", + purpose = "to compute p-values for model calibration tests", + message_type = "warning" + ) # Load evaluation_times from the object settings attribute, if it is not # provided. if (is.waive(evaluation_times)) evaluation_times <- object@settings$eval_times - - # Check evaluation_times argument - if (object@outcome_type %in% c("survival")) { - sapply( - evaluation_times, - .check_number_in_valid_range, - var_name = "evaluation_times", - range = c(0.0, Inf), - closed = c(FALSE, TRUE)) - } - - # Obtain ensemble method from stored settings, if required. if (is.waive(ensemble_method)) ensemble_method <- object@settings$ensemble_method - - # Check ensemble_method argument - .check_parameter_value_is_valid( - x = ensemble_method, - var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) - - # Load confidence alpha from object settings attribute if not provided - # externally. if (is.waive(confidence_level)) confidence_level <- object@settings$confidence_level - - # Check confidence_level input argument - .check_number_in_valid_range( - x = confidence_level, - var_name = "confidence_level", - range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) - - # Load the bootstrap method if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- object@settings$bootstrap_ci_method - .check_parameter_value_is_valid( - x = bootstrap_ci_method, - var_name = "bootstrap_ci_method", - values = .get_available_bootstrap_confidence_interval_methods()) - - # Check the level detail. - detail_level <- .parse_detail_level( - x = detail_level, - object = object, - default = "hybrid", - data_element = "calibration_data") - - # Check the estimation type. - estimation_type <- .parse_estimation_type( - x = estimation_type, - object = object, - default = "bootstrap_confidence_interval", - data_element = "calibration_data", - detail_level = detail_level, - has_internal_bootstrap = TRUE) + # Test if models are properly loaded + if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() + if (!model_is_trained(object = object)) return(NULL) # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = TRUE, - data_element = "calibration_data") + data_element = "calibration_data" + ) - # Test if models are properly loaded - if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() + proto_data_element <- .create_extract_calibration_data_object( + object = object, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + detail_level = detail_level, + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) - # Test if any model in the ensemble was successfully trained. - if (!model_is_trained(object = object)) return(NULL) + # Generate elements to send to dispatch. + calibration_data <- extract_dispatcher( + FUN = .extract_calibration_data, + has_internal_bootstrap = TRUE, + cl = cl, + object = object, + data = data, + proto_data_element = proto_data_element, + is_pre_processed = is_pre_processed, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + aggregate_results = aggregate_results, + message_indent = message_indent + 1L, + verbose = verbose + ) + + return(calibration_data) + } +) + + + +# extract_calibration_data (prediction table) ---------------------------------- +setMethod( + "extract_calibration_data", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + data, + cl = NULL, + ensemble_method = waiver(), + evaluation_times = waiver(), + detail_level = waiver(), + estimation_type = waiver(), + aggregate_results = waiver(), + confidence_level = waiver(), + bootstrap_ci_method = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE, + ... + ) { + + # Message extraction start + logger_message( + paste0("Assessing model calibration."), + indent = message_indent, + verbose = verbose + ) require_package( x = "harmonicmeanp", purpose = "to compute p-values for model calibration tests", - message_type = "warning") + message_type = "warning" + ) + + if (is.waive(evaluation_times) && methods::.hasSlot(object, "time")) { + evaluation_times <- object@time + } + if (is.waive(ensemble_method)) { + ensemble_method <- "median" + if (methods::.hasSlot(object, "ensemble_method")) ensemble_method <- object@ensemble_method + } + + # Default Values. + if (is.waive(detail_level)) detail_level <- "ensemble" + if (is.waive(estimation_type)) estimation_type <- "bootstrap_confidence_interval" + if (is.waive(confidence_level)) confidence_level <- 0.95 + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- "bc" + if (is.waive(aggregate_results)) aggregate_results <- TRUE + + # Check whether results should be aggregated. + aggregate_results <- .parse_aggregate_results( + x = aggregate_results, + object = object, + default = TRUE, + data_element = "calibration_data" + ) - # Generate a prototype data element. - proto_data_element <- new( - "familiarDataElementCalibrationData", + proto_data_element <- .create_extract_calibration_data_object( + object = object, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, detail_level = detail_level, estimation_type = estimation_type, confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method) + bootstrap_ci_method = bootstrap_ci_method + ) # Generate elements to send to dispatch. calibration_data <- extract_dispatcher( @@ -188,7 +236,8 @@ setMethod( evaluation_times = evaluation_times, aggregate_results = aggregate_results, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(calibration_data) } @@ -196,278 +245,988 @@ setMethod( +.create_extract_calibration_data_object <- function( + object, + ensemble_method, + evaluation_times, + detail_level, + estimation_type, + confidence_level, + bootstrap_ci_method +) { + # Check evaluation_times argument + if (object@outcome_type %in% c("survival")) { + sapply( + evaluation_times, + .check_number_in_valid_range, + var_name = "evaluation_times", + range = c(0.0, Inf), + closed = c(FALSE, TRUE) + ) + } + + # Check ensemble_method argument + .check_parameter_value_is_valid( + x = ensemble_method, + var_name = "ensemble_method", + values = .get_available_ensemble_prediction_methods() + ) + + # Check confidence_level input argument + .check_number_in_valid_range( + x = confidence_level, + var_name = "confidence_level", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + + # Check boostrap method + .check_parameter_value_is_valid( + x = bootstrap_ci_method, + var_name = "bootstrap_ci_method", + values = .get_available_bootstrap_confidence_interval_methods() + ) + + # Check the level detail. + detail_level <- .parse_detail_level( + x = detail_level, + object = object, + default = "hybrid", + data_element = "calibration_data" + ) + + # Check the estimation type. + estimation_type <- .parse_estimation_type( + x = estimation_type, + object = object, + default = "bootstrap_confidence_interval", + data_element = "calibration_data", + detail_level = detail_level, + has_internal_bootstrap = TRUE + ) + + # Generate a prototype data element. + proto_data_element <- new( + "familiarDataElementCalibrationData", + detail_level = detail_level, + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) + + return(proto_data_element) +} + + + .extract_calibration_data <- function( object, proto_data_element, evaluation_times = NULL, aggregate_results, cl, - ...) { - + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) # Add model name. - proto_data_element <- add_model_name( - proto_data_element, - object = object) + proto_data_element <- add_model_name(proto_data_element, object = object) # Add evaluation time as a identifier to the data element. - if (length(evaluation_times) > 0 && object@outcome_type == "survival") { + if (length(evaluation_times) > 0L && object@outcome_type == "survival") { data_elements <- add_data_element_identifier( x = proto_data_element, - evaluation_time = evaluation_times) + evaluation_time = evaluation_times + ) } else { data_elements <- list(proto_data_element) } # Iterate over data elements. - calibration_data <- lapply( - data_elements, + calibration_data <- mapply( ..extract_calibration_data, - object = object, - aggregate_results = aggregate_results, - cl = cl, - ...) + data_element = data_elements, + MoreArgs = list( + object = object, + aggregate_results = aggregate_results, + cl = cl, + ... + ), + SIMPLIFY = FALSE + ) return(calibration_data) } -..extract_calibration_data <- function( - data_element, +# ..extract_calibration_data (generic) ----------------------------------------- +setGeneric( + "..extract_calibration_data", + function(object, ...) standardGeneric("..extract_calibration_data") +) + + + +# ..extract_calibration_data (character) --------------------------------------- +setMethod( + "..extract_calibration_data", + signature(object = "character"), + function( + object, + ... + ){ + # Ensure that the object is loaded + object <- load_familiar_object(object) + + return(..extract_calibration_data(object = object, ...)) + } +) + + + +# ..extract_calibration_data (model, ensemble) --------------------------------- +setMethod( + "..extract_calibration_data", + signature(object = "familiarModelUnion"), + function( object, data, - cl = NULL, + data_element, is_pre_processed, ensemble_method, - metric, + ... + ) { + # Aggregate data. + data <- aggregate_data(data) + + if (object@outcome_type %in% c("survival", "competing_risk")) { + # Predict class probabilities or regression values. + prediction_data <- .predict( + object = object, + data = data, + type = "survival_probability", + time = data_element@identifiers$evaluation_time, + ensemble_method = ensemble_method, + is_pre_processed = is_pre_processed + ) + + } else { + # Predict class probabilities or regression values. + prediction_data <- .predict( + object = object, + data = data, + ensemble_method = ensemble_method, + is_pre_processed = is_pre_processed + ) + } + + return(..extract_calibration_data( + object = prediction_data, + data_element = data_element, + ... + )) + } +) + + + +# ..extract_calibration_data (prediction table) -------------------------------- +setMethod( + "..extract_calibration_data", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + data_element, aggregate_results, + cl = NULL, progress_bar = FALSE, verbose = FALSE, message_indent, - ...) { - - # Message the user concerning the time at which metrics are computed. This is - # only relevant for survival analysis. - if (length(data_element@identifiers$evaluation_time) > 0 && progress_bar) { - logger_message( - paste0( - "Assessing model calibration at time ", - data_element@identifiers$evaluation_time, "."), - indent = message_indent, - verbose = verbose) - } - - # Aggregate data. - data <- aggregate_data(data) - - if (object@outcome_type %in% c("survival", "competing_risk")) { - # Predict class probabilities or regression values. - prediction_data <- .predict( - object = object, - data = data, - type = "survival_probability", - time = data_element@identifiers$evaluation_time, - ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed) + ... + ) { + if (!( + is(object, "predictionTableSurvivalProbability") || + is(object, "predictionTableClassification") || + is(object, "predictionTableRegression") + )) { + ..warning_no_data_extraction_from_prediction_table("calibration data") + + return(NULL) + } - } else { - # Predict class probabilities or regression values. - prediction_data <- .predict( - object = object, - data = data, - ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed) + # Message the user concerning the time at which metrics are computed. This + # is only relevant for survival analysis. + if (length(data_element@identifiers$evaluation_time) > 0L && progress_bar) { + logger_message( + paste0( + "Assessing model calibration at time ", + data_element@identifiers$evaluation_time, "." + ), + indent = message_indent, + verbose = verbose + ) + } + + + # Check if any predictions are valid. + if (!all_predictions_valid(object)) return(NULL) + + # Remove data with missing outcomes. + object <- filter_missing_outcome(object) + + # Check that any prediction data remain. + if (is_empty(object)) return(NULL) + + # Add positive class as an identifier. + if (object@outcome_type %in% c("binomial")) { + data_element <- add_data_element_identifier( + x = data_element, + positive_class = get_outcome_class_levels(object)[2L] + ) + + } else if (object@outcome_type %in% c("multinomial")) { + data_element <- add_data_element_identifier( + x = data_element, + positive_class = get_outcome_class_levels(object) + ) + } + + # Add bootstrap data. + bootstrap_data <- add_data_element_bootstrap( + x = data_element, + ... + ) + + # Add distribution data. + if (!is.list(data_element)) data_element <- list(data_element) + + density_data <- lapply( + data_element, + .compute_calibration_data_density, + object = object + ) + + # Iterate over elements. + data_elements <- fam_mapply( + cl = cl, + assign = NULL, + FUN = .compute_calibration_data, + data_element = bootstrap_data$data_element, + bootstrap = bootstrap_data$bootstrap, + bootstrap_seed = bootstrap_data$seed, + MoreArgs = list("object" = object), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) + + # Flatten list of data elements. + data_elements <- unlist(data_elements) + if (!is.list(data_elements)) data_elements <- list(data_elements) + + # Add in density data elements. + data_elements <- c(data_elements, density_data) + + # Merge data elements + data_elements <- merge_data_elements(data_elements) + + if (aggregate_results) data_elements <- .compute_data_element_estimates(x = data_elements) + + return(data_elements) } +) + + + +# ..extract_calibration_data (NULL) -------------------------------------------- +setMethod( + "..extract_calibration_data", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) + + + +.compute_calibration_data <- function( + data_element, + object, + bootstrap, + bootstrap_seed +) { - # Check if any predictions are valid. - if (!all_predictions_valid(prediction_data, outcome_type = object@outcome_type)) return(NULL) + # Suppress NOTES due to non-standard evaluation in data.table + observed <- NULL - # Remove data with missing outcomes. - prediction_data <- remove_missing_outcomes( - data = prediction_data, - outcome_type = object@outcome_type) + # Start random number generator. + rstream_object <- .start_random_number_stream(seed = ifelse(is.finite(bootstrap_seed), bootstrap_seed, 19L)) - # Check that any prediction data remain. - if (is_empty(prediction_data)) return(NULL) + # Bootstrap the data. + if (bootstrap) { + object <- get_bootstrap_sample(data = object, rstream_object = rstream_object) + } - # Add positive class as an identifier. - if (object@outcome_type %in% c("binomial")) { - data_element <- add_data_element_identifier( - x = data_element, - positive_class = get_outcome_class_levels(object)[2]) + # Compute calibration, linear and gof test data. + calibration_data <- ..compute_calibration_data( + object, + data_element = data_element, + rstream_object = rstream_object + ) + + # Extract data. + calibration_at_large <- calibration_data$linear + calibration_gof_test <- calibration_data$gof_test + calibration_data <- calibration_data$calibration + + if (!is_empty(calibration_data) && data_element@estimation_type != "point") { + calibration_data <- ..compute_calibration_data_interpolated( + data = calibration_data + ) - } else if (object@outcome_type %in% c("multinomial")) { - data_element <- add_data_element_identifier( - x = data_element, - positive_class = get_outcome_class_levels(object)) + # Keep only finite predictions, + calibration_data <- calibration_data[is.finite(observed)] } - # Add bootstrap data. - bootstrap_data <- add_data_element_bootstrap( - x = data_element, - ...) + # Create additional data elements to contain linear fit data and GoF test + # data. + linear_fit_data_element <- methods::new( + "familiarDataElementCalibrationLinearFit", + data_element + ) + gof_data_element <- methods::new( + "familiarDataElementCalibrationGoodnessOfFit", + data_element + ) - # Add distribution data. - if (!is.list(data_element)) data_element <- list(data_element) + # Set for calibration data. + data_element@data <- calibration_data + data_element@value_column <- "observed" + data_element@grouping_column <- "expected" - density_data <- lapply( - data_element, - .compute_calibration_data_density, - data = prediction_data, - object = object) - - # Iterate over elements. - data_elements <- fam_mapply( - cl = cl, - assign = NULL, - FUN = .compute_calibration_data, - data_element = bootstrap_data$data_element, - bootstrap = bootstrap_data$bootstrap, - bootstrap_seed = bootstrap_data$seed, - MoreArgs = list( - "object" = object, - "data" = prediction_data), - progress_bar = progress_bar, - chopchop = TRUE) + # Set linear fit data, i.e. calibration-in-the-large and calibration slope. + linear_fit_data_element@data <- calibration_at_large + linear_fit_data_element@value_column <- "value" + linear_fit_data_element@grouping_column <- "type" + + # Set goodness of fit data. + gof_data_element@data <- calibration_gof_test + gof_data_element@value_column <- "p_value" + gof_data_element@grouping_column <- "type" - # Flatten list of data elements. - data_elements <- unlist(data_elements) - if (!is.list(data_elements)) data_elements <- list(data_elements) + return(list( + data_element, + linear_fit_data_element, + gof_data_element + )) +} + + + +# ..compute_calibration_data (generic) ----------------------------------------- +setGeneric( + "..compute_calibration_data", + function(object, ...) standardGeneric("..compute_calibration_data") +) + + + + +# ...compute_calibration_data (generic) ---------------------------------------- +setGeneric( + "...compute_calibration_data", + function(object, ...) standardGeneric("...compute_calibration_data") +) + + + +# ..compute_calibration_data (survival probability) ---------------------------- +setMethod( + "..compute_calibration_data", + signature(object = "predictionTableSurvivalProbability"), + function(object, data_element, rstream_object = NULL) { + # Generate baseline calibration data for survival models from an input table + # (data) containing survival probabilities for each sample and + # corresponding time and event status. + + # Suppress NOTES due to non-standard evaluation in data.table + exp_prob <- NULL + + # Set time. + time <- data_element@identifiers$evaluation_time + + # Find sample identifiers. + sample_identifiers <- get_id_columns(id_depth = "series") + + # Rename the survival column to standard name. + data <- data.table::copy(.as_data_table(object)) + data.table::setnames( + data, + old = c("outcome_time", "outcome_event", "predicted_outcome"), + new = c("time", "event", "exp_prob") + ) + + # Sort by survival probability. + data <- data[order(exp_prob)] + + # Randomly split into groups. The number of groups is determined using + # sturges rule. + group_data <- .calibration_create_randomised_groups( + x = data$exp_prob, + y = data$event, + sample_identifiers = data[, mget(sample_identifiers)], + n_min_y_in_group = 4L, + rstream_object = rstream_object + ) + + if (is_empty(group_data)) return(NULL) + + # Merge with prediction table. + group_data <- merge( + x = data, + y = group_data, + by = sample_identifiers, + allow.cartesian = TRUE + ) + + # Iterate over groups and add details by comparing the kaplan-meier survival + # curve within each group at time with the mean survival probability in + # the group. + calibration_data <- lapply( + split(group_data, by = "group_id"), + function(x, object, time) { + ...compute_calibration_data( + object = object, + data = x, + time = time + ) + }, + object = object, + time = time + ) + + # Combine to a single list. + calibration_data <- data.table::rbindlist( + calibration_data, + use.names = TRUE + ) + + # Prevent processing of empty tables. + if (is_empty(calibration_data)) return(NULL) + + # Set column order. + data.table::setcolorder( + x = calibration_data, + neworder = c("expected", "observed", "km_var", "n_g") + ) + + # Calibration-in-the-large and calibration slope + calibration_at_large <- .compute_calibration_linear_fit( + calibration_data = calibration_data, + outcome_type = object@outcome_type + ) + + # Nam-D'Agostino tests + calibration_gof_test <- .compute_calibration_nam_dagostino( + calibration_data = calibration_data + ) + + return(list( + "calibration" = calibration_data, + "linear" = calibration_at_large, + "gof_test" = calibration_gof_test + )) + } +) + + + +# ..compute_calibration_data (classification) ---------------------------------- +setMethod( + "..compute_calibration_data", + signature(object = "predictionTableClassification"), + function(object, data_element, rstream_object = NULL) { + # For assessing the calibration of categorical outcomes, we require expected + # and observed probabilities for 1 (binomial) or all classes (multinomial). + # Expected probabilities are easy, as the model predicts them. Observed + # probabilities are however based on class proportion within a group. This + # means that we need to define groups, ordered by predicted probability. The + # same groups need to be defined for the Hosmer-Lemeshow test, so we might + # as well obtain all the data here. + # + # Groups are defined for each class level because the samples should be + # ordered according to predicted class probability to create the groups. + + # Suppress NOTES due to non-standard evaluation in data.table + observed_class <- exp_prob <- NULL + + positive_class <- data_element@identifiers$positive_class + + # Identify the real outcome columns + outcome_column <- get_outcome_columns(x = "binomial") + + # Find sample identifiers. + sample_identifiers <- get_id_columns(id_depth = "series") + + # Make local copy. + data <- data.table::copy( + .as_data_table(object)[, mget(c(sample_identifiers, outcome_column, positive_class))] + ) + + # Rename columns to standard names + data.table::setnames( + data, + old = c(outcome_column, positive_class), + new = c("observed_class", "exp_prob") + ) + + # Mask class so that positive outcomes are TRUE and the rest FALSE + data[, "observed_class" := observed_class == positive_class] + + # Sort by probability + data <- data[order(exp_prob)] + + # Randomly split into groups. The number of groups is determined using + # sturges rule. + group_data <- .calibration_create_randomised_groups( + x = data$exp_prob, + sample_identifiers = data[, mget(sample_identifiers)], + rstream_object = rstream_object + ) + + if (is_empty(group_data)) return(NULL) + + # Merge with prediction table. + group_data <- merge( + x = data, + y = group_data, + by = sample_identifiers, + allow.cartesian = TRUE + ) + + # Compute calibration data from each group. + calibration_data <- lapply( + split(group_data, by = "group_id"), + function(x, object) { + ...compute_calibration_data( + object = object, + data = x + ) + }, + object = object + ) + + # Combine to a single list. + calibration_data <- data.table::rbindlist( + calibration_data, + use.names = TRUE + ) + + # Check that any calibration data was generated. + if (is_empty(calibration_data)) return(NULL) + + # Set column order + data.table::setcolorder( + x = calibration_data, + neworder = c("expected", "observed", "n_g", "n_pos", "n_neg") + ) + + # Calibration-in-the-large and calibration slope + calibration_at_large <- .compute_calibration_linear_fit( + calibration_data = calibration_data, + outcome_type = object@outcome_type + ) + + # Hosmer-Lemeshow tests + calibration_gof_test <- .compute_calibration_hosmer_lemeshow( + calibration_data = calibration_data + ) + + return(list( + "calibration" = calibration_data, + "linear" = calibration_at_large, + "gof_test" = calibration_gof_test + )) + } +) + + +# ..compute_calibration_data (regression) -------------------------------------- +setMethod( + "..compute_calibration_data", + signature(object = "predictionTableRegression"), + function(object, data_element, rstream_object = NULL) { + # Calibration for regression problems is pretty straightforward. However, for + # goodness-of-fit tests, we need to constrain expected and observed value + # ranges to [0, 1]. To do so, we use the range of outcome values from the + # development data, as stored in the calibration_info slot of the input + # object. + + # Suppress NOTES due to non-standard evaluation in data.table + outcome <- predicted_outcome <- NULL + n_groups <- 1L + + # Extract data. + data <- data.table::copy(.as_data_table(object)) + + # Find sample identifiers. + sample_identifiers <- get_id_columns(id_depth = "series") + + # Determine the outcome range + outcome_range <- object@observed_value_range + if (anyNA(outcome_range)) outcome_range <- range(data$outcome, na.rm = TRUE, finite = TRUE) + + # Get the shift and scale parameters. + norm_shift <- outcome_range[1L] + norm_scale <- diff(outcome_range) + + # Set scale parameters equal to 0.0 to 1.0 to avoid division by 0. + if (norm_scale == 0.0) norm_scale <- 1.0 + + # Apply normalisation. + data[, ":="( + "expected" = (predicted_outcome - norm_shift) / norm_scale, + "observed" = (outcome - norm_shift) / norm_scale + )] + + # Randomly split into groups. The number of groups is determined using + # sturges rule. + group_data <- .calibration_create_randomised_groups( + x = data$expected, + sample_identifiers = data[, mget(sample_identifiers)], + rstream_object = rstream_object + ) + + if (is_empty(group_data)) return(NULL) + + # Merge with prediction table. + group_data <- merge( + x = data, + y = group_data, + by = sample_identifiers, + allow.cartesian = TRUE + ) + + # Compute calibration data from each group. + calibration_data <- lapply( + split(group_data, by = "group_id"), + function(x, object) { + ...compute_calibration_data( + object = object, + data = x + ) + }, + object = object + ) + + # Combine to a single list. + calibration_data <- data.table::rbindlist( + calibration_data, + use.names = TRUE + ) + + # Check if the resulting table contains data. + if (is_empty(calibration_data)) return(NULL) + + # Make columns match the expected order + data.table::setcolorder( + x = calibration_data, + neworder = c("expected", "observed", "n_g") + ) + + # Calibration-in-the-large and calibration slope + calibration_at_large <- .compute_calibration_linear_fit( + calibration_data = calibration_data, + outcome_type = object@outcome_type + ) + + # Hosmer-Lemeshow tests + calibration_gof_test <- .compute_calibration_hosmer_lemeshow( + calibration_data = calibration_data + ) + + return(list( + "calibration" = calibration_data, + "linear" = calibration_at_large, + "gof_test" = calibration_gof_test + )) + } +) + + + +# ...compute_calibration_data (survival probability) --------------------------- +setMethod( + "...compute_calibration_data", + signature(object = "predictionTableSurvivalProbability"), + function( + object, + data, + time + ) { + # Set default values. + obs_prob <- exp_prob <- km_var <- NA_real_ + n_g <- NA_integer_ + + if (nrow(data) >= 2L) { + + # Fit a Kaplan-Meier curve for the current group + km_fit <- survival::survfit(Surv(time, event) ~ 1, data = data) + + if (length(km_fit$time) >= 2L) { + + # Get observed probability + obs_prob <- stats::approx( + x = km_fit$time, + y = km_fit$surv, + xout = time, + method = "linear", + rule = 2L + )$y + + # Get expected probability + exp_prob <- mean(data$exp_prob) + + # Get group size + n_g <- nrow(data) + + # Get greenwood variance estimate. + km_var <- stats::approx( + x = km_fit$time, + y = km_fit$std.err, + xout = time, + method = "linear", + rule = 2L + )$y^2.0 + + } + } + + # Create table. + calibration_table <- list( + "expected" = exp_prob, + "observed" = obs_prob, + "n_g" = n_g, + "km_var" = km_var + ) + + return(calibration_table) + } +) + + + +# ...compute_calibration_data (classification) --------------------------------- +setMethod( + "...compute_calibration_data", + signature(object = "predictionTableClassification"), + function( + object, + data + ) { + # Check that the groups list contains at least one entry. + if (is_empty(data)) return(NULL) + + # Create table + calibration_table <- list( + # Mean expected probability in a group. + "expected" = mean(data$exp_prob), + # Observed proportion of positive class in a group. + "observed" = mean(data$observed_class), + # Number of samples in the group + "n_g" = nrow(data), + # Number of samples with the positive class in each group. + "n_pos" = sum(data$observed_class), + # Number of samples with the negative class in each group. + "n_neg" = sum(!data$observed_class) + ) + + return(calibration_table) + } +) + + + +# ...compute_calibration_data (regression) --------------------------------- +setMethod( + "...compute_calibration_data", + signature(object = "predictionTableRegression"), + function( + object, + data + ) { + # Check that the groups list contains at least one entry. + if (is_empty(data)) return(NULL) + + # Create table + calibration_table <- list( + # Mean expected value in the group. + "expected" = mean(data$expected), + # Observed value in the group. + "observed" = mean(data$observed), + # Number of samples in the group + "n_g" = nrow(data) + ) + + return(calibration_table) + } +) + + + +#' Create randomised groups Creates randomised groups, e.g. for tests that +#' depend on splitting (continuous) data into groups, such as the +#' Hosmer-Lemeshow test +#' +#' The default fast mode is based on random sampling, whereas the slow mode is +#' based on probabilistic joining of adjacent groups. As the name suggests, fast +#' mode operates considerably more efficient. +#' +#' @param x Vector with data used for sorting. Groups are formed based on +#' adjacent values. +#' @param y Vector with markers, e.g. the events. Should be 0 or 1 (for an +#' event). +#' @param sample_identifiers data.table with sample_identifiers. If provide, a +#' list of grouped sample_identifiers will be returned, and integers +#' otherwise. +#' @param n_max_groups Maximum number of groups that need to be formed. +#' @param n_min_groups Minimum number of groups that need to be formed. +#' @param n_min_y_in_group Minimum number of y=1 in each group for a valid +#' group. +#' +#' @details Creates randomised groups, e.g. for tests that depend on splitting +#' (continuous) data into groups, such as the Hosmer-Lemeshow test +#' +#' @return data.table with sample identifiers and random group ids. +#' @md +#' @keywords internal +.calibration_create_randomised_groups <- function( + x, + y = NULL, + sample_identifiers, + n_max_groups = NULL, + n_min_groups = NULL, + n_min_y_in_group = NULL, + unique_samples_only = TRUE, + rstream_object = NULL +) { + # Suppress NOTES due to non-standard evaluation in data.table + group_id <- cum_y <- weight <- cum_prob_lower <- cum_prob_upper <- NULL + exclude <- y_in_group <- NULL + + # Populate the generic table. + data <- data.table::copy(sample_identifiers[, mget(get_id_columns(id_depth = "series"))]) + data[, "x" := x] + if (is.null(y)) { + data[, "y" := 0L] + } else { + data[, "y" := y] + } + if (unique_samples_only) data <- unique(data) - # Add in density data elements. - data_elements <- c(data_elements, density_data) + # - Get number of x + n_x <- nrow(data) - # Merge data elements - data_elements <- merge_data_elements(data_elements) + # - Get number of y + n_y <- sum(data$y) - if (aggregate_results) data_elements <- .compute_data_element_estimates(x = data_elements) + # - Get the maximum of groups + if (is.null(n_max_groups)) { + n_max_groups <- ceiling(2.5 * n_x^(1.0 / 3.0)) + } - return(data_elements) -} - - - -.compute_calibration_data <- function( - data_element, - object, - data, - bootstrap, - bootstrap_seed) { + # - Update maximum number of groups + if (n_y > 0.0 && !is.null(n_min_y_in_group)) { + n_max_groups <- min(c(n_max_groups, floor(n_y / n_min_y_in_group))) + } - # Suppress NOTES due to non-standard evaluation in data.table - observed <- NULL + # - Update mininum number of groups based on n_max_groups + if (is.null(n_min_groups)) { + n_min_groups <- min(c(n_max_groups, ceiling(1.0 * n_x^(1.0 / 3.0)))) + } - # Bootstrap the data. - if (bootstrap) { - data <- get_bootstrap_sample( - data = data, - seed = bootstrap_seed) + # Some checks + if (n_max_groups < n_min_groups || n_max_groups > n_x || n_max_groups < 2L) { + return(NULL) } + data <- data[order(x)] - # Extract data - if (object@outcome_type %in% c("survival")) { - # Calibration grouping data for survival outcomes. - calibration_data <- .compute_calibration_data_survival( - data = data, - time = data_element@identifiers$evaluation_time, - n_groups = ifelse(data_element@estimation_type == "point", 20L, 1L)) - - # Calibration-in-the-large and calibration slope - calibration_at_large <- .compute_calibration_linear_fit( - calibration_data = calibration_data, - outcome_type = object@outcome_type) - - # Nam-D'Agostino tests - calibration_gof_test <- .compute_calibration_nam_dagostino( - calibration_data = calibration_data) - - } else if (object@outcome_type %in% c("binomial", "multinomial")) { - # Calibration grouping data for categorical outcomes. - calibration_data <- .compute_calibration_data_categorical( - data = data, - positive_class = data_element@identifiers$positive_class, - n_groups = ifelse(data_element@estimation_type == "point", 20L, 1L)) - - # Calibration-in-the-large and calibration slope - calibration_at_large <- .compute_calibration_linear_fit( - calibration_data = calibration_data, - outcome_type = object@outcome_type) - - # Hosmer-Lemeshow tests - calibration_gof_test <- .compute_calibration_hosmer_lemeshow( - calibration_data = calibration_data) + # Initial loop counter + loop_iter <- 0L + + while (TRUE) { + # Draw a random number of groups between n_min_groups and n_max_groups + if (n_min_groups == n_max_groups) { + n_group_draw <- n_max_groups + } else { + n_group_draw <- fam_sample( + x = seq.int(from = n_min_groups, to = n_max_groups, by = 1L), + size = 1L, + replace = FALSE, + rstream_object = rstream_object + ) + } - } else if (object@outcome_type %in% c("count", "continuous")) { - # Calibration grouping data for numerical outcomes. - calibration_data <- .compute_calibration_data_regression( - object = object, - data = data, - n_groups = ifelse(data_element@estimation_type == "point", 20L, 1L)) + # Draw a randomised groups assignment + random_group_id <- sort( + fam_sample( + x = seq_len(n_group_draw), + size = n_x, + replace = TRUE, + rstream_object = rstream_object + ) + ) - # Calibration-in-the-large and calibration slope - calibration_at_large <- .compute_calibration_linear_fit( - calibration_data = calibration_data, - outcome_type = object@outcome_type) + # Assign group id + data[, "group_id" := random_group_id] - # Hosmer-Lemeshow tests - calibration_gof_test <- .compute_calibration_hosmer_lemeshow( - calibration_data = calibration_data) + # Check if all groups have the minimum required y (e.g. events/group size) + if (n_y > 0L && !is.null(n_min_y_in_group)) { + dt_y <- data[, list(y_in_group = sum(y)), by = group_id] + if (all(dt_y$y_in_group >= n_min_y_in_group)) break + + } else { + # If there is no minimum number of events required, only run one + # iteration + break + } - } else { - ..error_outcome_type_not_implemented(object@outcome_type) - } - - if (!is_empty(calibration_data) && data_element@estimation_type != "point") { - # Interpolate data to regular expected values, unless point data is used. - calibration_data <- calibration_data[ - , ..compute_calibration_data_interpolated(.SD), - by = c("rep_id"), - .SDcols = c("expected", "observed")] + # Update loop_iter in case the sample was not good enough + loop_iter <- loop_iter + 1L - # Keep only finite predictions, - calibration_data <- calibration_data[is.finite(observed)] + # Break from outer loop after 10 unsuccessful random samplings and create + # a static split instead + if (loop_iter >= 10L) { + # Cumulative sum over y + data[, "cum_y" := cumsum(y)] + + # Assign static group ids + data[, "group_id" := findInterval( + x = cum_y, + vec = c( + -Inf, + stats::quantile(x = cum_y, (1L:(n_min_groups - 1L)) / n_min_groups), + Inf + ) + )] + + # Break from loop + break + } } - # Create additional data elements to contain linear fit data and GoF test - # data. - linear_fit_data_element <- methods::new( - "familiarDataElementCalibrationLinearFit", - data_element) - gof_data_element <- methods::new( - "familiarDataElementCalibrationGoodnessOfFit", - data_element) - - # Set for calibration data. - data_element@data <- calibration_data - data_element@value_column <- "observed" - data_element@grouping_column <- "expected" - - # Set linear fit data, i.e. calibration-in-the-large and calibration slope. - linear_fit_data_element@data <- calibration_at_large - linear_fit_data_element@value_column <- "value" - linear_fit_data_element@grouping_column <- "type" - - # Set goodness of fit data. - gof_data_element@data <- calibration_gof_test - gof_data_element@value_column <- "p_value" - gof_data_element@grouping_column <- "type" - - return(list( - data_element, - linear_fit_data_element, - gof_data_element)) + # Get sample identifiers for each group + return(data[, mget(c(get_id_columns(id_depth = "series"), "group_id"))]) } .compute_calibration_data_density <- function( data_element, - data, - object) { + object +) { # Suppress NOTES due to non-standard evaluation in data.table predicted_outcome <- NULL @@ -475,31 +1234,34 @@ setMethod( # Copy data element. data_element <- methods::new( "familiarDataElementCalibrationDensity", - data_element) + data_element + ) # Copy data - data <- data.table::copy(data) + data <- data.table::copy(.as_data_table(object)) if (object@outcome_type %in% c("survival", "competing_risk")) { # Rename the survival column to standard name. data.table::setnames( data, - old = "survival_probability", - new = "expected") + old = "predicted_outcome", + new = "expected" + ) } else if (object@outcome_type %in% c("binomial", "multinomial")) { # Rename class probability columns to standard names. data.table::setnames( data, - old = get_class_probability_name(x = data_element@identifiers$positive_class), - new = "expected") + old = data_element@identifiers$positive_class, + new = "expected" + ) - } else if (object@outcome_type %in% c("count", "continuous")) { + } else if (object@outcome_type %in% c("continuous")) { # Determine the outcome range - outcome_range <- range(object@outcome_info@distribution$fivenum) + outcome_range <- range(object@observed_value_range) # Get the shift and scale parameters. - norm_shift <- outcome_range[1] + norm_shift <- outcome_range[1L] norm_scale <- diff(outcome_range) # Set scale parameters equal to 0.0 to 1.0 to avoid division by 0. @@ -520,17 +1282,18 @@ setMethod( expected_interpolated <- seq( from = 0.000, to = 1.000, - by = 0.005) + by = 0.005 + ) # Determine the bin for expected. n <- length(expected_interpolated) # Discretise bins. - group_bin <- floor((n - 1) * expected) + 1 + group_bin <- as.integer(floor((n - 1L) * expected)) + 1L # Check if the group_bin still falls within the valid range. group_bin <- ifelse(group_bin > n, n, group_bin) - group_bin <- ifelse(group_bin < 1, 1, group_bin) + group_bin <- ifelse(group_bin < 1L, 1L, group_bin) # Compute the frequency of each entry. data <- data.table::data.table("expected" = expected_interpolated[group_bin]) @@ -546,417 +1309,10 @@ setMethod( -.compute_calibration_data_survival <- function( - data, - time, - n_groups = 1L) { - # Generate baseline calibration data for survival models from an input table - # (data) containing survival probabilities for each sample and - # corresponding time and event status. - - # Suppress NOTES due to non-standard evaluation in data.table - exp_prob <- NULL - - # Rename the survival column to standard name. - data.table::setnames( - data, - old = c("outcome_time", "outcome_event", "survival_probability"), - new = c("time", "event", "exp_prob")) - - # Sort by survival probability. - data <- data[order(exp_prob)] - - # Repeatedly split into groups. The number of groups is determined using - # sturges rule. - repeated_groups <- lapply( - seq_len(n_groups), - function(ii, x, y, sample_identifiers) { - - return(create_randomised_groups( - x = x, - y = y, - sample_identifiers = sample_identifiers, - n_min_y_in_group = 4)) - }, - x = data$exp_prob, - y = data$event, - sample_identifiers = data[, mget(get_id_columns(id_depth = "series"))]) - - # Iterate over groups and add details by comparing the kaplan-meier survival - # curve within each group at time with the mean survival probability in - # the group. - calibration_table <- lapply( - seq_along(repeated_groups), - function(ii, groups, data, time) { - - return(..compute_calibration_data_survival( - data = data, - groups = groups[[ii]], - time = time, - ii = ii)) - }, - groups = repeated_groups, - data = data, - time = time) - - # Concatenate to table. - calibration_table <- data.table::rbindlist( - calibration_table, - use.names = TRUE) - - # Prevent processing of empty tables. - if (is_empty(calibration_table)) return(NULL) - - # Set column order. - data.table::setcolorder( - x = calibration_table, - neworder = c("expected", "observed", "km_var", "n_g", "rep_id")) - - return(calibration_table) -} - - - -..compute_calibration_data_survival <- function( - groups, - data, - time, - ii) { - - # Suppress NOTES due to non-standard evaluation in data.table - .NATURAL <- NULL - - # Placeholder variables - obs_prob <- exp_prob <- n_g <- km_var <- numeric(length(groups)) - - # Check that the groups list contains at least one entry. - if (is_empty(groups)) return(NULL) - - # Get observed and expected probabilities over the groups - for (jj in seq_along(groups)) { - - # Find data for the current group - group_data <- data[unique(groups[[jj]]), on = .NATURAL] - - if (nrow(group_data) >= 2) { - - # Fit a Kaplan-Meier curve for the current group - km_fit <- survival::survfit(Surv(time, event) ~ 1, data = group_data) - - if (length(km_fit$time) >= 2) { - - # Get observed probability - obs_prob[jj] <- stats::approx( - x = km_fit$time, - y = km_fit$surv, - xout = time, - method = "linear", - rule = 2)$y - - # Get expected probability - exp_prob[jj] <- mean(group_data$exp_prob) - - # Get group size - n_g[jj] <- length(groups[[jj]]) - - # Get greenwood variance estimate. - km_var[jj] <- stats::approx( - x = km_fit$time, - y = km_fit$std.err, - xout = time, - method = "linear", - rule = 2)$y^2 - - } else { - # Set NA values. - obs_prob[jj] <- exp_prob[jj] <- km_var[jj] <- NA_real_ - n_g[jj] <- NA_integer_ - } - - } else { - # Set NA values. - obs_prob[jj] <- exp_prob[jj] <- km_var[jj] <- NA_real_ - n_g[jj] <- NA_integer_ - } - } - - # Create table. - calibration_table <- data.table::data.table( - "expected" = exp_prob, - "observed" = obs_prob, - "n_g" = n_g, - "km_var" = km_var, - "rep_id" = ii) - - return(calibration_table) -} - - - -.compute_calibration_data_categorical <- function( - data, - positive_class, - n_groups = 1L) { - # For assessing the calibration of categorical outcomes, we require expected - # and observed probabilities for 1 (binomial) or all classes (multinomial). - # Expected probabilities are easy, as the model predicts them. Observed - # probabilities are however based on class proportion within a group. This - # means that we need to define groups, ordered by predicted probability. The - # same groups need to be defined for the Hosmer-Lemeshow test, so we might as - # well obtain all the data here. - # - # Groups are defined for each class level because the samples should be - # ordered according to predicted class probability to create the groups. - - # Suppress NOTES due to non-standard evaluation in data.table - observed_class <- exp_prob <- NULL - - # Determine outcome column - positive_class_column_name <- get_class_probability_name(x = positive_class) - - # Identify the real outcome columns - outcome_column <- get_outcome_columns(x = "binomial") - - # Find sample identifiers. - sample_identifiers <- get_id_columns(id_depth = "series") - - # Create a local copy of the data table - data <- data.table::copy(data[, mget(c(sample_identifiers, outcome_column, positive_class_column_name))]) - - # Only select instances with known outcomes and probabilities - data <- data[!(is.na(get(outcome_column)) | is.na(get(positive_class_column_name))), ] - - # Check that there is actually any data to work with - if (is_empty(data)) return(NULL) - - # Rename columns to standard names - data.table::setnames( - data, - old = c(outcome_column, positive_class_column_name), - new = c("observed_class", "exp_prob")) - - # Mask class so that positive outcomes are TRUE and the rest FALSE - data[, "observed_class" := observed_class == positive_class] - - # Sort by probability - data <- data[order(exp_prob)] - - # Repeatedly split into groups. The number of groups is determined using - # sturges rule. - repeated_groups <- lapply( - seq_len(n_groups), - function(ii, x, sample_identifiers) { - - return(create_randomised_groups( - x = x, - sample_identifiers = sample_identifiers)) - }, - x = data$exp_prob, - sample_identifiers = data[, mget(sample_identifiers)]) - - # Iterate over groups - calibration_table <- lapply( - seq_len(length(repeated_groups)), - function(ii, groups, data) { - - return(..compute_calibration_data_categorical( - data = data, - groups = groups[[ii]], - ii = ii)) - }, - data = data, - groups = repeated_groups) - - # Combine to a single list. - calibration_table <- data.table::rbindlist( - calibration_table, - use.names = TRUE) - - # Check that any calibration data was generated. - if (is_empty(calibration_table)) return(NULL) - - # Set column order - data.table::setcolorder( - x = calibration_table, - neworder = c("expected", "observed", "n_g", "n_pos", "n_neg", "rep_id")) - - return(calibration_table) -} - - - -..compute_calibration_data_categorical <- function( - groups, - data, - ii) { - - # Suppress NOTES due to non-standard evaluation in data.table - .NATURAL <- NULL - - # Set placeholders. - obs_prob <- exp_prob <- n_g <- n_pos <- n_neg <- numeric(length(groups)) - - # Check that the groups list contains at least one entry. - if (is_empty(groups)) return(NULL) - - # Get observed and expected probabilities over the groups - for (jj in seq_along(groups)) { - # Find data for the current group - group_data <- data[unique(groups[[jj]]), on = .NATURAL] - - # Mean expected probability in a group. - exp_prob[jj] <- mean(group_data$exp_prob) - - # Observed proportion of positive class in a group. - obs_prob[jj] <- mean(group_data$observed_class) - - # Number of samples in the group - n_g[jj] <- nrow(group_data) - - # Number of samples with the positive class in each group. - n_pos[jj] <- sum(group_data$observed_class) - - # Number of samples with the negative class in each group. - n_neg[jj] <- sum(!group_data$observed_class) - } - - # Create table - calibration_table <- data.table::data.table( - "expected" = exp_prob, - "observed" = obs_prob, - "n_g" = n_g, - "n_pos" = n_pos, - "n_neg" = n_neg, - "rep_id" = ii) - - return(calibration_table) -} - - - -.compute_calibration_data_regression <- function( - object, - data, - n_groups = 1L) { - # Calibration for regression problems is pretty straightforward. However, for - # goodness-of-fit tests, we need to constrain expected and observed value - # ranges to [0, 1]. To do so, we use the range of outcome values from the - # development data, as stored in the calibration_info slot of the input - # object. - - # Suppress NOTES due to non-standard evaluation in data.table - outcome <- predicted_outcome <- NULL - - # Remove non-finite predicted values. - data <- data[is.finite(outcome) & is.finite(predicted_outcome), ] - - # Check for empty required data. - if (is_empty(data)) return(NULL) - if (is.null(object@outcome_info)) return(NULL) - - # Determine the outcome range - outcome_range <- range(object@outcome_info@distribution$fivenum) - - # Get the shift and scale parameters. - norm_shift <- outcome_range[1] - norm_scale <- diff(outcome_range) - - # Set scale parameters equal to 0.0 to 1.0 to avoid division by 0. - if (norm_scale == 0.0) norm_scale <- 1.0 - - # Apply normalisation. - data[, ":="( - "expected" = (predicted_outcome - norm_shift) / norm_scale, - "observed" = (outcome - norm_shift) / norm_scale)] - - # Repeatedly split into groups. The number of groups is determined using - # sturges rule. - repeated_groups <- lapply( - seq_len(n_groups), - function(ii, x, sample_identifiers) { - - return(create_randomised_groups( - x = x, - sample_identifiers = sample_identifiers)) - }, - x = data$expected, - sample_identifiers = data[, mget(get_id_columns(id_depth = "series"))]) - - # Iterate over groups - calibration_table <- lapply( - seq_len(length(repeated_groups)), - function(ii, groups, data) { - - return(..compute_calibration_data_regression( - data = data, - groups = groups[[ii]], - ii = ii)) - }, - data = data, - groups = repeated_groups) - - # Concatenate to a single table - calibration_table <- data.table::rbindlist( - calibration_table, - use.names = TRUE) - - # Check if the resulting table contains data. - if (is_empty(calibration_table)) return(NULL) - - # Make columns match the expected order - data.table::setcolorder( - x = calibration_table, - neworder = c("expected", "observed", "n_g", "rep_id")) - - return(calibration_table) -} - - - -..compute_calibration_data_regression <- function( - groups, - data, - ii) { - - # Suppress NOTES due to non-standard evaluation in data.table - .NATURAL <- NULL - - # Set placeholders. - obs_prob <- exp_prob <- n_g <- numeric(length(groups)) - - # Check that the groups list contains at least one entry. - if (is_empty(groups)) return(NULL) - - # Get observed and expected probabilities over the groups - for (jj in seq_along(groups)) { - # Find data for the current group - group_data <- data[unique(groups[[jj]]), on = .NATURAL] - - # Mean expected probability in a group. - exp_prob[jj] <- mean(group_data$expected) - - # Observed proportion of positive class in a group. - obs_prob[jj] <- mean(group_data$observed) - - # Number of samples in the group - n_g[jj] <- nrow(group_data) - } - - # Create table - calibration_table <- data.table::data.table( - "expected" = exp_prob, - "observed" = obs_prob, - "n_g" = n_g, - "rep_id" = ii) - - return(calibration_table) -} - - - .compute_calibration_linear_fit <- function( calibration_data, - outcome_type) { + outcome_type +) { # Tests calibration-at-the-large and calibration slope # Suppress NOTES due to non-standard evaluation in data.table. @@ -969,22 +1325,16 @@ setMethod( calibration_data <- calibration_data[is.finite(expected) & is.finite(observed)] # Check if the input is empty or only contains one entry - if (nrow(calibration_data) < 2) return(NULL) + if (nrow(calibration_data) < 2L) return(NULL) # Fit per repeated measurement. - fit_data <- lapply( - split(calibration_data, by = "rep_id"), - ..compute_calibration_fit, - outcome_type = outcome_type) - - # Concatenate to a single table. - fit_data <- data.table::rbindlist( - fit_data, - use.names = TRUE) + fit_data <- ..compute_calibration_fit( + calibration_data, + outcome_type = outcome_type + ) # Remove NaNs fit_data <- fit_data[is.finite(p_value)] - if (is_empty(fit_data)) return(NULL) return(fit_data) @@ -994,7 +1344,8 @@ setMethod( ..compute_calibration_fit <- function( calibration_data, - outcome_type) { + outcome_type +) { # Suppress NOTES due to non-standard evaluation in data.table. type <- value <- ci_low <- ci_up <- NULL @@ -1003,13 +1354,14 @@ setMethod( # directly compare with the expected slope of 1. fit <- stats::lm( observed ~ expected + 1 + offset(expected), - data = calibration_data) + data = calibration_data + ) # Get coefficients for intercept and slope fit_coef <- stats::coef(fit) # Determine if there is no slope. - no_slope <- is.na(fit_coef["expected"]) && data.table::uniqueN(calibration_data$expected) + no_slope <- is.na(fit_coef["expected"]) && data.table::uniqueN(calibration_data$expected) == 1L if (no_slope) fit_coef["expected"] <- 0.0 # Get confidence intervals @@ -1021,7 +1373,7 @@ setMethod( if (no_slope) { fit_summary <- rbind( fit_summary, - matrix(data = c(0.0, Inf, 0.0, 1.0), ncol = 4) + matrix(data = c(0.0, Inf, 0.0, 1.0), ncol = 4L) ) rownames(fit_summary) <- c("(Intercept)", "expected") } @@ -1031,38 +1383,32 @@ setMethod( if (outcome_type %in% c("binomial", "multinomial", "survival")) { # Determine the number of groups. - n_groups <- data.table::uniqueN(calibration_data, by = "rep_id") + n_groups <- 1L # Recompute the standard deviation - fit_summary[, 2] <- fit_summary[, 2] * sqrt(n_groups) + fit_summary[, 2L] <- fit_summary[, 2L] * sqrt(n_groups) # Recompute the t-score - fit_summary[, 3] <- fit_summary[, 1] / fit_summary[, 2] - fit_summary[, 3][fit_summary[, 2] == 0.0] <- Inf + fit_summary[, 3L] <- fit_summary[, 1L] / fit_summary[, 2L] + fit_summary[, 3L][fit_summary[, 2L] == 0.0] <- Inf # Recompute the p-value - fit_summary[, 4] <- 2.0 * stats::pt(abs(fit_summary[, 3]), fit$df.residual, lower.tail = FALSE) + fit_summary[, 4L] <- 2.0 * stats::pt(abs(fit_summary[, 3L]), fit$df.residual, lower.tail = FALSE) # Adapt the confidence intervals - fit_conf_int[, 1] <- fit_summary[, 1] + fit_summary[, 2] * stats::qnorm(0.025) - fit_conf_int[, 2] <- fit_summary[, 1] + fit_summary[, 2] * stats::qnorm(0.975) + fit_conf_int[, 1L] <- fit_summary[, 1L] + fit_summary[, 2L] * stats::qnorm(0.025) + fit_conf_int[, 2L] <- fit_summary[, 1L] + fit_summary[, 2L] * stats::qnorm(0.975) } - # Construct data table + # Construct data table and update the slope so that the expected slope + # (slope+1) is shown instead. calibration_at_large <- data.table::data.table( "type" = c("offset", "slope"), - "value" = fit_coef, - "ci_low" = fit_conf_int[, 1], - "ci_up" = fit_conf_int[, 2], - "p_value" = fit_summary[, 4]) - - # Update the slope so that the expected slope (slope+1) is shown instead - calibration_at_large[ - type == "slope", - ":="( - "value" = value + 1, - "ci_low" = ci_low + 1, - "ci_up" = ci_up + 1)] + "value" = fit_coef + c(0.0, 1.0), + "ci_low" = fit_conf_int[, 1L] + c(0.0, 1.0), + "ci_up" = fit_conf_int[, 2L] + c(0.0, 1.0), + "p_value" = fit_summary[, 4L] + ) return(calibration_at_large) } @@ -1086,33 +1432,39 @@ setMethod( # Compute test statistic for each group calibration_data[ - , "hm_group" := ..compute_calibration_test_statistic(observed, expected, n_g), - by = seq_len(nrow(calibration_data))] + , + "hm_group" := ..compute_calibration_test_statistic(observed, expected, n_g), + by = seq_len(nrow(calibration_data)) + ] # Remove NA values in hm_group calibration_data <- calibration_data[is.finite(hm_group)] if (is_empty(calibration_data)) return(NULL) # Compute test statistic for each time point - gof_table <- calibration_data[, list("statistic" = sum(hm_group, na.rm = TRUE), n_groups = .N), - by = "rep_id"] + gof_table <- calibration_data[ + , + list("statistic" = sum(hm_group, na.rm = TRUE), n_groups = .N) + ] # Remove all entries with n_groups < 3 - gof_table <- gof_table[n_groups >= 3] + gof_table <- gof_table[n_groups >= 3L] if (is_empty(gof_table)) return(NULL) # Perform chi-square test - gof_table <- gof_table[, list(p_value = stats::pchisq( - q = statistic, - df = n_groups - 2, - lower.tail = FALSE)), - by = "rep_id"] - - # Add type and drop rep_id. + gof_table <- gof_table[ + , + list("p_value" = stats::pchisq( + q = statistic, + df = n_groups - 2L, + lower.tail = FALSE + )) + ] + + # Add type. gof_table[, "type" := "hosmer_lemeshow"] - gof_table[, "rep_id" := NULL] - + # Reorder columns data.table::setcolorder(gof_table, c("type", "p_value")) @@ -1125,11 +1477,13 @@ setMethod( observed, expected, n_g, - method = "approximate") { + method = "approximate" +) { if (!method %in% c("exact", "approximate")) { ..error_reached_unreachable_code( - "..compute_hm_test_statistic: method should be exact or approximate") + "..compute_hm_test_statistic: method should be exact or approximate" + ) } # Check for infinite or NA values. @@ -1138,20 +1492,20 @@ setMethod( if (method == "exact") { # Use exact computation for comparison. Note that this has asymptotic # behaviour for expected -> 0 and expected -> 1. - value <- (observed - expected)^2 * n_g / (expected * (1 - expected)) + value <- (observed - expected)^2.0 * n_g / (expected * (1.0 - expected)) return(value) } else if (method == "approximate") { # Use exact computation for comparison. - exact_value <- (observed - expected)^2 * n_g / (expected * (1 - expected)) + exact_value <- (observed - expected)^2.0 * n_g / (expected * (1.0 - expected)) if (!is.finite(exact_value)) exact_value <- Inf if (expected <= 0.05) { # Use Taylor series for 1/(x * (1-x)) to second order at 0.05. - value <- n_g * (expected - observed)^2 * 400 * - (1 / 19 - 360 / 361 * (expected - 1 / 20)) + value <- n_g * (expected - observed)^2.0 * 400.0 * + (1.0 / 19.0 - 360.0 / 361.0 * (expected - 1.0 / 20.0)) if (exact_value < value) value <- exact_value if (value < 0.0) value <- 0.0 @@ -1159,8 +1513,8 @@ setMethod( } else if (expected >= 0.95) { # Use Taylor series for 1/(x * (1-x)) to second order at 0.95. - value <- n_g * (expected - observed)^2 * 400 * - (1 / 19 + 360 / 361 * (expected - 19 / 20)) + value <- n_g * (expected - observed)^2.0 * 400.0 * + (1.0 / 19.0 + 360.0 / 361.0 * (expected - 19.0 / 20.0)) if (exact_value < value) value <- exact_value if (value < 0.0) value <- 0.0 @@ -1196,10 +1550,13 @@ setMethod( # Compute test statistic for each group. calibration_data[ - , ":="( + , + ":="( "nd_group" = ..compute_calibration_test_statistic(observed, expected, n_g), - "gnd_group" = (observed - expected)^2 / km_var), - by = seq_len(nrow(calibration_data))] + "gnd_group" = (observed - expected)^2.0 / km_var + ), + by = seq_len(nrow(calibration_data)) + ] # Remove NA values in hm_group calibration_data <- calibration_data[is.finite(nd_group) & is.finite(gnd_group)] @@ -1207,25 +1564,30 @@ setMethod( # Compute test statistic for each time point gof_table <- calibration_data[ - , list( + , + list( "nam_dagostino" = sum(nd_group, na.rm = TRUE), "greenwood_nam_dagostino" = sum(gnd_group, na.rm = TRUE), - "n_groups" = .N), - by = "rep_id"] + "n_groups" = .N + ) + ] # Compute test score for both test tests. gof_table <- gof_table[ - n_groups > 1, + n_groups > 1L, list( "nam_dagostino" = stats::pchisq( q = nam_dagostino, - df = n_groups - 1, - lower.tail = FALSE), + df = n_groups - 1L, + lower.tail = FALSE + ), "greenwood_nam_dagostino" = stats::pchisq( q = greenwood_nam_dagostino, - df = n_groups - 1, - lower.tail = FALSE)), - by = "rep_id"] + df = n_groups - 1L, + lower.tail = FALSE + ) + ) + ] # Check for an empty goodness-of-fit table. if (is_empty(gof_table)) return(NULL) @@ -1233,18 +1595,17 @@ setMethod( # Melt so that each test is on a separate row gof_table <- data.table::melt( gof_table, - id.vars = "rep_id", variable.name = "type", value.name = "p_value", - variable.factor = FALSE) - - # Drop rep_id. - gof_table[, "rep_id" := NULL] + measure.vars = colnames(gof_table), + variable.factor = FALSE + ) # Reorder columns data.table::setcolorder( x = gof_table, - neworder = c("type", "p_value")) + neworder = c("type", "p_value") + ) return(gof_table) } @@ -1253,7 +1614,8 @@ setMethod( ..compute_calibration_data_interpolated <- function( data, - method = "loess") { + method = "loess" +) { # Suppress NOTES due to non-standard evaluation in data.table observed <- expected <- NULL @@ -1263,7 +1625,8 @@ setMethod( expected_interpolated <- seq( from = 0.000, to = 1.000, - by = 0.005) + by = 0.005 + ) # Select only unique entries. data <- unique(data) @@ -1276,33 +1639,36 @@ setMethod( # Switch interpolation method for small number of predictions. if (method == "loess") { - if (n_instances >= 4) { - degree <- 2 + if (n_instances >= 4L) { + degree <- 2L - } else if (n_instances == 3) { - degree <- 1 + } else if (n_instances == 3L) { + degree <- 1L - } else if (n_instances == 2) { + } else if (n_instances == 2L) { method <- "linear" } else { return(list( "expected" = NA_real_, - "observed" = NA_real_)) + "observed" = NA_real_ + )) } } else if (method == "linear") { - if (n_instances < 2) { + if (n_instances < 2L) { return(list( "expected" = NA_real_, - "observed" = NA_real_)) + "observed" = NA_real_ + )) } } else { ..error_reached_unreachable_code(paste0( "..compute_calibration_data_interpolated: unexpected interpolation ", - "method encountered: ", method)) + "method encountered: ", method + )) } if (method == "linear") { @@ -1313,36 +1679,37 @@ setMethod( y = data$observed, xout = expected_interpolated, method = "linear", - rule = 1)$y) + rule = 1L + )$y) } else if (method == "loess") { # Set up the loess model. - loess_predictor <- suppressWarnings( - stats::loess( - observed ~ expected, - data = data, - span = 1.0, - degree = degree, - normalize = FALSE, - control = stats::loess.control(surface = "direct"))) + loess_predictor <- suppressWarnings(stats::loess( + observed ~ expected, + data = data, + span = 1.0, + degree = degree, + normalize = FALSE, + control = stats::loess.control(surface = "direct") + )) # Predicted interpolated values. observed_interpolated <- suppressWarnings(predict( loess_predictor, - newdata = expected_interpolated)) + newdata = expected_interpolated + )) } # Set expected values and the corresponding interpolated observed values. - return(list( + return(data.table::data.table( "expected" = expected_interpolated, - "observed" = observed_interpolated)) + "observed" = observed_interpolated + )) } -# ..compute_data_element_estimates methods ------------------------------------- - -## ..compute_data_element_estimates (familiarDataElementCalibrationData) ------- +# ..compute_data_element_estimates (familiarDataElementCalibrationData) -------- setMethod( "..compute_data_element_estimates", signature(x = "familiarDataElementCalibrationData"), @@ -1361,7 +1728,8 @@ setMethod( # Point estimates need to be for all expected probability values, # which means that we have to compute it from the data. x <- .add_point_estimate_from_elements( - x = x[estimation_type %in% c("bci", "bootstrap_confidence_interval")]) + x = x[estimation_type %in% c("bci", "bootstrap_confidence_interval")] + ) } # Check that x is not empty. @@ -1373,7 +1741,7 @@ setMethod( -## ..compute_data_element_estimates (familiarDataElementCalibrationLinearFit) ----- +# ..compute_data_element_estimates (familiarDataElementCalibrationLinearFit) ---- setMethod( "..compute_data_element_estimates", signature(x = "familiarDataElementCalibrationLinearFit"), @@ -1396,37 +1764,41 @@ setMethod( if (any(estimation_type %in% c("bci", "bootstrap_confidence_interval"))) { # Obtain data from bootstrapped data. - data <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1]]@data + data <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1L]]@data } else { - data <- x[[1]]@data + data <- x[[1L]]@data } # Get the grouping column. - grouping_column <- x[[1]]@grouping_column + grouping_column <- x[[1L]]@grouping_column # Compute p-value by grouping column. p_value <- data[ - , list("p_value" = harmonic_p_value(p_value)), - by = c(grouping_column)] + , + list("p_value" = harmonic_p_value(p_value)), + by = c(grouping_column) + ] # Merge data into y@data <- merge( x = y@data, y = p_value, - by = grouping_column) + by = grouping_column + ) # Update value column y@value_column <- setdiff( names(y@data), - y@grouping_column) + y@grouping_column + ) return(y) } ) -## ..compute_data_element_estimates (familiarDataElementCalibrationGoodnessOfFit) ----- +# ..compute_data_element_estimates (familiarDataElementCalibrationGoodnessOfFit) ----- setMethod( "..compute_data_element_estimates", signature(x = "familiarDataElementCalibrationGoodnessOfFit"), @@ -1446,10 +1818,10 @@ setMethod( if (any(estimation_type %in% c("bci", "bootstrap_confidence_interval"))) { # Obtain data from bootstrapped data. - x <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1]] + x <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1L]] } else { - x <- x[[1]] + x <- x[[1L]] } # Get the grouping column. @@ -1459,20 +1831,20 @@ setMethod( # be used (e.g. Fisher's method). Hence we calculate a harmonic mean p value # according to Wilson (2019), 10.1073/pnas.1814092116. x@data <- x@data[ - , list("p_value" = harmonic_p_value(p_value)), - by = c(grouping_column)] + , + list("p_value" = harmonic_p_value(p_value)), + by = c(grouping_column) + ] # Update value column - x@value_column <- setdiff( - names(x@data), - x@grouping_column) + x@value_column <- setdiff(names(x@data), x@grouping_column) return(x) } ) -## ..compute_data_element_estimates (familiarDataElementCalibrationDensity) ---- +# ..compute_data_element_estimates (familiarDataElementCalibrationDensity) ----- setMethod( "..compute_data_element_estimates", signature(x = "familiarDataElementCalibrationDensity"), @@ -1492,10 +1864,10 @@ setMethod( if (any(estimation_type %in% c("bci", "bootstrap_confidence_interval"))) { # Obtain data from bootstrapped data. - x <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1]] + x <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1L]] } else { - x <- x[[1]] + x <- x[[1L]] } # Get the grouping column. @@ -1503,25 +1875,27 @@ setMethod( # Compute frequency by grouping column. x@data <- x@data[ - , list("frequency" = sum(frequency)), - by = c(grouping_column)] + , + list("frequency" = sum(frequency)), + by = c(grouping_column) + ] # Normalise frequency by all grouping columns minus expected. grouping_column <- setdiff(grouping_column, "expected") - if (length(grouping_column) > 0) { + if (length(grouping_column) > 0L) { x@data <- x@data[ - , "frequency" := frequency / sum(frequency), - by = c(grouping_column)][order(expected)] + , + "frequency" := frequency / sum(frequency), + by = c(grouping_column) + ][order(expected)] } else { x@data <- x@data[, "frequency" := frequency / sum(frequency)][order(expected)] } # Update value column - x@value_column <- setdiff( - names(x@data), - x@grouping_column) + x@value_column <- setdiff(names(x@data), x@grouping_column) return(x) } @@ -1571,7 +1945,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_calibration_data") } ) @@ -1589,7 +1964,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -1602,7 +1978,8 @@ setMethod( aggregate_results = aggregate_results, type = "calibration", subtype = "data", - object_class = "familiarDataElementCalibrationData") + object_class = "familiarDataElementCalibrationData" + ) # Obtain linear fit data linear_fit_data <- .export( @@ -1612,7 +1989,8 @@ setMethod( aggregate_results = aggregate_results, type = "calibration", subtype = "at_large", - object_class = "familiarDataElementCalibrationLinearFit") + object_class = "familiarDataElementCalibrationLinearFit" + ) # Obtain goodness of fit data gof_data <- .export( @@ -1622,7 +2000,8 @@ setMethod( aggregate_results = aggregate_results, type = "calibration", subtype = "gof_test", - object_class = "familiarDataElementCalibrationGoodnessOfFit") + object_class = "familiarDataElementCalibrationGoodnessOfFit" + ) # Obtain density data density_data <- .export( @@ -1632,14 +2011,16 @@ setMethod( aggregate_results = aggregate_results, type = "calibration", subtype = "density", - object_class = "familiarDataElementCalibrationDensity") + object_class = "familiarDataElementCalibrationDensity" + ) # Set data list. data_list <- list( "data" = calibration_data, "density" = density_data, "linear_test" = linear_fit_data, - "gof_test" = gof_data) + "gof_test" = gof_data + ) if (!is.null(dir_path)) data_list <- NULL if (export_collection) data_list <- c(data_list, list("collection" = object)) @@ -1661,7 +2042,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -1670,8 +2052,11 @@ setMethod( list( "object" = object, "data_element" = "calibration_data", - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_calibration_data, @@ -1680,7 +2065,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationCalibrationInfo.R b/R/FamiliarDataComputationCalibrationInfo.R index 10f83e8e..b5e13e27 100644 --- a/R/FamiliarDataComputationCalibrationInfo.R +++ b/R/FamiliarDataComputationCalibrationInfo.R @@ -10,7 +10,9 @@ setClass( slots = list("outcome_type" = "ANY"), prototype = methods::prototype( estimation_type = "point", - outcome_type = NULL)) + outcome_type = NULL + ) +) @@ -20,7 +22,7 @@ setClass( #' #'@description Collects . #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list of familiarDataElements with hyperparameters. #'@md @@ -32,7 +34,8 @@ setGeneric( detail_level = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_calibration_info") } ) @@ -47,28 +50,32 @@ setMethod( object, detail_level = waiver(), message_indent = 0L, - verbose = FALSE) { + verbose = FALSE + ) { # Extracts calibration info for survival outcomes. Note that some routines - # for count and continuous outcomes are available, but not used. + # for continuous outcomes are available, but not used. if (!object@outcome_type %in% c("survival")) return(NULL) # Message extraction start logger_message( paste0("Extracting calibration information."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Check the level detail. detail_level <- .parse_detail_level( x = detail_level, object = object, default = "ensemble", - data_element = "calibration_info") + data_element = "calibration_info" + ) proto_data_element <- methods::new( "familiarDataElementCalibrationInfo", - detail_level = detail_level) + detail_level = detail_level + ) # Generate elements to send to dispatch. calibration_info <- extract_dispatcher( @@ -79,7 +86,8 @@ setMethod( proto_data_element = proto_data_element, aggregate_results = FALSE, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(calibration_info) } @@ -87,10 +95,24 @@ setMethod( +# extract_calibration_info (prediction table) ---------------------------------- +setMethod( + "extract_calibration_info", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("extract calibration info") + + return(NULL) + } +) + + + .extract_calibration_info <- function( object, proto_data_element, - ...) { + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -109,12 +131,10 @@ setMethod( # Set value and grouping columns. if (object@outcome_type == "survival") { - data_element@value_column <- setdiff( - colnames(data_element@data), "time") - + data_element@value_column <- setdiff(colnames(data_element@data), "time") data_element@grouping_column <- "time" - } else if (object@outcome_type %in% c("count", "continuous")) { + } else if (object@outcome_type %in% c("continuous")) { data_element@value_column <- colnames(data_element@data) } else { @@ -147,62 +167,77 @@ setMethod( data <- data.table::rbindlist( lapply(x, function(x) (x@data)), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) - if (x[[1]]@outcome_type %in% c("continuous", "count")) { + if (x[[1L]]@outcome_type %in% c("continuous")) { - # Extract min and max values of the range for continuous and count type - # outcomes. - if (is.null(x[[1]]@grouping_column)) { - data <- data[, list( - "min_value" = min(min_value), - "max_value" = max(max_value))] + # Extract min and max values of the range for continuous type outcomes. + if (is.null(x[[1L]]@grouping_column)) { + data <- data[ + , + list( + "min_value" = min(min_value), + "max_value" = max(max_value) + ) + ] } else { - data <- data[, list( - "min_value" = min(min_value), - "max_value" = max(max_value)), - by = x[[1]]]@grouping_column + data <- data[ + , + list( + "min_value" = min(min_value), + "max_value" = max(max_value) + ), + by = x[[1L]]@grouping_column + ] } - } else if (x[[1]]@outcome_type %in% c("survival")) { + } else if (x[[1L]]@outcome_type %in% c("survival")) { # Identify all unique time points. new_time <- sort(unique(data$time)) # Find non-time grouping columns. grouping_column <- setdiff( - colnames(data), c("time", x[[1]]@value_column)) + colnames(data), c("time", x[[1L]]@value_column) + ) # Select only unique data points to prevent warnings during approximation. data <- unique(data) - if (length(grouping_column) > 0) { + if (length(grouping_column) > 0L) { # Interpolate survival columns by grouping column. data <- data[ - , ..interpolate_survival_data(.SD, time = time, new_time = new_time), + , + ..interpolate_survival_data(.SD, time = time, new_time = new_time), by = c(grouping_column), - .SDcols = x[[1]]@value_column] + .SDcols = x[[1L]]@value_column + ] } else { # Interpolate survival columns. data <- data[ - , ..interpolate_survival_data(.SD, time = time, new_time = new_time), - .SDcols = x[[1]]@value_column] + , + ..interpolate_survival_data(.SD, time = time, new_time = new_time), + .SDcols = x[[1L]]@value_column + ] } # Compute mean value at each time point, by group. data <- data[ - , lapply(.SD, mean, na.rm = TRUE), - by = c(x[[1]]@grouping_column), - .SDcols = c(x[[1]]@value_column)] + , + lapply(.SD, mean, na.rm = TRUE), + by = c(x[[1L]]@grouping_column), + .SDcols = c(x[[1L]]@value_column) + ] } else { - ..error_outcome_type_not_implemented(outcome_type = x[[1]]@outcome_type) + ..error_outcome_type_not_implemented(outcome_type = x[[1L]]@outcome_type) } # Copy data element. - y <- x[[1]] + y <- x[[1L]] y@data <- data return(y) @@ -215,32 +250,38 @@ setMethod( data, time, new_time, - extrapolate = FALSE) { + extrapolate = FALSE +) { # Get columns names. value_columns <- colnames(data) # Interpolate survival data. - data <- data[, lapply( - .SD, - function(y, x, x_out, extrapolate) { - return(stats::approx( - x = x, - y = y, - xout = x_out, - rule = ifelse(extrapolate, 2, 1), - method = "linear")$y) - }, - x = time, - x_out = new_time, - extrapolate = extrapolate)] + data <- data[ + , + lapply( + .SD, + function(y, x, x_out, extrapolate) { + return(stats::approx( + x = x, + y = y, + xout = x_out, + rule = ifelse(extrapolate, 2L, 1L), + method = "linear" + )$y) + }, + x = time, + x_out = new_time, + extrapolate = extrapolate + ) + ] # Insert time column. data[, "time" := new_time] # Select only finite values. This removes extrapolated values in case # extrapolate equals FALSE. - data <- data[!is.na(value_columns[1])] + data <- data[!is.na(value_columns[1L])] return(as.list(data)) } @@ -285,7 +326,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_calibration_info") } ) @@ -301,7 +343,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -309,7 +352,7 @@ setMethod( if (object@outcome_type %in% c("binomial", "multinomial")) { return(NULL) - } else if (object@outcome_type %in% c("count", "continuous")) { + } else if (object@outcome_type %in% c("continuous")) { subtype <- "observed_value_range" } else if (object@outcome_type %in% c("survival")) { @@ -326,7 +369,8 @@ setMethod( aggregate_results = aggregate_results, type = "calibration", subtype = subtype, - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -343,7 +387,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -351,8 +396,11 @@ setMethod( args = c( list( "object" = object, - "data_element" = "calibration_info"), - list(...))) + "data_element" = "calibration_info" + ), + list(...) + ) + ) return(do.call( export_calibration_info, @@ -361,7 +409,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationConfusionMatrix.R b/R/FamiliarDataComputationConfusionMatrix.R index 04c7897b..a3a80b9d 100644 --- a/R/FamiliarDataComputationConfusionMatrix.R +++ b/R/FamiliarDataComputationConfusionMatrix.R @@ -9,7 +9,9 @@ setClass( contains = "familiarDataElement", prototype = methods::prototype( value_column = "count", - grouping_column = c("observed_outcome", "expected_outcome"))) + grouping_column = c("observed_outcome", "expected_outcome") + ) +) @@ -20,7 +22,7 @@ setClass( #'@description Computes and extracts the confusion matrix for predicted and #' observed categorical outcomes used in a `familiarEnsemble` object. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A data.table containing predicted and observed outcome data together #' with a co-occurence count. @@ -37,7 +39,8 @@ setGeneric( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_confusion_matrix") } ) @@ -56,7 +59,8 @@ setMethod( detail_level = waiver(), is_pre_processed = FALSE, message_indent = 0L, - verbose = FALSE) { + verbose = FALSE + ) { # Don't compute a confusion matrix if there is nothing to be computed. if (!object@outcome_type %in% c("binomial", "multinomial")) return(NULL) @@ -65,23 +69,87 @@ setMethod( logger_message( paste0("Computing confusion matrix."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) - # Obtain ensemble method from stored settings, if required. if (is.waive(ensemble_method)) ensemble_method <- object@settings$ensemble_method + + proto_data_element <- .create_extract_confusion_matrix_object( + object = object, + ensemble_method = ensemble_method, + detail_level = detail_level + ) - # Check the level detail. - detail_level <- .parse_detail_level( - x = detail_level, + # Generate elements to send to dispatch. + confusion_matrix_data <- extract_dispatcher( + FUN = .extract_confusion_matrix, + has_internal_bootstrap = FALSE, + cl = cl, object = object, - default = "ensemble", - data_element = "confusion_matrix") + data = data, + proto_data_element = proto_data_element, + is_pre_processed = is_pre_processed, + ensemble_method = ensemble_method, + aggregate_results = TRUE, + message_indent = message_indent + 1L, + verbose = verbose + ) - # Generate a prototype data element. - proto_data_element <- new( - "familiarDataElementConfusionMatrix", - detail_level = detail_level, - estimation_type = "point") + return(confusion_matrix_data) + } +) + + + +# extract_confusion_matrix (prediction table) ---------------------------------- +setMethod( + "extract_confusion_matrix", + signature("familiarDataElementPredictionTable"), + function( + object, + data, + cl = NULL, + ensemble_method = waiver(), + detail_level = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE + ) { + if (is_empty(object)) return(NULL) + + if (!is(object, "predictionTableClassification")) { + ..warning_no_data_extraction_from_prediction_table("confusion matrix") + + return(NULL) + } + + # Reference labels should be present. + if (!.has_reference_data(object)) { + ..warning_prediction_table_lacks_reference("confusion matrix") + return(NULL) + } + + # Message extraction start + logger_message( + paste0("Computing confusion matrix."), + indent = message_indent, + verbose = verbose + ) + + if (is.waive(ensemble_method)) { + ensemble_method <- "median" + if (methods::.hasSlot(object, "ensemble_method")) ensemble_method <- object@ensemble_method + } + if (is.waive(detail_level)) detail_level <- "ensemble" + + # Copy object to prevent changing the provided object by reference. + object <- .copy(object) + + proto_data_element <- .create_extract_confusion_matrix_object( + object = object, + ensemble_method = ensemble_method, + detail_level = detail_level + ) # Generate elements to send to dispatch. confusion_matrix_data <- extract_dispatcher( @@ -95,7 +163,8 @@ setMethod( ensemble_method = ensemble_method, aggregate_results = TRUE, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(confusion_matrix_data) } @@ -103,62 +172,154 @@ setMethod( +.create_extract_confusion_matrix_object <- function( + object, + detail_level, + ensemble_method +) { + # Check the level detail. + detail_level <- .parse_detail_level( + x = detail_level, + object = object, + default = "ensemble", + data_element = "confusion_matrix" + ) + + # Check ensemble_method argument + .check_parameter_value_is_valid( + x = ensemble_method, + var_name = "ensemble_method", + values = .get_available_ensemble_prediction_methods() + ) + + proto_data_element <- new( + "familiarDataElementConfusionMatrix", + detail_level = detail_level, + estimation_type = "point" + ) + + return(proto_data_element) +} + + + .extract_confusion_matrix <- function( object, proto_data_element, - data, - is_pre_processed, - ensemble_method, - verbose, - message_indent = 0L, - ...) { - - # Suppress NOTES due to non-standard evaluation in data.table - count <- NULL + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) - if (object@outcome_type %in% c("binomial", "multinomial")) { - # Iterate over outcome classes. - - # Add model name. - data_element <- add_model_name(proto_data_element, object = object) + if (!object@outcome_type %in% c("binomial", "multinomial")) { + ..error_outcome_type_not_implemented(object@outcome_type) + } + + # Add model name. + data_element <- add_model_name(proto_data_element, object = object) + + return(..extract_confusion_matrix( + object = object, + data_element = data_element, + ... + )) +} + + + +# ..extract_confusion_matrix (generic) ----------------------------------------- +setGeneric( + "..extract_confusion_matrix", + function(object, ...) standardGeneric("..extract_confusion_matrix") +) + + + +# ..extract_confusion_matrix (character) --------------------------------------- +setMethod( + "..extract_confusion_matrix", + signature(object = "character"), + function( + object, + ... + ){ + # Ensure that the object is loaded + object <- load_familiar_object(object) + return(..extract_confusion_matrix(object = object, ...)) + } +) + + + +# ..extract_confusion_matrix (model, ensemble) --------------------------------- +setMethod( + "..extract_confusion_matrix", + signature(object = "familiarModelUnion"), + function( + object, + data, + ensemble_method, + is_pre_processed, + ... + ) { # Predict class probabilities. prediction_data <- .predict( object = object, data = data, ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed) + is_pre_processed = is_pre_processed + ) - if (!all_predictions_valid( - prediction_table = prediction_data, - outcome_type = object@outcome_type)) { - return(NULL) - } + if (is_empty(prediction_data)) return(NULL) + + return(..extract_confusion_matrix( + object = prediction_data, + ... + )) + } +) + + + +# ..extract_confusion (classification) ----------------------------------------- +setMethod( + "..extract_confusion_matrix", + signature(object = "predictionTableClassification"), + function( + object, + data_element, + ... + ) { + # Suppress NOTES due to non-standard evaluation in data.table + count <- NULL + + if (!all_predictions_valid(object)) return(NULL) # Remove data with missing outcomes. - prediction_data <- remove_missing_outcomes( - data = prediction_data, - outcome_type = object@outcome_type) + object <- filter_missing_outcome(object) # Check that any prediction data remain. - if (is_empty(prediction_data)) return(NULL) + if (is_empty(object)) return(NULL) # Make a local copy with only the required data - data <- prediction_data[, c("outcome", "predicted_class")] + data <- .copy(object) + data <- .as_data_table(.complete(object)) + data <- data[, c("outcome", "predicted_class")] # Rename outcome columns data.table::setnames( x = data, old = c("outcome", "predicted_class"), - new = c("observed_outcome", "expected_outcome")) + new = c("observed_outcome", "expected_outcome") + ) # Sum pairs of observed and expected outcome categories. data <- data[ , list("count" = .N), - by = c("observed_outcome", "expected_outcome")] + by = c("observed_outcome", "expected_outcome") + ] # Find class levels in the data class_levels <- get_outcome_class_levels(object) @@ -167,31 +328,41 @@ setMethod( empty_matrix <- data.table::data.table(expand.grid( list( "observed_outcome" = class_levels, - "expected_outcome" = class_levels), - stringsAsFactors = FALSE)) + "expected_outcome" = class_levels + ), + stringsAsFactors = FALSE + )) empty_matrix[, "count" := 0L] # Combine data with the empty matrix to add in combinations that appear 0 # times. - data <- data.table::rbindlist( - list(data, empty_matrix), - use.names = TRUE) + data <- data.table::rbindlist(list(data, empty_matrix), use.names = TRUE) # Use a max operation to remove any combinations that appear twice in the # table. data <- data[ - , list("count" = max(count)), - by = c("observed_outcome", "expected_outcome")] + , + list("count" = max(count)), + by = c("observed_outcome", "expected_outcome") + ] # Set data element. data_element@data <- data - } else { - ..error_outcome_type_not_implemented(object@outcome_type) + return(data_element) } - - return(data_element) -} +) + + + +# ..extract_confusion (NULL) --------------------------------------------------- +setMethod( + "..extract_confusion_matrix", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) @@ -231,7 +402,8 @@ setGeneric( object, dir_path = NULL, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_confusion_matrix_data") } ) @@ -248,7 +420,8 @@ setMethod( object, dir_path = NULL, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -260,7 +433,8 @@ setMethod( aggregate_results = TRUE, type = "performance", subtype = "confusion_matrix", - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -276,7 +450,8 @@ setMethod( object, dir_path = NULL, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -284,8 +459,11 @@ setMethod( args = c( list( "object" = object, - "data_element" = "confusion_matrix"), - list(...))) + "data_element" = "confusion_matrix" + ), + list(...) + ) + ) return(do.call( export_confusion_matrix_data, @@ -293,7 +471,10 @@ setMethod( list( "object" = object, "dir_path" = dir_path, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationDecisionCurveAnalysis.R b/R/FamiliarDataComputationDecisionCurveAnalysis.R index 897decc5..d973f885 100644 --- a/R/FamiliarDataComputationDecisionCurveAnalysis.R +++ b/R/FamiliarDataComputationDecisionCurveAnalysis.R @@ -9,7 +9,9 @@ setClass( contains = "familiarDataElement", prototype = methods::prototype( value_column = "net_benefit", - grouping_column = "threshold_probability")) + grouping_column = "threshold_probability" + ) +) # exract_decision_curve_data (generic) ----------------------------------------- @@ -23,7 +25,7 @@ setClass( #' For survival outcomes, the Nam-D'Agostino and Greenwood-Nam-D'Agostino tests #' are performed. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list with data.tables containing calibration test information for #' the ensemble model. @@ -45,7 +47,8 @@ setGeneric( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_decision_curve_data") } ) @@ -69,92 +72,157 @@ setMethod( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { - # Decision curve analysis is only available for categorical and - # survival outcomes. - if (object@outcome_type %in% c("count", "continuous")) return(NULL) + # Decision curve analysis is only available for categorical and survival + # outcomes. + if (!object@outcome_type %in% c("binomial", "multinomial", "survival")) return(NULL) # Message extraction start logger_message( paste0("Computing data for decision curve analysis."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) - # Load evaluation_times from the object settings attribute, if it is not provided. if (is.waive(evaluation_times)) evaluation_times <- object@settings$eval_times - - # Check evaluation_times argument - if (object@outcome_type %in% c("survival")) { - sapply( - evaluation_times, - .check_number_in_valid_range, - var_name = "evaluation_times", - range = c(0.0, Inf), - closed = c(FALSE, TRUE)) - } - - # Obtain ensemble method from stored settings, if required. if (is.waive(ensemble_method)) ensemble_method <- object@settings$ensemble_method - - # Check ensemble_method argument - .check_parameter_value_is_valid( - x = ensemble_method, - var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) - - # Load confidence alpha from object settings attribute if not - # provided externally. if (is.waive(confidence_level)) confidence_level <- object@settings$confidence_level - - # Check confidence_level input argument - .check_number_in_valid_range( - x = confidence_level, - var_name = "confidence_level", - range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) - - # Load the bootstrap method if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- object@settings$bootstrap_ci_method - .check_parameter_value_is_valid( - x = bootstrap_ci_method, - var_name = "bootstrap_ci_method", - values = .get_available_bootstrap_confidence_interval_methods()) + # Test if models are properly loaded + if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() - # Check the level detail. - detail_level <- .parse_detail_level( - x = detail_level, + # Check whether results should be aggregated. + aggregate_results <- .parse_aggregate_results( + x = aggregate_results, object = object, - default = "hybrid", - data_element = "decision_curve_analyis") + default = TRUE, + data_element = "decision_curve_analyis" + ) - # Check the estimation type. - estimation_type <- .parse_estimation_type( - x = estimation_type, + # Generate a prototype data element. + proto_data_element <- .create_extract_decision_curve_object( object = object, - default = "bootstrap_confidence_interval", - data_element = "decision_curve_analyis", + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, detail_level = detail_level, - has_internal_bootstrap = TRUE) + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) + + # Generate elements to send to dispatch. + dca_data <- extract_dispatcher( + FUN = .extract_decision_curve_data, + has_internal_bootstrap = TRUE, + cl = cl, + object = object, + data = data, + proto_data_element = proto_data_element, + is_pre_processed = is_pre_processed, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + aggregate_results = aggregate_results, + message_indent = message_indent + 1L, + verbose = verbose + ) + + return(dca_data) + } +) + + + +# extract_decision_curve_data (prediction table) ------------------------------- +setMethod( + "extract_decision_curve_data", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + data, + cl = NULL, + ensemble_method = waiver(), + evaluation_times = waiver(), + detail_level = waiver(), + estimation_type = waiver(), + aggregate_results = waiver(), + confidence_level = waiver(), + bootstrap_ci_method = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE, + ... + ) { + if (is_empty(object)) return(NULL) + + # Decision curve analysis is only available for categorical and survival + # outcomes. + if (!( + is(object, "predictionTableSurvivalProbability") || + is(object, "predictionTableClassification") + )) { + ..warning_no_data_extraction_from_prediction_table("decision curves") + + return(NULL) + } + # Reference labels should be present. + if (!.has_reference_data(object)) { + ..warning_prediction_table_lacks_reference("decision curves") + return(NULL) + } + + # Message extraction start + logger_message( + paste0("Computing data for decision curve analysis."), + indent = message_indent, + verbose = verbose + ) + + if (is.waive(evaluation_times) && methods::.hasSlot(object, "time")) { + evaluation_times <- object@time + } + if (is.waive(ensemble_method)) { + ensemble_method <- "median" + if (methods::.hasSlot(object, "ensemble_method")) ensemble_method <- object@ensemble_method + } + + # Default Values. + if (is.waive(detail_level)) detail_level <- "ensemble" + if (is.waive(estimation_type)) estimation_type <- "bootstrap_confidence_interval" + if (is.waive(confidence_level)) confidence_level <- 0.95 + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- "bc" + if (is.waive(aggregate_results)) aggregate_results <- TRUE # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = TRUE, - data_element = "decision_curve_analyis") + data_element = "decision_curve_analyis" + ) - # Test if models are properly loaded - if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() + # Copy object to prevent changing the provided object by reference. + object <- .copy(object) # Generate a prototype data element. - proto_data_element <- new( - "familiarDataElementDecisionCurve", + proto_data_element <- .create_extract_decision_curve_object( + object = object, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, detail_level = detail_level, estimation_type = estimation_type, confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method) + bootstrap_ci_method = bootstrap_ci_method + ) + + if (is(object, "predictionTableSurvivalProbability")) { + proto_data_element <- add_data_element_identifier( + x = proto_data_element, + evaluation_time = object@time + )[[1L]] + } # Generate elements to send to dispatch. dca_data <- extract_dispatcher( @@ -169,7 +237,8 @@ setMethod( evaluation_times = evaluation_times, aggregate_results = aggregate_results, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(dca_data) } @@ -177,7 +246,110 @@ setMethod( -.extract_decision_curve_data <- function( +.create_extract_decision_curve_object <- function( + object, + ensemble_method, + evaluation_times, + detail_level, + estimation_type, + confidence_level, + bootstrap_ci_method +) { + + # Check evaluation_times argument + if (object@outcome_type %in% c("survival")) { + sapply( + evaluation_times, + .check_number_in_valid_range, + var_name = "evaluation_times", + range = c(0.0, Inf), + closed = c(FALSE, TRUE) + ) + } + + # Check confidence_level input argument. + .check_number_in_valid_range( + x = confidence_level, + var_name = "confidence_level", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + + # Check ensemble_method argument. + .check_parameter_value_is_valid( + x = ensemble_method, + var_name = "ensemble_method", + values = .get_available_ensemble_prediction_methods() + ) + + # bootstrap_ci_method + .check_parameter_value_is_valid( + x = bootstrap_ci_method, + var_name = "bootstrap_ci_method", + values = .get_available_bootstrap_confidence_interval_methods() + ) + + # Check the level detail. + detail_level <- .parse_detail_level( + x = detail_level, + object = object, + default = "hybrid", + data_element = "decision_curve_analyis" + ) + + # Check the estimation type. + estimation_type <- .parse_estimation_type( + x = estimation_type, + object = object, + default = "bootstrap_confidence_interval", + data_element = "decision_curve_analyis", + detail_level = detail_level, + has_internal_bootstrap = TRUE + ) + + # Generate a prototype data element. + proto_data_element <- new( + "familiarDataElementDecisionCurve", + detail_level = detail_level, + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) + + return(proto_data_element) +} + + + +# .extract_decision_curve_data (generic) -------------------------------------- +setGeneric( + ".extract_decision_curve_data", + function(object, ...) standardGeneric(".extract_decision_curve_data") +) + + +# .extract_decision_curve_data (character) ------------------------------------- +setMethod( + ".extract_decision_curve_data", + signature(object = "character"), + function( + object, + ... + ){ + # Ensure that the object is loaded + object <- load_familiar_object(object) + + return(.extract_decision_curve_data(object = object, ...)) + } +) + + + +# .extract_decision_curve_data (familiarModelUnion) ---------------------------- +setMethod( + ".extract_decision_curve_data", + signature(object = "familiarModelUnion"), + function( object, data, proto_data_element, @@ -185,141 +357,252 @@ setMethod( cl, ensemble_method, is_pre_processed, - ...) { - - # Ensure that the object is loaded - object <- load_familiar_object(object) - - # Add model name. - proto_data_element <- add_model_name(proto_data_element, object = object) - - # Add evaluation time as a identifier to the data element. - if (length(evaluation_times) > 0 && object@outcome_type == "survival") { - data_elements <- add_data_element_identifier( - x = proto_data_element, - evaluation_time = evaluation_times) + ... + ) { + # Add model name. + proto_data_element <- add_model_name(proto_data_element, object = object) - } else if (object@outcome_type %in% c("binomial", "multinomial")) { + if (length(evaluation_times) > 0L && object@outcome_type == "survival") { + # Add evaluation time as a identifier to the data element. + data_elements <- add_data_element_identifier( + x = proto_data_element, + evaluation_time = evaluation_times + ) + + } else { + data_elements <- list(proto_data_element) + } - # Predict class probabilities. - prediction_data <- .predict( - object = object, - data = data, - ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed) + if (object@outcome_type == "survival") { + dca_data <- lapply( + data_elements, + function(data_element, object, data, ensemble_method, is_pre_processed, ...) { + prediction_table <- .predict( + object = object, + data = data, + time = data_element@identifiers$evaluation_time, + ensemble_method = ensemble_method, + is_pre_processed = is_pre_processed, + type = "survival_probability" + ) + + return(.extract_decision_curve_data( + object = prediction_table, + proto_data_element = data_element, + ... + )) + }, + object = object, + data = data, + ensemble_method = ensemble_method, + is_pre_processed = is_pre_processed, + ... + ) + + } else if (object@outcome_type %in% c("binomial", "multinomial")) { + prediction_table <- .predict( + object = object, + data = data, + ensemble_method = ensemble_method, + is_pre_processed = is_pre_processed + ) + + dca_data <- mapply( + .extract_decision_curve_data, + proto_data_element = data_elements, + MoreArgs = c( + list("object" = prediction_table), + list(...) + ), + SIMPLIFY = FALSE + ) + + } else { + ..error_outcome_type_not_implemented(object@outcome_type) + } + return(dca_data) + } +) + + + +# .extract_decision_curve_data (classification) -------------------------------- +setMethod( + ".extract_decision_curve_data", + signature(object = "predictionTableClassification"), + function( + object, + proto_data_element, + aggregate_results, + cl = NULL, + progress_bar = FALSE, + verbose = FALSE, + message_indent = 0L, + ... + ) { # Check if any predictions are valid. - if (!all_predictions_valid( - prediction_data, - outcome_type = object@outcome_type)) { - return(NULL) - } + if (!all_predictions_valid(object)) return(NULL) # Remove data with missing outcomes. - prediction_data <- remove_missing_outcomes( - data = prediction_data, - outcome_type = object@outcome_type) + object <- filter_missing_outcome(object) + if (is_empty(object)) return(NULL) - # Check that any prediction data remain. - if (is_empty(prediction_data)) return(NULL) + data <- .as_data_table(object) + if (nrow(data) <= 1L) return(NULL) # Determine class levels outcome_class_levels <- get_outcome_class_levels(object) # Select only one outcome class for binomial outcomes. - if (object@outcome_type == "binomial") outcome_class_levels <- outcome_class_levels[2] + if (object@outcome_type == "binomial") outcome_class_levels <- outcome_class_levels[2L] # Add positive class as an identifier. data_elements <- add_data_element_identifier( x = proto_data_element, - positive_class = outcome_class_levels) + positive_class = outcome_class_levels + ) - } else { - data_elements <- list(proto_data_element) - } - - # Dispatch to function - if (object@outcome_type %in% c("binomial", "multinomial")) { - dca_data <- lapply( - data_elements, - .compute_dca_data_categorical, - data = prediction_data, - cl = cl, - ...) + # Add bootstrap data. + bootstrap_data <- add_data_element_bootstrap(x = data_elements, ...) - } else if (object@outcome_type %in% c("survival")) { - dca_data <- lapply( - data_elements, - .compute_dca_data_survival, - data = data, - object = object, - ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed, + if (length(bootstrap_data) > 1L && progress_bar) { + logger_message( + paste0( + "Computing decision curves for the ", + paste_s(outcome_class_levels), + ifelse(length(outcome_class_levels) == 1L, " class.", " classes.") + ), + indent = message_indent, + verbose = verbose + ) + } + + # Set test probabilities + threshold_probabilities <- seq( + from = 0.000, + to = 1.000, + by = 0.005 + ) + + # Iterate over elements. + data_elements <- fam_mapply( cl = cl, - ...) + assign = NULL, + FUN = .compute_dca_data_categorical_model, + data_element = bootstrap_data$data_element, + bootstrap = bootstrap_data$bootstrap, + bootstrap_seed = bootstrap_data$seed, + MoreArgs = list( + "data" = data, + "threshold_probabilities" = threshold_probabilities + ), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) - } else { - ..error_outcome_type_not_implemented(object@outcome_type) + # Merge data elements + data_elements <- merge_data_elements(data_elements) + + if (aggregate_results) data_elements <- .compute_data_element_estimates(x = data_elements) + + return(data_elements) } - - return(dca_data) -} +) -.compute_dca_data_categorical <- function( - data_element, - data, +# .extract_decision_curve_data (survival probability) -------------------------- +setMethod( + ".extract_decision_curve_data", + signature(object = "predictionTableSurvivalProbability"), + function( + object, + proto_data_element, aggregate_results, cl = NULL, progress_bar = FALSE, verbose = FALSE, message_indent = 0L, - ...) { - - # Check if the data has more than 1 row. - if (nrow(data) <= 1) return(NULL) - - if (length(data_element@identifiers$positive_class) > 0 && progress_bar) { - logger_message( - paste0( - "Computing decision curves for the \"", - data_element@identifiers$positive_class, "\" class."), - indent = message_indent, - verbose = verbose) + ... + ) { + + # Check if any predictions are valid. + if (!all_predictions_valid(object)) return(NULL) + + # Remove data with missing outcomes. + object <- filter_missing_outcome(object) + if (is_empty(object)) return(NULL) + + data <- .as_data_table(object) + if (nrow(data) <= 1L) return(NULL) + + # Add bootstrap data. + bootstrap_data <- add_data_element_bootstrap(x = proto_data_element, ...) + + # Message the user concerning the time at which the decision curves are + # computed. This is only relevant for survival analysis, where survival + # probability is time depend. + if (length(bootstrap_data) > 0L && progress_bar) { + message_str <- "Computing decision curves" + if (!is.null(proto_data_element@identifiers$evaluation_time)) { + message_str <- c( + message_str, + " at time ", proto_data_element@identifiers$evaluation_time, "." + ) + + } else { + message_str <- c(message_str, ".") + } + + logger_message( + paste0(message_str, collapse = ""), + indent = message_indent, + verbose = verbose + ) + } + + # Set test probabilities + threshold_probabilities <- seq( + from = 0.000, + to = 1.000, + by = 0.005 + ) + + # Iterate over elements. + data_elements <- fam_mapply( + cl = cl, + assign = NULL, + FUN = .compute_dca_data_survival_model, + data_element = bootstrap_data$data_element, + bootstrap = bootstrap_data$bootstrap, + bootstrap_seed = bootstrap_data$seed, + MoreArgs = list( + "data" = data, + "threshold_probabilities" = threshold_probabilities + ), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) + + # Merge data elements + data_elements <- merge_data_elements(data_elements) + + if (aggregate_results) data_elements <- .compute_data_element_estimates(x = data_elements) + + return(data_elements) } - - # Set test probabilities - threshold_probabilities <- seq( - from = 0.000, - to = 1.000, - by = 0.005) - - # Add bootstrap data. - bootstrap_data <- add_data_element_bootstrap(x = data_element, ...) - - # Iterate over elements. - data_elements <- fam_mapply( - cl = cl, - assign = NULL, - FUN = .compute_dca_data_categorical_model, - data_element = bootstrap_data$data_element, - bootstrap = bootstrap_data$bootstrap, - bootstrap_seed = bootstrap_data$seed, - MoreArgs = list( - "data" = data, - "threshold_probabilities" = threshold_probabilities), - progress_bar = progress_bar, - chopchop = TRUE) - - # Merge data elements - data_elements <- merge_data_elements(data_elements) - - if (aggregate_results) data_elements <- .compute_data_element_estimates(x = data_elements) - - return(data_elements) -} +) + +# .extract_decision_curve_data (NULL) ------------------------------------------ +setMethod( + ".extract_decision_curve_data", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) .compute_dca_data_categorical_model <- function( @@ -327,7 +610,8 @@ setMethod( data, threshold_probabilities, bootstrap, - bootstrap_seed) { + bootstrap_seed +) { # Suppress NOTES due to non-standard evaluation in data.table outcome <- probability <- is_positive <- NULL @@ -339,15 +623,17 @@ setMethod( if (bootstrap) { data <- get_bootstrap_sample( data = data, - seed = bootstrap_seed) + seed = bootstrap_seed + ) } # Make a local copy data <- data.table::copy(data) data.table::setnames( x = data, - old = get_class_probability_name(positive_class), - new = "probability") + old = positive_class, + new = "probability" + ) # Determine positive output. data[, "is_positive" := outcome == positive_class] @@ -376,18 +662,21 @@ setMethod( # Set the data attribute. intervention_data_element@data <- data.table::data.table( "threshold_probability" = threshold_probabilities, - "net_benefit" = intervention_net_benefit) + "net_benefit" = intervention_net_benefit + ) # Set the curve type identifier. intervention_data_element <- add_data_element_identifier( x = intervention_data_element, - curve_type = "intervention_all") + curve_type = "intervention_all" + ) # Determine the number of true and false positives to determine the net # benefit of the model. data[, ":="( "n_true_positive" = cumsum(is_positive), - "n_false_positive" = cumsum(!is_positive))] + "n_false_positive" = cumsum(!is_positive) + )] # Compute benefit for the model. model_net_benefit <- ..compute_dca_data_net_benefit(data, threshold_probabilities) @@ -397,116 +686,37 @@ setMethod( # Set the data attribute data_element@data <- data.table::data.table( "threshold_probability" = threshold_probabilities, - "net_benefit" = model_net_benefit) + "net_benefit" = model_net_benefit + ) # Set the curve type identifier. data_element <- add_data_element_identifier( x = data_element, - curve_type = "model") + curve_type = "model" + ) return(c( data_element, - intervention_data_element)) + intervention_data_element + )) } -.compute_dca_data_survival <- function( - data_element, - data, - object, - ensemble_method, - aggregate_results, - is_pre_processed, - cl = NULL, - progress_bar = FALSE, - verbose = FALSE, - message_indent = 0L, - ...) { - - # Predict survival probabilities. - data <- .predict( - object = object, - data = data, - time = data_element@identifiers$evaluation_time, - ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed, - type = "survival_probability") - - # Check if any predictions are valid. - if (!all_predictions_valid( - data, - outcome_type = object@outcome_type)) { - return(NULL) - } - - # Remove data with missing outcomes. - data <- remove_missing_outcomes( - data = data, - outcome_type = object@outcome_type) - - # Check that any prediction data remain. - if (is_empty(data)) return(NULL) - - # Check if the data has more than 1 row. - if (nrow(data) <= 1) return(NULL) - - # Message the user concerning the time at which the decision curves are - # computed. This is only relevant for survival analysis, where survival - # probability is time depend. - if (length(data_element@identifiers$evaluation_time) > 0 && progress_bar) { - logger_message( - paste0( - "Computing decision curves at time ", - data_element@identifiers$evaluation_time, "."), - indent = message_indent, - verbose = verbose) - } - - # Set test probabilities - threshold_probabilities <- seq( - from = 0.000, - to = 1.000, - by = 0.005) - - # Add bootstrap data. - bootstrap_data <- add_data_element_bootstrap(x = data_element, ...) - - # Iterate over elements. - data_elements <- fam_mapply( - cl = cl, - assign = NULL, - FUN = .compute_dca_data_survival_model, - data_element = bootstrap_data$data_element, - bootstrap = bootstrap_data$bootstrap, - bootstrap_seed = bootstrap_data$seed, - MoreArgs = list( - "data" = data, - "threshold_probabilities" = threshold_probabilities), - progress_bar = progress_bar, - chopchop = TRUE) - - # Merge data elements - data_elements <- merge_data_elements(data_elements) - - if (aggregate_results) data_elements <- .compute_data_element_estimates(x = data_elements) - - return(data_elements) -} - - .compute_dca_data_survival_model <- function( data_element, data, threshold_probabilities, bootstrap, - bootstrap_seed) { + bootstrap_seed +) { # Bootstrap the data. if (bootstrap) { data <- get_bootstrap_sample( data = data, - seed = bootstrap_seed) + seed = bootstrap_seed + ) } # Compute benefit for the situation an intervention always happens. @@ -514,7 +724,8 @@ setMethod( data = data, x = threshold_probabilities, evaluation_time = data_element@identifiers$evaluation_time, - intervention = TRUE) + intervention = TRUE + ) # Copy data element for intervention. intervention_data_element <- data_element @@ -522,35 +733,41 @@ setMethod( # Set the data attribute. intervention_data_element@data <- data.table::data.table( "threshold_probability" = threshold_probabilities, - "net_benefit" = intervention_net_benefit) + "net_benefit" = intervention_net_benefit + ) # Set the curve type identifier. intervention_data_element <- add_data_element_identifier( x = intervention_data_element, - curve_type = "intervention_all") + curve_type = "intervention_all" + ) # Compute benefit for the model. model_net_benefit <- ..compute_dca_data_net_benefit_survival( data = data, x = threshold_probabilities, evaluation_time = data_element@identifiers$evaluation_time, - intervention = FALSE) + intervention = FALSE + ) if (is.null(model_net_benefit)) return(NULL) # Set the data attribute data_element@data <- data.table::data.table( "threshold_probability" = threshold_probabilities, - "net_benefit" = model_net_benefit) + "net_benefit" = model_net_benefit + ) # Set the curve type identifier. data_element <- add_data_element_identifier( x = data_element, - curve_type = "model") + curve_type = "model" + ) return(c( data_element, - intervention_data_element)) + intervention_data_element + )) } @@ -570,20 +787,21 @@ setMethod( # Determine net benefit. data[, ":="( "net_benefit" = n_true_positive / n - - n_false_positive / n * (probability / (1.0 - probability)))] + n_false_positive / n * (probability / (1.0 - probability)) + )] # Net benefit should be numeric. data <- data[is.finite(net_benefit)] # Check if the data has more than 1 row. - if (nrow(data) <= 1) return(NULL) + if (nrow(data) <= 1L) return(NULL) # If the predicted probability occurs more than once, select the lowest net # benefit. data <- data[, list("net_benefit" = min(net_benefit)), by = "probability"] # Check if the data has more than 1 row. - if (nrow(data) <= 1) return(NULL) + if (nrow(data) <= 1L) return(NULL) # Compute net benefit at the test probabilities. net_benefit <- suppressWarnings(stats::approx( @@ -592,7 +810,8 @@ setMethod( xout = x, yleft = n_max_true_positive / n, yright = -Inf, - method = "linear")$y) + method = "linear" + )$y) return(net_benefit) } @@ -603,10 +822,11 @@ setMethod( data, x, evaluation_time, - intervention = FALSE) { + intervention = FALSE +) { # Suppress NOTES due to non-standard evaluation in data.table - survival_probability <- outcome_event <- outcome_time <- NULL + predicted_outcome <- outcome_event <- outcome_time <- NULL death <- censored <- n <- NULL # Prepare net benefit. @@ -627,10 +847,10 @@ setMethod( # We want to avoid running too many computations. Therefore, we will only # compute the number of true positives and false positives when the group size # changes. - previous_group_size <- n_group_size + 1 + previous_group_size <- n_group_size + 1L for (ii in seq_along(p_threshold)) { # Select the group of patients - surv_group <- data.table::copy(data[survival_probability >= x[ii]]) + surv_group <- data.table::copy(data[predicted_outcome >= x[ii]]) # Get the total group size of the group where predicted survival probability # exceeds the threshold probability. @@ -643,10 +863,10 @@ setMethod( n_true_positive <- n_true_positive n_false_positive <- n_false_positive - } else if (n_surv_group == 0) { + } else if (n_surv_group == 0L) { # There are no true and false positives, because there are no positives # with survival probability greater than the threshold. - n_true_positive <- n_false_positive <- 0 + n_true_positive <- n_false_positive <- 0L } else { # Create the basic part of the Kaplan-Meier data by summing the number of @@ -657,17 +877,17 @@ setMethod( surv_group <- surv_group[ outcome_time <= evaluation_time, list( - "death" = sum(outcome_event == 1), - "censored" = sum(outcome_event == 0)), - by = "outcome_time"][order(outcome_time)] + "death" = sum(outcome_event == 1L), + "censored" = sum(outcome_event == 0L) + ), + by = "outcome_time" + ][order(outcome_time)] - if (nrow(surv_group) > 0) { + if (nrow(surv_group) > 0L) { # Add group sizes at the start of each interval. - surv_group[, "n" := n_surv_group - data.table::shift( - cumsum(death + censored), - n = 1, - fill = 0, - type = "lag")] + surv_group[ + , "n" := n_surv_group - data.table::shift(cumsum(death + censored), n = 1L, fill = 0L, type = "lag") + ] # Compute the probability of survival in the interval surv_group[, "survival_in_interval" := (n - death) / n] @@ -741,7 +961,8 @@ setGeneric( object, dir_path = NULL, aggregate_results = TRUE, - ...) { + ... + ) { standardGeneric("export_decision_curve_analysis_data") } ) @@ -758,8 +979,8 @@ setMethod( object, dir_path = NULL, aggregate_results = TRUE, - ...) { - + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -769,7 +990,8 @@ setMethod( dir_path = dir_path, aggregate_results = aggregate_results, type = "decision_curve_analysis", - subtype = "data")) + subtype = "data" + )) } ) @@ -785,7 +1007,8 @@ setMethod( object, dir_path = NULL, aggregate_results = TRUE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -794,8 +1017,11 @@ setMethod( list( "object" = object, "data_element" = "decision_curve_analyis", - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_decision_curve_analysis_data, @@ -803,7 +1029,10 @@ setMethod( list( "object" = object, "dir_path" = dir_path, - "aggregate_results" = aggregate_results), - list(...)))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationFeatureExpression.R b/R/FamiliarDataComputationFeatureExpression.R index 77e2e602..da13b190 100644 --- a/R/FamiliarDataComputationFeatureExpression.R +++ b/R/FamiliarDataComputationFeatureExpression.R @@ -8,12 +8,15 @@ setClass( contains = "familiarDataElement", slots = list( "feature_info" = "ANY", - "evaluation_time" = "ANY"), + "evaluation_time" = "ANY" + ), prototype = methods::prototype( detail_level = "ensemble", estimation_type = "point", feature_info = NULL, - evaluation_time = NULL)) + evaluation_time = NULL + ) +) # extract_feature_expression (generic) ----------------------------------------- @@ -27,7 +30,7 @@ setClass( #' sample. This is used to determine cluster information, and indicate which #' samples are similar. The table is created by the #' `extract_sample_similarity` method. -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list with a data.table containing feature expressions. #'@md @@ -48,7 +51,8 @@ setGeneric( evaluation_times = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_feature_expression") } ) @@ -72,17 +76,21 @@ setMethod( sample_similarity_metric = waiver(), evaluation_times = waiver(), message_indent = 0L, - verbose = FALSE) { + verbose = FALSE + ) { # Message extraction start logger_message( paste0("Compute feature expression."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Obtain evaluation times from the data. - if (is.waive(evaluation_times) && - object@outcome_type %in% c("survival", "competing_risk")) { + if ( + is.waive(evaluation_times) && + object@outcome_type %in% c("survival", "competing_risk") + ) { evaluation_times <- object@settings$eval_times } else if (is.waive(evaluation_times)) { @@ -96,7 +104,8 @@ setMethod( .check_number_in_valid_range, var_name = "evaluation_times", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) } # Aggregate data @@ -108,7 +117,8 @@ setMethod( data <- process_input_data( object = object, data = data, - stop_at = "batch_normalisation") + stop_at = "batch_normalisation" + ) if (is_empty(data)) return(NULL) @@ -118,21 +128,21 @@ setMethod( # Maintain only important features. The current set is based on the # important features of the model, i.e. those that end up in the # model (potentially as a cluster). - expression_data <- filter_features( - data = data, - available_features = model_features) + expression_data <- filter_features(data = data, available_features = model_features) # Perform inverse normalisation expression_data <- normalise_features( data = expression_data, feature_info_list = object@feature_info, - invert = TRUE) + invert = TRUE + ) # Perform inverse transformation expression_data <- transform_features( data = expression_data, feature_info_list = object@feature_info, - invert = TRUE) + invert = TRUE + ) # Add sample_name to expression_data row_names <- get_unique_row_names(expression_data) @@ -141,7 +151,8 @@ setMethod( "batch_id" = NULL, "sample_id" = NULL, "series_id" = NULL, - "repetition_id" = NULL)] + "repetition_id" = NULL + )] # Set expression data. expression_data <- methods::new( @@ -149,7 +160,115 @@ setMethod( data = expression_data@data, feature_info = object@feature_info[model_features], evaluation_time = evaluation_times, - value_column = model_features) + value_column = model_features + ) + + # Add model name. + expression_data <- add_model_name(expression_data, object) + + return(list(expression_data)) + } +) + + + +# extract_feature_expression (prediction table) -------------------------------- +setMethod( + "extract_feature_expression", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("feature expression") + + return(NULL) + } +) + + + +# extract_feature_expression (dataObject) -------------------------------------- +setMethod( + "extract_feature_expression", + signature(object = "dataObject"), + function( + object, + data, + feature_similarity, + sample_similarity, + feature_cluster_method = waiver(), + feature_linkage_method = waiver(), + feature_similarity_metric = waiver(), + sample_cluster_method = waiver(), + sample_linkage_method = waiver(), + sample_similarity_metric = waiver(), + evaluation_times = waiver(), + message_indent = 0L, + verbose = FALSE + ) { + + # Message extraction start + logger_message( + paste0("Compute feature expression."), + indent = message_indent, + verbose = verbose + ) + + if ( + is.waive(evaluation_times) && + object@outcome_type %in% c("survival", "competing_risk") + ) { + # Get default evaluation times. + settings <- .parse_evaluation_time_settings( + data = object@data, + outcome_type = object@outcome_type + ) + + evaluation_times <- settings$eval_times + + } else if (is.waive(evaluation_times)) { + evaluation_times <- NULL + } + + # Check if evaluation_times is correct. + if (object@outcome_type %in% c("survival", "competing_risk")) { + sapply( + evaluation_times, + .check_number_in_valid_range, + var_name = "evaluation_times", + range = c(0.0, Inf), + closed = c(FALSE, TRUE) + ) + } + + if (is_empty(object)) return(NULL) + + # Generate feature info by running the familiarTaskGenericFeatureInfo task. + generic_feature_info_task <- new("familiarTaskGenericFeatureInfo") + object@feature_info <- .perform_task( + object = generic_feature_info_task, + data = object + ) + + # Perform inverse transformation + expression_data <- .copy(object) + + # Add sample_name to expression_data + row_names <- get_unique_row_names(expression_data) + expression_data@data[, ":="( + "sample_name" = row_names, + "batch_id" = NULL, + "sample_id" = NULL, + "series_id" = NULL, + "repetition_id" = NULL + )] + + # Set expression data. + expression_data <- methods::new( + "familiarDataElementFeatureExpression", + data = expression_data@data, + feature_info = object@feature_info, + evaluation_time = evaluation_times, + value_column = get_feature_columns(object) + ) # Add model name. expression_data <- add_model_name(expression_data, object) @@ -177,19 +296,14 @@ setMethod( #' #'@inheritDotParams extract_feature_expression #'@inheritDotParams as_familiar_collection +#'@inheritDotParams as_data_object #' -#'@details Data is usually collected from a `familiarCollection` object. -#' However, you can also provide one or more `familiarData` objects, that will -#' be internally converted to a `familiarCollection` object. It is also -#' possible to provide a `familiarEnsemble` or one or more `familiarModel` -#' objects together with the data from which data is computed prior to export. -#' Paths to the previous files can also be provided. -#' +#'@details #' All parameters aside from `object` and `dir_path` are only used if `object` #' is not a `familiarCollection` object, or a path to one. -#' -#' Feature expressions are computed by standardising each feature, i.e. sample -#' mean is 0 and standard deviation is 1. +#' +#' Feature similarity data can be created from `dataObject`, or `data.table` objects. +#' For `data.table`, see \code{\link{as_data_object}} for additional arguments. #' #'@return A data.table (if `dir_path` is not provided), or nothing, as all data #' is exported to `csv` files. @@ -203,7 +317,8 @@ setGeneric( dir_path = NULL, evaluation_time = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_feature_expressions") } ) @@ -221,7 +336,8 @@ setMethod( dir_path = NULL, evaluation_time = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -239,7 +355,8 @@ setMethod( evaluation_time, .check_number_in_valid_range, var_name = "evaluation_time", - range = c(0, Inf)) + range = c(0.0, Inf) + ) # Set clustering method. x <- lapply( @@ -248,7 +365,8 @@ setMethod( x@evaluation_time <- evaluation_time return(x) }, - evaluation_time = evaluation_time) + evaluation_time = evaluation_time + ) } return(.export( @@ -258,7 +376,8 @@ setMethod( aggregate_results = FALSE, type = "feature_expression", subtype = NULL, - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -275,7 +394,8 @@ setMethod( dir_path = NULL, evaluation_time = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -284,8 +404,11 @@ setMethod( list( "object" = object, "data_element" = "feature_expressions", - "evaluation_times" = evaluation_time), - list(...))) + "evaluation_times" = evaluation_time + ), + list(...) + ) + ) return(do.call( export_feature_expressions, @@ -294,8 +417,11 @@ setMethod( "object" = object, "dir_path" = dir_path, "evaluation_time" = evaluation_time, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -309,14 +435,16 @@ setMethod( x, x_list, aggregate_results = FALSE, - ...) { + ... + ) { # Add grouping columns to data. Note that we do not merge the data elements. x <- lapply( x_list, .identifier_as_data_attribute, identifier = "all", - as_grouping_column = TRUE) + as_grouping_column = TRUE + ) return(x) } diff --git a/R/FamiliarDataComputationFeatureSimilarity.R b/R/FamiliarDataComputationFeatureSimilarity.R index ba4969f7..39151e4c 100644 --- a/R/FamiliarDataComputationFeatureSimilarity.R +++ b/R/FamiliarDataComputationFeatureSimilarity.R @@ -12,7 +12,8 @@ setClass( "linkage_method" = "character", "cluster_cut_method" = "character", "similarity_threshold" = "ANY", - "dendrogram" = "ANY"), + "dendrogram" = "ANY" + ), prototype = methods::prototype( detail_level = "ensemble", similarity_metric = NA_character_, @@ -22,7 +23,9 @@ setClass( similarity_threshold = NULL, dendrogram = NULL, value_column = "value", - grouping_column = c("feature_name_1", "feature_name_2"))) + grouping_column = c("feature_name_1", "feature_name_2") + ) +) # extract_feature_similarity (generic) ----------------------------------------- @@ -33,7 +36,7 @@ setClass( #' used in a `familiarEnsemble` object. This table can be used to cluster #' features, and is exported directly by `export_feature_similarity`. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A data.table containing pairwise distance between features. This data #' is only the upper triangular of the complete matrix (i.e. the sparse @@ -59,7 +62,8 @@ setGeneric( feature_similarity_metric = waiver(), verbose = FALSE, message_indent = 0L, - ...) { + ... + ) { standardGeneric("extract_feature_similarity") } ) @@ -85,13 +89,15 @@ setMethod( feature_similarity_metric = waiver(), verbose = FALSE, message_indent = 0L, - ...) { + ... + ) { # Message extraction start logger_message( paste0("Computing pairwise similarity between features."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Obtain cluster method from stored settings, if required. if (is.waive(feature_cluster_method)) { @@ -129,7 +135,8 @@ setMethod( cluster_cut_method = feature_cluster_cut_method, cluster_similarity_threshold = feature_similarity_threshold, cluster_similarity_metric = feature_similarity_metric, - data_type = "feature") + data_type = "feature" + ) # Obtain confidence level from the settings file stored with the # familiarEnsemble object. @@ -142,7 +149,8 @@ setMethod( x = confidence_level, var_name = "confidence_level", range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) + closed = c(FALSE, FALSE) + ) # Load the bootstrap method if (is.waive(bootstrap_ci_method)) { @@ -152,7 +160,8 @@ setMethod( .check_parameter_value_is_valid( x = bootstrap_ci_method, var_name = "bootstrap_ci_methpd", - values = .get_available_bootstrap_confidence_interval_methods()) + values = .get_available_bootstrap_confidence_interval_methods() + ) # Check the estimation type. estimation_type <- .parse_estimation_type( @@ -161,14 +170,16 @@ setMethod( default = "point", data_element = "feature_similarity", detail_level = "ensemble", - has_internal_bootstrap = TRUE) + has_internal_bootstrap = TRUE + ) # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = TRUE, - data_element = "feature_similarity") + data_element = "feature_similarity" + ) # Generate a prototype data element. proto_data_element <- new( @@ -180,7 +191,8 @@ setMethod( cluster_method = feature_cluster_method, linkage_method = feature_linkage_method, cluster_cut_method = feature_cluster_cut_method, - similarity_threshold = feature_similarity_threshold) + similarity_threshold = feature_similarity_threshold + ) # Generate elements to send to dispatch. similarity_data <- extract_dispatcher( @@ -193,7 +205,166 @@ setMethod( is_pre_processed = is_pre_processed, aggregate_results = aggregate_results, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) + + return(similarity_data) + } +) + + +# extract_feature_similarity (familiarDataElementPredictionTable) -------------- +setMethod( + "extract_feature_similarity", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("feature similarity") + + return(NULL) + } +) + + + +# extract_feature_similarity (dataObject) -------------------------------------- + +setMethod( + "extract_feature_similarity", + signature(object = "dataObject"), + function( + object, + cl = NULL, + estimation_type = waiver(), + aggregate_results = waiver(), + confidence_level = waiver(), + bootstrap_ci_method = waiver(), + is_pre_processed = FALSE, + feature_cluster_method = waiver(), + feature_linkage_method = waiver(), + feature_cluster_cut_method = waiver(), + feature_similarity_threshold = waiver(), + feature_similarity_metric = waiver(), + verbose = FALSE, + message_indent = 0L, + ... + ) { + + # Message extraction start + logger_message( + paste0("Computing pairwise similarity between features."), + indent = message_indent, + verbose = verbose + ) + + # Parse input. + settings <- .parse_feature_clustering( + feature_cluster_method = feature_cluster_method, + feature_linkage_method = feature_linkage_method, + feature_cluster_cut_method = feature_cluster_cut_method, + feature_similarity_metric = feature_similarity_metric, + feature_similarity_threshold = feature_similarity_threshold + ) + + # There are no settings attached to dataObject, so we pass these through. + # Set default cluster method. + if (is.waive(feature_cluster_method)) { + feature_cluster_method <- settings$feature_cluster_method + } + + # Set default linkage method, if required. + if (is.waive(feature_linkage_method)) { + feature_linkage_method <- settings$feature_linkage_method + } + + # Set default cluster cut method, if required. + if (is.waive(feature_cluster_cut_method)) { + feature_cluster_cut_method <- settings$feature_cluster_cut_method + } + + # Set default cluster similarity threshold, if required. + if (is.waive(feature_similarity_threshold)) { + feature_similarity_threshold <- settings$feature_similarity_threshold + } + + # Obtain default similarity metric, if required. + if (is.waive(feature_similarity_metric)) { + feature_similarity_metric <- settings$feature_similarity_metric + } + + # Replace feature cluster method == "none" with "hclust" + if (feature_cluster_method == "none") feature_cluster_method <- "hclust" + + # Set default confidence level. + if (is.waive(confidence_level)) confidence_level <- 0.95 + + # Check alpha + .check_number_in_valid_range( + x = confidence_level, + var_name = "confidence_level", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + + # Load the bootstrap method + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- "percentile" + + .check_parameter_value_is_valid( + x = bootstrap_ci_method, + var_name = "bootstrap_ci_methpd", + values = .get_available_bootstrap_confidence_interval_methods() + ) + + # Check the estimation type. + estimation_type <- .parse_estimation_type( + x = estimation_type, + object = object, + default = "point", + data_element = "feature_similarity", + detail_level = "ensemble", + has_internal_bootstrap = TRUE + ) + + # Check whether results should be aggregated. + aggregate_results <- .parse_aggregate_results( + x = aggregate_results, + object = object, + default = TRUE, + data_element = "feature_similarity" + ) + + # Generate a prototype data element. + proto_data_element <- new( + "familiarDataElementFeatureSimilarity", + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method, + similarity_metric = feature_similarity_metric, + cluster_method = feature_cluster_method, + linkage_method = feature_linkage_method, + cluster_cut_method = feature_cluster_cut_method, + similarity_threshold = feature_similarity_threshold + ) + + # Generate feature info by running the familiarTaskGenericFeatureInfo task. + generic_feature_info_task <- new("familiarTaskGenericFeatureInfo") + object@feature_info <- .perform_task( + object = generic_feature_info_task, + data = object + ) + + # Generate elements to send to dispatch. + similarity_data <- extract_dispatcher( + FUN = .extract_feature_similarity, + has_internal_bootstrap = TRUE, + cl = cl, + object = object, + data = object, + proto_data_element = proto_data_element, + is_pre_processed = is_pre_processed, + aggregate_results = aggregate_results, + message_indent = message_indent + 1L, + verbose = verbose + ) return(similarity_data) } @@ -212,7 +383,8 @@ setMethod( n_bootstraps, message_indent = 0L, verbose = FALSE, - ...) { + ... +) { # Add the name of the ensemble model data_element <- add_model_name(data = proto_data_element, object = object) @@ -222,40 +394,41 @@ setMethod( object = object, data = data, stop_at = "imputation", - is_pre_processed = is_pre_processed) + is_pre_processed = is_pre_processed + ) # Check if the input data is not empty if (is_empty(data)) return(NULL) # Check if the number of samples is sufficient (>5), and return an empty table # if not. - if (data.table::uniqueN( - data@data, - by = get_id_columns(id_depth = "series")) <= 5) { - return(data_element) - } - - # Maintain only important features. The current set is based on the required - # features. - data <- filter_features( - data = data, - available_features = object@model_features) + if (get_n_samples(data, "series") <= 5L) return(NULL) + if (is(object, "familiarEnsemble")) { + # Maintain only important features. The current set is based on the required + # features. + data <- filter_features( + data = data, + available_features = get_model_features(object) + ) + } + # Identify eligible columns. feature_columns <- get_feature_columns(x = data) # Break if there are not at least 2 features present between which correlation # can be compared. - if (length(feature_columns) < 2) return(data_element) + if (length(feature_columns) < 2L) return(data_element) # Add bootstrap data. bootstrap_data <- add_data_element_bootstrap( x = data_element, n_bootstraps = n_bootstraps, - ...) + ... + ) # Iterate over elements. - if (n_bootstraps > 1) { + if (n_bootstraps > 1L) { data_elements <- fam_mapply( cl = cl, assign = NULL, @@ -265,9 +438,11 @@ setMethod( bootstrap_seed = bootstrap_data$seed, MoreArgs = list( "data" = data, - "feature_info_list" = object@feature_info), - progress_bar = progress_bar, - chopchop = TRUE) + "feature_info_list" = object@feature_info + ), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) } else { data_elements <- fam_mapply( @@ -282,8 +457,10 @@ setMethod( "feature_info_list" = object@feature_info, "cl" = cl, "verbose" = verbose, - "message_indent" = message_indent), - progress_bar = FALSE) + "message_indent" = message_indent + ), + progress_bar = FALSE + ) } @@ -305,22 +482,20 @@ setMethod( bootstrap, bootstrap_seed, message_indent = 0L, - verbose = FALSE) { + verbose = FALSE +) { # Bootstrap the data. if (bootstrap) { data <- get_bootstrap_sample( data = data, - seed = bootstrap_seed) + seed = bootstrap_seed + ) } # Check if the number of samples is sufficient (>5), and return an # empty table if not. - if (data.table::uniqueN( - data@data, - by = get_id_columns(id_depth = "series")) <= 5) { - return(NULL) - } + if (get_n_samples(data, "series") <= 5L) return(NULL) # Identify eligible columns. feature_columns <- get_feature_columns(x = data) @@ -333,7 +508,8 @@ setMethod( data_type = "feature", cl = cl, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(data_element) } @@ -380,7 +556,8 @@ setMethod( data.table::setnames( x = cluster_table, old = "name", - new = "feature") + new = "feature" + ) # Set cluster info as data. x@data <- cluster_table @@ -416,7 +593,8 @@ setMethod( by.x = "feature_name_1", by.y = "name", all.x = TRUE, - all.y = FALSE) + all.y = FALSE + ) mutual_correlation_table <- merge( x = mutual_correlation_table, @@ -424,13 +602,15 @@ setMethod( by.x = "feature_name_2", by.y = "name", all.x = TRUE, - all.y = FALSE) + all.y = FALSE + ) # Rename columns data.table::setnames( x = mutual_correlation_table, old = c("label_order.x", "label_order.y"), - new = c("label_order_1", "label_order_2")) + new = c("label_order_1", "label_order_2") + ) # Add to data element. x@data <- mutual_correlation_table @@ -455,7 +635,8 @@ setMethod( # Compute the cluster table. cluster_table <- create_clusters( object = cluster_method_object, - as_cluster_object = FALSE) + as_cluster_object = FALSE + ) return(cluster_table) } @@ -466,7 +647,7 @@ setMethod( if (is_empty(x)) return(NULL) - if (length(x@similarity_threshold) > 1) { + if (length(x@similarity_threshold) > 1L) { # Remove 1.0 because that does not yield clustering info. available_thresholds <- setdiff(x@similarity_threshold, 1.0) @@ -482,14 +663,16 @@ setMethod( cluster_cut_method = x@cluster_cut_method, cluster_similarity_threshold = x@similarity_threshold, cluster_similarity_metric = x@similarity_metric, - cluster_representation_method = "none") + cluster_representation_method = "none" + ) # Attach the similarity table to the cluster_method_object. cluster_method_object@similarity_table <- methods::new( "similarityTable", data = x@data[, mget(c("feature_name_1", "feature_name_2", "value"))], similarity_metric = x@similarity_metric, - data_type = cluster_method_object@data_type) + data_type = cluster_method_object@data_type + ) return(cluster_method_object) } @@ -509,20 +692,18 @@ setMethod( #'@param export_clustering Add clustering information to data. #' #'@inheritParams export_all -#'@inheritParams extract_data +#'@inheritParams .extract_data #'@inheritParams plot_univariate_importance #' #'@inheritDotParams as_familiar_collection +#'@inheritDotParams as_data_object #' -#'@details Data is usually collected from a `familiarCollection` object. -#' However, you can also provide one or more `familiarData` objects, that will -#' be internally converted to a `familiarCollection` object. It is also -#' possible to provide a `familiarEnsemble` or one or more `familiarModel` -#' objects together with the data from which data is computed prior to export. -#' Paths to the previous files can also be provided. -#' +#'@details #' All parameters aside from `object` and `dir_path` are only used if `object` #' is not a `familiarCollection` object, or a path to one. +#' +#' Feature similarity data can be created from `dataObject`, or `data.table` objects. +#' For `data.table`, see \code{\link{as_data_object}} for additional arguments. #' #'@return A list containing a data.table (if `dir_path` is not provided), or #' nothing, as all data is exported to `csv` files. @@ -543,7 +724,8 @@ setGeneric( export_ordered_data = FALSE, export_clustering = FALSE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_feature_similarity") } ) @@ -566,7 +748,8 @@ setMethod( export_ordered_data = FALSE, export_clustering = FALSE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -575,7 +758,7 @@ setMethod( x <- object@feature_similarity if (export_ordered_data && export_clustering) { - stop("Cannot simultaneously export cluster information and ordering of features.") + ..error("Cannot simultaneously export cluster information and ordering of features.") } # Check that the data are not empty. @@ -590,7 +773,8 @@ setMethod( x@cluster_method <- feature_cluster_method return(x) }, - feature_cluster_method = feature_cluster_method) + feature_cluster_method = feature_cluster_method + ) } if (!is.waive(feature_linkage_method)) { @@ -602,7 +786,8 @@ setMethod( x@linkage_method <- feature_linkage_method return(x) }, - feature_linkage_method = feature_linkage_method) + feature_linkage_method = feature_linkage_method + ) } if (!is.waive(feature_cluster_cut_method)) { @@ -614,7 +799,8 @@ setMethod( x@cluster_cut_method <- feature_cluster_cut_method return(x) }, - feature_cluster_cut_method = feature_cluster_cut_method) + feature_cluster_cut_method = feature_cluster_cut_method + ) } if (!is.waive(feature_similarity_threshold)) { @@ -626,23 +812,27 @@ setMethod( x@similarity_threshold <- feature_similarity_threshold return(x) }, - feature_similarity_threshold = feature_similarity_threshold) + feature_similarity_threshold = feature_similarity_threshold + ) } # Check whether the input parameters are valid and create a cluster object. .check_cluster_parameters( - cluster_method = x[[1]]@cluster_method, + cluster_method = x[[1L]]@cluster_method, data_type = "feature", - cluster_linkage = x[[1]]@linkage_method, - cluster_cut_method = x[[1]]@cluster_cut_method, - cluster_similarity_threshold = x[[1]]@similarity_threshold, - cluster_similarity_metric = x[[1]]@similarity_metric, - cluster_representation_method = "none") - - if (aggregate_results || - export_dendrogram || - export_ordered_data || - export_clustering) { + cluster_linkage = x[[1L]]@linkage_method, + cluster_cut_method = x[[1L]]@cluster_cut_method, + cluster_similarity_threshold = x[[1L]]@similarity_threshold, + cluster_similarity_metric = x[[1L]]@similarity_metric, + cluster_representation_method = "none" + ) + + if ( + aggregate_results || + export_dendrogram || + export_ordered_data || + export_clustering + ) { x <- .compute_data_element_estimates(x) if (export_dendrogram || export_ordered_data || export_clustering) { @@ -666,10 +856,11 @@ setMethod( dir_path = dir_path, aggregate_results = aggregate_results, type = "feature_similarity", - subtype = x[[1]]@similarity_metric, + subtype = x[[1L]]@similarity_metric, export_dendrogram = export_dendrogram, export_ordered_data = export_ordered_data, - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -690,7 +881,8 @@ setMethod( feature_cluster_cut_method = waiver(), feature_similarity_threshold = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -703,8 +895,11 @@ setMethod( "feature_cluster_method" = feature_cluster_method, "feature_linkage_method" = feature_linkage_method, "feature_cluster_cut_method" = feature_cluster_cut_method, - "feature_similarity_threshold" = feature_similarity_threshold), - list(...))) + "feature_similarity_threshold" = feature_similarity_threshold + ), + list(...) + ) + ) return(do.call( export_feature_similarity, @@ -717,8 +912,11 @@ setMethod( "feature_linkage_method" = feature_linkage_method, "feature_cluster_cut_method" = feature_cluster_cut_method, "feature_similarity_threshold" = feature_similarity_threshold, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -734,7 +932,8 @@ setMethod( aggregate_results = FALSE, export_dendrogram, export_ordered_data, - ...) { + ... + ) { # This is like .export,familiarDataElement, but the elements are merged # prior to computing estimates. @@ -745,7 +944,8 @@ setMethod( x = x_list, as_data = "all", as_grouping_column = TRUE, - force_data_table = TRUE) + force_data_table = TRUE + ) } else { x <- x_list diff --git a/R/FamiliarDataComputationHyperparameters.R b/R/FamiliarDataComputationHyperparameters.R index 95acada5..03be15bd 100644 --- a/R/FamiliarDataComputationHyperparameters.R +++ b/R/FamiliarDataComputationHyperparameters.R @@ -10,7 +10,9 @@ setClass( contains = "familiarDataElement", prototype = methods::prototype( detail_level = "hybrid", - estimation_type = "point")) + estimation_type = "point" + ) +) @@ -20,7 +22,7 @@ setClass( #' #'@description Collects hyperparameters from models in a `familiarEnsemble`. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list of familiarDataElements with hyperparameters. #'@md @@ -31,7 +33,8 @@ setGeneric( object, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_hyperparameters") } ) @@ -45,14 +48,16 @@ setMethod( function( object, message_indent = 0L, - verbose = FALSE) { + verbose = FALSE + ) { # Extracts hyper-parameters from each model and collects them. # Message extraction start logger_message( paste0("Extracting hyperparameters from the models in the ensemble."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Test if models are properly loaded if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() @@ -71,7 +76,8 @@ setMethod( proto_data_element = proto_data_element, aggregate_results = FALSE, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(hyperparameter_data) } @@ -79,10 +85,24 @@ setMethod( +# extract_hyperparameters (prediction table) ----------------------------------- +setMethod( + "extract_hyperparameters", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("model hyperparameters") + + return(NULL) + } +) + + + .extract_hyperparameters <- function( object, proto_data_element, - ...) { + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -119,16 +139,18 @@ setMethod( export_vec <- sapply( seq_len(nrow(data)), function(ii, data) (paste0(data$instance[ii], " (", data$n[ii], ")")), - data = data) + data = data + ) export_vec <- paste(export_vec, collapse = "; ") } else if (is.numeric(x)) { export_vec <- paste0( - stats::quantile(x = x, probs = 0.5, na.rm = TRUE, type = 1, names = FALSE), + stats::quantile(x = x, probs = 0.5, na.rm = TRUE, type = 1L, names = FALSE), " [", min(x, na.rm = TRUE), ", ", - max(x, na.rm = TRUE), "]") + max(x, na.rm = TRUE), "]" + ) } return(export_vec) @@ -143,11 +165,13 @@ setMethod( function( x, identifier, - as_grouping_column = TRUE) { + as_grouping_column = TRUE + ) { - if (length(identifier) == 0) { + if (length(identifier) == 0L) { ..error_reached_unreachable_code( - ".identifier_as_data_attribute: Cannot pass an empty identifier.") + ".identifier_as_data_attribute: Cannot pass an empty identifier." + ) } # Different learners have different hyperparameters. We therefore @@ -159,12 +183,13 @@ setMethod( # Remove learner, if present. identifier <- setdiff(identifier, "learner") - if (length(identifier) == 0) return(x) + if (length(identifier) == 0L) return(x) return(callNextMethod( x = x, identifier = identifier, - as_grouping_column = as_grouping_column)) + as_grouping_column = as_grouping_column + )) } else { return(callNextMethod()) @@ -180,7 +205,8 @@ setMethod( function( x, x_list = NULL, - ...) { + ... + ) { # It might be that x was only used to direct to this method. if (!is.null(x_list)) x <- x_list @@ -194,38 +220,43 @@ setMethod( data <- data.table::rbindlist( lapply(x, function(x) (x@data)), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) - # Split by fs_method - data <- split(data, by = "fs_method") + # Split by vimp_method + data <- split(data, by = "vimp_method") - learner <- x[[1]]@identifiers$learner - if (is.null(learner)) learner <- x[[1]]@data$learner[1] + learner <- x[[1L]]@identifiers$learner + if (is.null(learner)) learner <- x[[1L]]@data$learner[1L] # Set learner. parameter_string <- paste0("learner\t", learner) for (current_data in data) { # Determine the vimp_method - vimp_method <- current_data$fs_method[1] + vimp_method <- current_data$vimp_method[1L] # Set vimp method. parameter_string <- c( parameter_string, - paste0("fs_method\t", vimp_method), - "---------------------") + paste0("vimp_method\t", vimp_method), + "---------------------" + ) # Parse data. parameter_string <- c( parameter_string, sapply( - x[[1]]@value_column, + x[[1L]]@value_column, function(hyperparameter, data) { return(paste0( hyperparameter, "\t", - ..hyperparameter_to_string(data[[hyperparameter]]))) + ..hyperparameter_to_string(data[[hyperparameter]]) + )) }, - data = current_data)) + data = current_data + ) + ) parameter_string <- c(parameter_string, " ") @@ -235,7 +266,7 @@ setMethod( parameter_string <- paste0(parameter_string, collapse = "\n") # Copy data element. - y <- x[[1]] + y <- x[[1L]] y@data <- parameter_string # Update value column @@ -255,7 +286,8 @@ setMethod( x, x_list, aggregate_results = FALSE, - ...) { + ... + ) { # This is like .export,familiarDataElement, but the elements are # merged prior to computing estimates. @@ -264,7 +296,8 @@ setMethod( x = x_list, as_data = "all", as_grouping_column = TRUE, - force_data_table = TRUE) + force_data_table = TRUE + ) if (aggregate_results) { x <- .compute_data_element_estimates(x) @@ -316,7 +349,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_hyperparameters") } ) @@ -334,7 +368,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -353,7 +388,8 @@ setMethod( aggregate_results = aggregate_results, type = "hyperparameter", subtype = subtype, - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -370,7 +406,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -378,8 +415,11 @@ setMethod( args = c( list( "object" = object, - "data_element" = "hyperparameters"), - list(...))) + "data_element" = "hyperparameters" + ), + list(...) + ) + ) return(do.call( export_hyperparameters, @@ -388,7 +428,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationICE.R b/R/FamiliarDataComputationICE.R index c76161d0..2d0e91a7 100644 --- a/R/FamiliarDataComputationICE.R +++ b/R/FamiliarDataComputationICE.R @@ -5,14 +5,16 @@ NULL # familiarDataElementIndividualConditionalExpectation object ------------------- setClass( "familiarDataElementIndividualConditionalExpectation", - contains = "familiarDataElement") + contains = "familiarDataElement" +) # familiarDataElementPartialDependence object ---------------------------------- setClass( "familiarDataElementPartialDependence", - contains = "familiarDataElement") + contains = "familiarDataElement" +) @@ -36,7 +38,7 @@ setClass( #'@param feature_y_range As `feature_x_range`, but for the second feature in #' case two features are defined. #'@param n_sample_points Number of points used to sample continuous features. -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A data.table containing individual conditional expectation plot data. #'@md @@ -50,10 +52,11 @@ setGeneric( features = NULL, feature_x_range = NULL, feature_y_range = NULL, - n_sample_points = 50L, + n_sample_points = 20L, ensemble_method = waiver(), evaluation_times = waiver(), sample_limit = waiver(), + n_important_features = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), @@ -62,7 +65,8 @@ setGeneric( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_ice") } ) @@ -80,10 +84,11 @@ setMethod( features = NULL, feature_x_range = NULL, feature_y_range = NULL, - n_sample_points = 50L, + n_sample_points = 20L, ensemble_method = waiver(), evaluation_times = waiver(), sample_limit = waiver(), + n_important_features = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), @@ -92,30 +97,33 @@ setMethod( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # Message extraction start if (is.null(features)) { logger_message( paste0( "Computing individual conditional expectation and partial dependence ", - "data for features in the dataset."), + "data for features in the dataset." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else { logger_message( paste0( "Computing individual conditional expectation and partial dependence ", - "data for the selected features."), + "data for the selected features: ", paste_s(features), "." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } # Load evaluation_times from the object settings attribute, if it is not provided. - if (is.waive(evaluation_times)) { - evaluation_times <- object@settings$eval_times - } + if (is.waive(evaluation_times)) evaluation_times <- object@settings$eval_times # Check evaluation_times argument if (object@outcome_type %in% c("survival")) { @@ -124,62 +132,63 @@ setMethod( .check_number_in_valid_range, var_name = "evaluation_times", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) } # Check n_sample_points argument .check_number_in_valid_range( x = n_sample_points, var_name = "n_sample_points", - range = c(1, Inf)) + range = c(1L, Inf) + ) # Obtain ensemble method from stored settings, if required. - if (is.waive(ensemble_method)) { - ensemble_method <- object@settings$ensemble_method - } + if (is.waive(ensemble_method)) ensemble_method <- object@settings$ensemble_method # Check ensemble_method argument .check_parameter_value_is_valid( x = ensemble_method, var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) + values = .get_available_ensemble_prediction_methods() + ) # Load confidence alpha from object settings attribute if not provided # externally. - if (is.waive(confidence_level)) { - confidence_level <- object@settings$confidence_level - } + if (is.waive(confidence_level)) confidence_level <- object@settings$confidence_level # Check confidence_level input argument .check_number_in_valid_range( x = confidence_level, var_name = "confidence_level", range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) + closed = c(FALSE, FALSE) + ) # Load the bootstrap method - if (is.waive(bootstrap_ci_method)) { - bootstrap_ci_method <- object@settings$bootstrap_ci_method - } + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- object@settings$bootstrap_ci_method .check_parameter_value_is_valid( x = bootstrap_ci_method, var_name = "bootstrap_ci_method", - values = .get_available_bootstrap_confidence_interval_methods()) + values = .get_available_bootstrap_confidence_interval_methods() + ) # Check the sample limit. sample_limit <- .parse_sample_limit( x = sample_limit, object = object, default = Inf, - data_element = "ice_data") + data_element = "ice_data" + ) # Check the level detail. detail_level <- .parse_detail_level( x = detail_level, object = object, default = "hybrid", - data_element = "ice_data") + data_element = "ice_data" + ) # Check the estimation type. estimation_type <- .parse_estimation_type( @@ -188,14 +197,16 @@ setMethod( default = "bootstrap_confidence_interval", data_element = "ice_data", detail_level = detail_level, - has_internal_bootstrap = FALSE) + has_internal_bootstrap = FALSE + ) # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = TRUE, - data_element = "ice_data") + data_element = "ice_data" + ) # Test if models are properly loaded if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() @@ -203,13 +214,33 @@ setMethod( # Test if any model in the ensemble was successfully trained. if (!model_is_trained(object = object)) return(NULL) + important_features <- NULL + if (is.null(features)) { + # Check the number of important features. + n_important_features <- .parse_n_important_features( + x = n_important_features, + object = object, + default = 20, + data_element = "ice_data" + ) + + # Set features to be assessed using ICE, which are the most important + # features. + important_features <- .select_important_features( + object = object, + data = data, + n_important_features = n_important_features + ) + } + # Generate a prototype data element. proto_data_element <- new( "familiarDataElementIndividualConditionalExpectation", detail_level = detail_level, estimation_type = estimation_type, confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method) + bootstrap_ci_method = bootstrap_ci_method + ) # Generate elements to send to dispatch. ice_data <- extract_dispatcher( @@ -222,6 +253,7 @@ setMethod( feature_x_range = feature_x_range, feature_y_range = feature_y_range, sample_limit = sample_limit, + important_features = important_features, n_sample_points = n_sample_points, proto_data_element = proto_data_element, is_pre_processed = is_pre_processed, @@ -229,7 +261,8 @@ setMethod( evaluation_times = evaluation_times, aggregate_results = TRUE, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(ice_data) } @@ -237,6 +270,19 @@ setMethod( +# extract_ice (prediction table) ----------------------------------------------- +setMethod( + "extract_ice", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("individual conditional expectation") + + return(NULL) + } +) + + + .extract_ice <- function( object, data, @@ -244,6 +290,7 @@ setMethod( evaluation_times = NULL, features = NULL, sample_limit, + important_features = NULL, aggregate_results, n_models, is_pre_processed = FALSE, @@ -251,7 +298,8 @@ setMethod( message_indent = 0L, verbose = FALSE, progress_bar = FALSE, - ...) { + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -264,13 +312,15 @@ setMethod( object = object, data = data, stop_at = "signature", - is_pre_processed = is_pre_processed) + is_pre_processed = is_pre_processed + ) # Maintain only important features. The current set is based on the # required features. data <- filter_features( data = data, - available_features = object@model_features) + available_features = object@model_features + ) # Check if the input data is not empty if (is_empty(data)) return(NULL) @@ -279,16 +329,18 @@ setMethod( data <- get_subsample( data = data, size = sample_limit, - seed = 0L) + seed = 0L + ) # Aggregate data. data <- aggregate_data(data) # Add evaluation time as a identifier to the data element. - if (length(evaluation_times) > 0 && object@outcome_type == "survival") { + if (length(evaluation_times) > 0L && object@outcome_type == "survival") { data_elements <- add_data_element_identifier( x = proto_data_element, - evaluation_time = evaluation_times) + evaluation_time = evaluation_times + ) } else { data_elements <- list(proto_data_element) @@ -298,47 +350,54 @@ setMethod( # Check that the features exist in the data set. if (!all(features %in% c(object@model_features))) { - warning(paste0( + ..warning(paste0( "Data for individual conditional expectation or partial dependence plots ", "could not be computed for ", paste_s(setdiff(features, object@model_features)), - " feature(s) as they are not used by the model.")) + " feature(s) as they are not used by the model." + )) } # Add features as identifier. - if (length(features) == 1) { + if (length(features) == 1L) { data_elements <- add_data_element_identifier( x = data_elements, - feature_x = features) + feature_x = features + ) - } else if (length(features) == 2) { + } else if (length(features) == 2L) { - if (length(unique(features)) != 2) { - stop(paste0( + if (length(unique(features)) != 2L) { + ..error(paste0( "Data for individual conditional expectation or partial dependence plots ", "could not be computed as the provided features are not unique: ", - paste_s(features), ".")) + paste_s(features), "." + )) } data_elements <- add_data_element_identifier( x = data_elements, - feature_x = features[1]) + feature_x = features[1L] + ) data_elements <- add_data_element_identifier( x = data_elements, - feature_y = features[2]) + feature_y = features[2L] + ) } else { - stop(paste0( + ..error(paste0( "Data for individual conditional expectation or partial dependence plots cannot ", "be computed for more than 2 features simultaneously. Found: ", - paste_s(features), ".")) + paste_s(features), "." + )) } } else { - # Add features as identifier. + # Add important features as identifier. data_elements <- add_data_element_identifier( x = data_elements, - feature_x = object@model_features) + feature_x = important_features + ) } # Iterate over elements. @@ -351,11 +410,14 @@ setMethod( list( "data" = data, "object" = object, - "verbose" = verbose && !progress_bar && n_models == 1, - "message_indent" = message_indent), - list(...)), - progress_bar = progress_bar, - chopchop = TRUE) + "verbose" = verbose && !progress_bar && n_models == 1L, + "message_indent" = message_indent + ), + list(...) + ), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) # Flatten list of data elements. data_elements <- unlist(data_elements) @@ -383,50 +445,64 @@ setMethod( ensemble_method, verbose = FALSE, message_indent, - ...) { + ... +) { # Divide feature(s) into points. + # Check that feature is present for the model. + if (!data_element@identifiers$feature_x %in% names(object@feature_info)) return(NULL) + # Generate range feature_x_range <- .create_feature_range( feature_info = object@feature_info, feature = data_element@identifiers$feature_x, column_type = class(data@data[[data_element@identifiers$feature_x]]), feature_range = feature_x_range, - n = n_sample_points) + n = n_sample_points + ) # Add feature values. data_elements <- add_data_element_identifier( x = data_element, - feature_x_value = feature_x_range) + feature_x_value = feature_x_range + ) # Mention feature. message_str <- paste0( - "Computing ICE / PD curves for \"", data_element@identifiers$feature_x, "\"") + "Computing ICE / PD curves for \"", data_element@identifiers$feature_x, "\"" + ) if (!is.null(data_element@identifiers$feature_y)) { + # Check that feature is present for the model. + if (!data_element@identifiers$feature_y %in% names(object@feature_info)) return(NULL) + feature_y_range <- .create_feature_range( feature_info = object@feature_info, feature = data_element@identifiers$feature_y, column_type = class(data@data[[data_element@identifiers$feature_y]]), feature_range = feature_y_range, - n = n_sample_points) + n = n_sample_points + ) # Add feature values. data_elements <- add_data_element_identifier( x = data_elements, - feature_y_value = feature_y_range) + feature_y_value = feature_y_range + ) # Mention feature. message_str <- c( message_str, - paste0(" and \"", data_element@identifiers$feature_y, "\"")) + paste0(" and \"", data_element@identifiers$feature_y, "\"") + ) } # Add evaluation time. - if (length(data_element@identifiers$evaluation_time) > 0) { + if (length(data_element@identifiers$evaluation_time) > 0L) { message_str <- c( message_str, - paste0(" at time ", data_element@identifiers$evaluation_time, ".")) + paste0(" at time ", data_element@identifiers$evaluation_time, ".") + ) } else { message_str <- c(message_str, ".") @@ -435,7 +511,8 @@ setMethod( logger_message( paste0(message_str, collapse = ""), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Iterate over elements. data_elements <- lapply( @@ -443,7 +520,8 @@ setMethod( ...extract_ice_data, data = data, object = object, - ensemble_method = ensemble_method) + ensemble_method = ensemble_method + ) return(data_elements) } @@ -454,7 +532,8 @@ setMethod( data_element, data, object, - ensemble_method) { + ensemble_method +) { # Make a local copy of the data. data@data <- data.table::copy(data@data) @@ -466,14 +545,13 @@ setMethod( if (!is.null(data_element@identifiers$feature_y)) { data@data[, (data_element@identifiers$feature_y) := data_element@identifiers$feature_y_value] } - - # Predict both novelty - if (object@outcome_type %in% c("survival", "competing_risk")) { - type <- c("survival_probability", "novelty") - - } else { - type <- c("default", "novelty") - } + + # Predict both primary outcomes and novelty + type <- ifelse( + object@outcome_type %in% c("survival", "competing_risk"), + "survival_probability", + "default" + ) # Compute performance data. prediction_data <- .predict( @@ -482,87 +560,63 @@ setMethod( ensemble_method = ensemble_method, time = data_element@identifiers$evaluation_time, type = type, - aggregate_results = TRUE) + aggregate_results = TRUE + ) + + # Compute novelty values. + novelty_data <- .predict( + object = object, + data = data, + ensemble_method = ensemble_method, + time = data_element@identifiers$evaluation_time, + type = "novelty", + aggregate_results = TRUE + ) # Check that valid prediction data were generated. - if (!any_predictions_valid( - prediction_data, - outcome_type = object@outcome_type)) { - return(NULL) - } - - # Select prediction columns - if (object@outcome_type %in% c("survival", "competing_risk")) { - prediction_columns <- c("survival_probability", "novelty") - - } else if (object@outcome_type %in% c("binomial", "multinomial")) { - prediction_columns <- c( - get_class_probability_name(object), "novelty") - - } else if (object@outcome_type %in% c("count", "continuous")) { - prediction_columns <- c("predicted_outcome", "novelty") - - } else { - ..error_no_known_outcome_type(object@outcome_type) - } - - # Select only the prediction columns. - ice_data <- prediction_data[, mget(prediction_columns)] - - # Create unique row names for samples and insert. - ice_data[, "sample" := get_unique_row_names(x = data)] - - # Remove data with missing predictions. - ice_data <- remove_nonvalid_predictions( - ice_data, - outcome_type = object@outcome_type) + if (!any_predictions_valid(prediction_data)) return(NULL) + prediction_data <- .drop_reference_data(prediction_data) + prediction_data <- .merge_slots_into_data(prediction_data) + prediction_data <- remove_invalid_predictions(prediction_data) # Check if removing invalid predictions leaves any data. - if (is_empty(ice_data)) return(NULL) + if (is_empty(prediction_data)) return(NULL) + + novelty_data <- .drop_reference_data(novelty_data) + novelty_data <- .merge_slots_into_data(novelty_data) + novelty_data <- remove_invalid_predictions(novelty_data) if (object@outcome_type %in% c("binomial", "multinomial")) { # Determine class levels. class_levels <- get_outcome_class_levels(object) - if (object@outcome_type == "binomial") class_levels <- class_levels[2] - # Find probability names. - probability_names <- get_class_probability_name(class_levels) - - # Convert table from wide to long format. - ice_data <- data.table::melt( - data = ice_data, - measure.vars = probability_names, - variable.name = "positive_class", - value.name = "probability") - - # Replace labels by class names. - ice_data$positive_class <- factor( - x = ice_data$positive_class, - levels = probability_names, - labels = class_levels) + if (object@outcome_type == "binomial") { + used_class_levels <- class_levels[2L] + prediction_data@value_column <- c( + setdiff(prediction_data@value_column, class_levels), + used_class_levels + ) + + } else { + used_class_levels <- class_levels + } - # Add positive class as identifier. - data_elements <- add_data_element_identifier( - x = data_element, - positive_class = class_levels) - - # Create ice and pd plot data. - data_elements <- lapply( - data_elements, - .create_ice_and_pd_objects, - data = ice_data, - outcome_type = object@outcome_type, - value_columns = c("probability", "novelty")) - - } else { - # Create ice and pd plot data. - data_elements <- .create_ice_and_pd_objects( - data_element, - data = ice_data, - outcome_type = object@outcome_type, - value_columns = prediction_columns) - } + # Make sure that probability is returned. + prediction_data <- .convert_value_to_grouping_column( + prediction_data, + new_grouping_column = used_class_levels, + new_grouping_column_name = "positive_class", + new_value_column_name = "probability" + ) + } + + # Create ice and pd plot data. + data_elements <- .create_ice_and_pd_objects( + data_element, + prediction_data = prediction_data, + novelty_data = novelty_data + ) return(data_elements) } @@ -574,14 +628,17 @@ setMethod( feature, feature_range, n, - column_type) { + column_type +) { # Find the feature information associated with the feature. feature_info <- feature_info[[feature]] # Check that the feature info is present. if (is.null(feature_info)) { - stop(paste0("Feature information could not be found for the ", feature, " feature.")) + ..error( + paste0("Feature information could not be found for the ", feature, " feature.") + ) } # Determine if the feature is categorical or numerical. @@ -594,12 +651,13 @@ setMethod( feature_range <- factor(feature_levels, levels = feature_levels) } else if (!all(feature_range %in% feature_levels)) { - stop(paste0( + ..error(paste0( "One or more levels defined in the feature range for creating ", "individual conditional expectation and partial dependence plots do not ", "match levels found in training data: ", paste_s(setdiff(feature_range, feature_levels)), - ". Check for misspelled levels.")) + ". Check for misspelled levels." + )) } # If not null, and no mismatches occur, use feature_range directly. @@ -608,16 +666,18 @@ setMethod( if (!is.null(feature_range)) { # Check that values are numeric. if (!is.numeric(feature_range)) { - stop(paste0( + ..error(paste0( "Numeric values are required to define the feature range for creating ", - "individual conditional expectation and partial dependence plots.")) + "individual conditional expectation and partial dependence plots." + )) } # Check that all values are finite. - if (any(!is.finite(feature_range))) { - stop(paste0( + if (!all(is.finite(feature_range))) { + ..error(paste0( "Numeric values for creating individual conditional expectation and partial dependence ", - " plots should be finite. NA and infinite values are not allowed.")) + " plots should be finite. NA and infinite values are not allowed." + )) } # Sort values. @@ -625,33 +685,28 @@ setMethod( # If two values are defined, interpret as range, and sample from it. # If not, use feature_range directly. - if (length(feature_range) == 2) { + if (length(feature_range) == 2L) { feature_range <- stats::approx( x = c(0.00, 1.00), y = feature_range, n = n, - method = "linear")$y + method = "linear" + )$y } } else { # Create the range of values from the feature distribution. - if (n == 1) { - feature_range <- as.numeric(feature_info@distribution$fivenum)[3] - - } else { - # Sample the five-number summary. - feature_range <- stats::spline( - x = c(0.00, 0.25, 0.50, 0.75, 1.00), - y = as.numeric(feature_info@distribution$fivenum), - n = n, - method = "hyman")$y - } + feature_range <- stats::spline( + x = (seq_along(feature_info@distribution$pctl) - 1L) / + (length(feature_info@distribution$pctl) - 1L), + y = as.numeric(feature_info@distribution$pctl), + xout = get_percentiles(n), + method = "hyman" + )$y } # Convert to integer if required. - if (any(column_type == "integer")) { - feature_range <- as.integer(feature_range) - } + if (any(column_type == "integer")) feature_range <- as.integer(feature_range) # Select unique values. feature_range <- unique(feature_range) @@ -659,7 +714,8 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( ".create_feature_range: encountered unknown feature type (", - feature_info@feature_type, ") for the ", feature, " feature.")) + feature_info@feature_type, ") for the ", feature, " feature." + )) } return(feature_range) @@ -669,31 +725,29 @@ setMethod( .create_ice_and_pd_objects <- function( data_element, - data, - outcome_type, - value_columns) { - - # Suppress NOTES due to non-standard evaluation in data.table - positive_class <- NULL - - # Make a local copy. - data <- data.table::copy(data) - - if (outcome_type %in% c("binomial", "multinomial")) { - # Select only data corresponding to the positive class. - data <- data[positive_class == data_element@identifiers$positive_class] - - # Drop the positive class column. - data[, "positive_class" := NULL] - } - + prediction_data, + novelty_data +) { # Create ice and pd data elements. ice_data_element <- data_element - - # Update ice data element. - ice_data_element@grouping_column <- "sample" - ice_data_element@data <- data - ice_data_element@value_column <- value_columns + + if (is_empty(novelty_data)) { + ice_data_element@data <- data.table::copy(.as_data_table(prediction_data)) + ice_data_element@grouping_column <- prediction_data@grouping_column + ice_data_element@value_column <- prediction_data@value_column + + } else { + data <- merge( + x = data.table::copy(.as_data_table(prediction_data)), + y = data.table::copy(.as_data_table(novelty_data)), + by = intersect(prediction_data@grouping_column, novelty_data@grouping_column), + all = TRUE + ) + + ice_data_element@data <- data + ice_data_element@grouping_column <- union(prediction_data@grouping_column, novelty_data@grouping_column) + ice_data_element@value_column <- union(prediction_data@value_column, novelty_data@value_column) + } # Update pd data element. pd_data_element <- .create_pd_object(ice_data_element) @@ -708,26 +762,32 @@ setMethod( # Create partial dependence data. pd_data_element <- methods::new( "familiarDataElementPartialDependence", - ice_data_element) + ice_data_element + ) # Select grouping columns. - grouping_columns <- setdiff(ice_data_element@grouping_column, "sample") - - if (length(grouping_columns) == 0) grouping_columns <- NULL + grouping_columns <- setdiff( + ice_data_element@grouping_column, get_id_columns() + ) + if (length(grouping_columns) == 0L) grouping_columns <- NULL pd_data_element@grouping_column <- grouping_columns # Average data. - if (length(grouping_columns) > 0) { + if (length(grouping_columns) > 0L) { pd_data_element@data <- pd_data_element@data[ - , lapply(.SD, mean, na.rm = TRUE), + , + lapply(.SD, mean, na.rm = TRUE), .SDcols = ice_data_element@value_column, - by = c(grouping_columns)] + by = c(grouping_columns) + ] } else { pd_data_element@data <- pd_data_element@data[ - , lapply(.SD, mean, na.rm = TRUE), - .SDcols = ice_data_element@value_column] + , + lapply(.SD, mean, na.rm = TRUE), + .SDcols = ice_data_element@value_column + ] } return(pd_data_element) @@ -739,27 +799,35 @@ setMethod( ice_data, pd_data, outcome_type, + class_levels = NULL, anchor_values = NULL, n_samples = NULL, - seed) { + seed +) { + + # Prevent NOTES + positive_class <- NULL if (is_empty(ice_data)) { return(list( "ice_data" = ice_data, - "pd_data" = pd_data)) + "pd_data" = pd_data + )) } # Find anchor value for the x-feature. It will be NULL if the current feature # does does not appear in anchor_values. x_anchor <- tryCatch( anchor_values[[ice_data@identifiers$feature_x]], - error = function(err) (return(NULL))) + error = function(err) (return(NULL)) + ) if (!is.null(x_anchor)) { - if (length(x_anchor) > 1) { - stop(paste0( + if (length(x_anchor) > 1L) { + ..error(paste0( "Only a single value can be provided as an anchor value for the ", - ice_data@identifiers$feature_x, " feature.")) + ice_data@identifiers$feature_x, " feature." + )) } } @@ -768,13 +836,15 @@ setMethod( # with the data. y_anchor <- tryCatch( anchor_values[[ice_data@identifiers$feature_y]], - error = function(err) (return(NULL))) + error = function(err) (return(NULL)) + ) if (!is.null(y_anchor)) { - if (length(y_anchor) > 1) { - stop(paste0( + if (length(y_anchor) > 1L) { + ..error(paste0( "Only a single value can be provided as an anchor value for the ", - ice_data@identifiers$feature_y, " feature.")) + ice_data@identifiers$feature_y, " feature." + )) } } @@ -782,12 +852,9 @@ setMethod( if (outcome_type %in% c("binomial", "multinomial")) { old_value_column <- "probability" - } else if (outcome_type %in% c("continuous", "count")) { + } else if (outcome_type %in% c("continuous", "survival")) { old_value_column <- "predicted_outcome" - } else if (outcome_type %in% c("survival")) { - old_value_column <- "survival_probability" - } else { ..error_outcome_type_not_implemented(outcome_type) } @@ -805,19 +872,23 @@ setMethod( data.table::setnames( x = ice_data@data, old = old_value_column, - new = new_value_column) + new = new_value_column + ) data.table::setnames( x = pd_data@data, old = old_value_column, - new = new_value_column) + new = new_value_column + ) # Update value column attributes. ice_data@value_column <- c( new_value_column, - setdiff(ice_data@value_column, old_value_column)) + setdiff(ice_data@value_column, old_value_column) + ) pd_data@value_column <- c( new_value_column, - setdiff(pd_data@value_column, old_value_column)) + setdiff(pd_data@value_column, old_value_column) + ) if (!is.null(x_anchor) || !is.null(y_anchor)) { @@ -828,7 +899,8 @@ setMethod( y_anchor = y_anchor, value_column = new_value_column, outcome_type = outcome_type, - anchor_values = anchor_values) + anchor_values = anchor_values + ) # Update partial dependence data. pd_data <- .create_pd_object(ice_data) @@ -841,17 +913,27 @@ setMethod( split(ice_data@data, by = "data_set", drop = TRUE), ..restrict_ice_samples, n_samples = n_samples, - seed = seed) + seed = seed + ) # Replace data attribute with the limited sample list. ice_data@data <- data.table::rbindlist( cropped_ice_data, - use.names = TRUE) + use.names = TRUE + ) + } + + # Retain only positive class for binomial outcomes. + if (outcome_type == "binomial") { + selected_class <- tail(class_levels, n = 1L) + ice_data@data <- ice_data@data[positive_class == selected_class] + pd_data@data <- pd_data@data[positive_class == selected_class] } return(list( "ice_data" = ice_data, - "pd_data" = pd_data)) + "pd_data" = pd_data + )) } @@ -862,7 +944,8 @@ setMethod( y_anchor = NULL, value_column, outcome_type, - anchor_values = NULL) { + anchor_values = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table feature_x_value <- feature_x_value <- feature_y_value <- value <- NULL @@ -871,37 +954,43 @@ setMethod( if (!is.null(x_anchor) && !is.null(y_anchor)) { # Set grouping columns. - grouping_columns <- setdiff( - x@grouping_column, - c("feature_x_value", "feature_y_value")) + grouping_columns <- setdiff(x@grouping_column, c("feature_x_value", "feature_y_value")) # Subtract anchor value for 2D plots with x and y anchors. - if (length(grouping_columns) > 0) { - x@data[, (value_column) := lapply( - .SD, - ..anchor_ice_values_2D, - x = feature_x_value, - x_anchor = x_anchor, - y = feature_y_value, - y_anchor = y_anchor, - value_offset = value, - x_name = x@identifiers$feature_x, - y_name = x@identifiers$feature_y), + if (length(grouping_columns) > 0L) { + x@data[ + , + (value_column) := lapply( + .SD, + ..anchor_ice_values_2D, + x = feature_x_value, + x_anchor = x_anchor, + y = feature_y_value, + y_anchor = y_anchor, + value_offset = value, + x_name = x@identifiers$feature_x, + y_name = x@identifiers$feature_y + ), by = c(grouping_columns), - .SDcols = value_column] + .SDcols = value_column + ] } else { - x@data[, (value_column) := lapply( - .SD, - ..anchor_ice_values_1D, - x = feature_x_value, - x_anchor = x_anchor, - y = feature_y_value, - y_anchor = y_anchor, - value_offset = value, - x_name = x@identifiers$feature_x, - y_name = x@identifiers$feature_y), - .SDcols = value_column] + x@data[ + , + (value_column) := lapply( + .SD, + ..anchor_ice_values_1D, + x = feature_x_value, + x_anchor = x_anchor, + y = feature_y_value, + y_anchor = y_anchor, + value_offset = value, + x_name = x@identifiers$feature_x, + y_name = x@identifiers$feature_y + ), + .SDcols = value_column + ] } } else if (!is.null(x_anchor)) { @@ -909,26 +998,34 @@ setMethod( grouping_columns <- setdiff(x@grouping_column, c("feature_x_value")) # Subtract anchor value for x anchor. - if (length(grouping_columns) > 0) { - x@data[, (value_column) := lapply( - .SD, - ..anchor_ice_values_1D, - x = feature_x_value, - x_anchor = x_anchor, - value_offset = value, - name = x@identifiers$feature_x), + if (length(grouping_columns) > 0L) { + x@data[ + , + (value_column) := lapply( + .SD, + ..anchor_ice_values_1D, + x = feature_x_value, + x_anchor = x_anchor, + value_offset = value, + name = x@identifiers$feature_x + ), by = c(grouping_columns), - .SDcols = value_column] + .SDcols = value_column + ] } else { - x@data[, (value_column) := lapply( - .SD, - ..anchor_ice_values_1D, - x = feature_x_value, - x_anchor = x_anchor, - value_offset = value, - name = x@identifiers$feature_x), - .SDcols = value_column] + x@data[ + , + (value_column) := lapply( + .SD, + ..anchor_ice_values_1D, + x = feature_x_value, + x_anchor = x_anchor, + value_offset = value, + name = x@identifiers$feature_x + ), + .SDcols = value_column + ] } } else if (!is.null(y_anchor)) { @@ -936,26 +1033,34 @@ setMethod( grouping_columns <- setdiff(x@grouping_column, c("feature_y_value")) # Subtract anchor value for y anchor. - if (length(grouping_columns) > 0) { - x@data[, (value_column) := lapply( - .SD, - ..anchor_ice_values_1D, - x = feature_y_value, - x_anchor = y_anchor, - value_offset = value, - name = x@identifiers$feature_y), + if (length(grouping_columns) > 0L) { + x@data[ + , + (value_column) := lapply( + .SD, + ..anchor_ice_values_1D, + x = feature_y_value, + x_anchor = y_anchor, + value_offset = value, + name = x@identifiers$feature_y + ), by = c(grouping_columns), - .SDcols = value_column] + .SDcols = value_column + ] } else { - x@data[, (value_column) := lapply( - .SD, - ..anchor_ice_values_1D, - x = feature_y_value, - x_anchor = y_anchor, - value_offset = value, - name = x@identifiers$feature_y), - .SDcols = value_column] + x@data[ + , + (value_column) := lapply( + .SD, + ..anchor_ice_values_1D, + x = feature_y_value, + x_anchor = y_anchor, + value_offset = value, + name = x@identifiers$feature_y + ), + .SDcols = value_column + ] } } else { @@ -971,24 +1076,26 @@ setMethod( ..restrict_ice_samples <- function(x, n_samples, seed = NULL) { # Suppress NOTES due to non-standard evaluation in data.table - sample <- NULL + sample <- .NATURAL <- NULL if (is.null(n_samples)) return(x) - # Select unique sample identifiers. - sample_identifiers <- unique(x$sample) - - # Do not sample if the number of available samples is smaller than n_samples. - if (length(sample_identifiers) < n_samples) return(x) + # Check if the number of samples allows for sampling. + n_samples_present <- get_n_samples(x, id_depth = "sample") + if (n_samples_present < n_samples) n_samples <- n_samples_present # Select samples. - selected_identifiers <- fam_sample( - x = sample_identifiers, - size = n_samples, - replace = FALSE, - seed = seed) + selected_samples <- fam_sample( + x = x, + size = n_samples, + replace = FALSE, + seed = seed + ) + + if (is_empty(selected_samples)) return(NULL) - x <- x[sample %in% selected_identifiers] + # Select only selected samples + x <- x[selected_samples, on = .NATURAL] return(x) } @@ -1000,13 +1107,15 @@ setMethod( x, x_anchor, value_offset, - name) { + name +) { # Check anchor value. x_anchor <- .check_anchor_value( x = x, x_anchor = x_anchor, - name = name) + name = name + ) if (is.numeric(x)) { # Set anchor value @@ -1018,7 +1127,8 @@ setMethod( anchor_value <- stats::spline( x = x, y = value_offset, - xout = x_anchor)$y + xout = x_anchor + )$y } } else { # Set anchor value by selecting the value corresponding to x_anchor. @@ -1039,7 +1149,8 @@ setMethod( y_anchor, value_offset, x_name, - y_name) { + y_name +) { # This is a bit more tricky since we need to do a surface interpolation which # R does not support out of the box. The akima package has a weird licence. @@ -1047,11 +1158,13 @@ setMethod( x_anchor <- .check_anchor_value( x = x, x_anchor = x_anchor, - name = x_name) + name = x_name + ) y_anchor <- .check_anchor_value( x = y, x_anchor = y_anchor, - name = y_name) + name = y_name + ) if (x_anchor %in% x && y_anchor %in% y) { # Simple - no interpolation needed. @@ -1062,19 +1175,22 @@ setMethod( anchor_value <- stats::spline( x = y[x == x_anchor], y = value_offset[x == x_anchor], - xout = y_anchor)$y + xout = y_anchor + )$y } else if (y_anchor %in% y) { # Interpolation in x. anchor_value <- stats::spline( x = x[y == y_anchor], y = value_offset[y == y_anchor], - xout = x_anchor)$y + xout = x_anchor + )$y } else { require_package( x = "ranger", - purpose = "to anchor ICE/PD plot curves") + purpose = "to anchor ICE/PD plot curves" + ) # Interpolation using random forest. model <- ranger::ranger( @@ -1082,17 +1198,21 @@ setMethod( data = data.table::data.table( "x" = x, "y" = y, - "value" = value_offset), - num.trees = 100, + "value" = value_offset + ), + num.trees = 100L, num.threads = 1L, - seed = 1L) + seed = 1L + ) anchor_value <- predict( model, data.table::data.table( "x" = x_anchor, - "y" = y_anchor), - num.threads = 1L)$predictions + "y" = y_anchor + ), + num.threads = 1L + )$predictions } # Subtract the anchor value. @@ -1106,7 +1226,7 @@ setMethod( if (is.numeric(x)) { if (!is.numeric(x_anchor)) { - stop(paste0("Anchor value of the ", name, " feature should be numeric.")) + ..error(paste0("Anchor value of the ", name, " feature should be numeric.")) } # Check for out-of-range anchor values. @@ -1116,27 +1236,30 @@ setMethod( if (x_anchor < min(x)) x_anchor <- min(x) if (x_anchor > max(x)) x_anchor <- max(x) - warning(paste0( + ..warning(paste0( "Anchor value (", x_anchor_old, ") of the ", name, " feature lies outside computed range. ", - "The nearest value (", x_anchor, ") is used instead.")) + "The nearest value (", x_anchor, ") is used instead." + )) } } else if (is.factor(x)) { # Check that the anchor value appears in the levels of x. if (!x_anchor %in% levels(x)) { - stop(paste0( + ..error(paste0( "Anchor value (", x_anchor, ") of the ", name, " feature was not found among the computed levels (", - paste_s(levels(x)), ").")) + paste_s(levels(x)), ")." + )) } } else { if (!x_anchor %in% x) { - stop(paste0( + ..error(paste0( "Anchor value (", x_anchor, ") of the ", name, - " feature was not found among the available values.")) + " feature was not found among the available values." + )) } } @@ -1179,7 +1302,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_ice_data") } ) @@ -1197,7 +1321,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -1211,7 +1336,8 @@ setMethod( type = "explanation", subtype = "ice", object_class = "familiarDataElementIndividualConditionalExpectation", - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -1228,7 +1354,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -1237,8 +1364,11 @@ setMethod( list( "object" = object, "data_element" = "ice_data", - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_ice_data, @@ -1247,8 +1377,11 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -1262,8 +1395,9 @@ setMethod( x, x_list, aggregate_results = FALSE, - ...) { - + ... + ) { + if (aggregate_results) { x_list <- .compute_data_element_estimates(x_list) } @@ -1271,16 +1405,15 @@ setMethod( # Determine identifiers that should be merged. Since the feature values of # the x and y features may be different (e.g. numeric and factor), merging # them would cause features values to merged incorrectly. - merging_identifiers <- setdiff( - names(x@identifiers), - c("feature_x", "feature_y")) + merging_identifiers <- setdiff(names(x@identifiers), c("feature_x", "feature_y")) # Merge data elements. x <- merge_data_elements( x = x_list, as_data = merging_identifiers, as_grouping_column = TRUE, - force_data_table = TRUE) + force_data_table = TRUE + ) return(x) } @@ -1322,7 +1455,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_partial_dependence_data") } ) @@ -1340,7 +1474,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -1354,7 +1489,8 @@ setMethod( type = "explanation", subtype = "pd", object_class = "familiarDataElementPartialDependence", - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -1371,7 +1507,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -1380,8 +1517,11 @@ setMethod( list( "object" = object, "data_element" = "ice_data", - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_partial_dependence_data, @@ -1390,8 +1530,11 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -1404,7 +1547,8 @@ setMethod( x, x_list, aggregate_results = FALSE, - ...) { + ... + ) { if (aggregate_results) { x_list <- .compute_data_element_estimates(x_list) @@ -1413,16 +1557,15 @@ setMethod( # Determine identifiers that should be merged. Since the feature values of # the x and y features may be different (e.g. numeric and factor), merging # them would cause features values to merged incorrectly. - merging_identifiers <- setdiff( - names(x@identifiers), - c("feature_x", "feature_y")) + merging_identifiers <- setdiff(names(x@identifiers), c("feature_x", "feature_y")) # Merge data elements. x <- merge_data_elements( x = x_list, as_data = merging_identifiers, as_grouping_column = TRUE, - force_data_table = TRUE) + force_data_table = TRUE + ) return(x) } diff --git a/R/FamiliarDataComputationModelPerformance.R b/R/FamiliarDataComputationModelPerformance.R index b65a3f0a..7e207ae8 100644 --- a/R/FamiliarDataComputationModelPerformance.R +++ b/R/FamiliarDataComputationModelPerformance.R @@ -7,7 +7,8 @@ NULL setClass( "familiarDataElementModelPerformance", contains = "familiarDataElement", - prototype = methods::prototype(value_column = "value")) + prototype = methods::prototype(value_column = "value") +) # extract_performance (generic) ------------------------------------------------ @@ -16,7 +17,7 @@ setClass( #'@description Computes and collects discriminative performance metrics from a #' `familiarEnsemble`. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@details This method computes credibility intervals for the ensemble model, at #' the level of `confidence_level`. This is a general method. Metrics with @@ -43,7 +44,8 @@ setGeneric( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_performance") } ) @@ -67,109 +69,144 @@ setMethod( is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # Message extraction start logger_message( paste0("Computing model performance metrics on the dataset."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) - # Load evaluation_times from the object settings attribute, if it is not - # provided. - if (is.waive(evaluation_times)) { - evaluation_times <- object@settings$eval_times - } + if (is.waive(evaluation_times)) evaluation_times <- object@settings$eval_times + if (is.waive(ensemble_method)) ensemble_method <- object@settings$ensemble_method + if (is.waive(confidence_level)) confidence_level <- object@settings$confidence_level + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- object@settings$bootstrap_ci_method + if (is.waive(metric)) metric <- object@settings$metric - # Check evaluation_times argument - if (object@outcome_type %in% c("survival")) { - sapply( - evaluation_times, - .check_number_in_valid_range, - var_name = "evaluation_times", - range = c(0.0, Inf), - closed = c(FALSE, TRUE)) - } + # Test if models are properly loaded + if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() - # Obtain ensemble method from stored settings, if required. - if (is.waive(ensemble_method)) { - ensemble_method <- object@settings$ensemble_method - } + # Check whether results should be aggregated. + aggregate_results <- .parse_aggregate_results( + x = aggregate_results, + object = object, + default = FALSE, + data_element = "model_performance" + ) - # Load confidence alpha from object settings attribute if not provided - # externally. - if (is.waive(confidence_level)) { - confidence_level <- object@settings$confidence_level - } + proto_data_element <- .create_extract_model_performance_object( + object = object, + metric = metric, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + detail_level = detail_level, + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) - # Check confidence_level input argument - .check_number_in_valid_range( - x = confidence_level, - var_name = "confidence_level", - range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) - - # Check ensemble_method argument - .check_parameter_value_is_valid( - x = ensemble_method, - var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) - - # Load the bootstrap method - if (is.waive(bootstrap_ci_method)) { - bootstrap_ci_method <- object@settings$bootstrap_ci_method - } + # Generate elements to send to dispatch. + performance_data <- extract_dispatcher( + FUN = .extract_model_performance_data, + has_internal_bootstrap = TRUE, + cl = cl, + object = object, + data = data, + proto_data_element = proto_data_element, + is_pre_processed = is_pre_processed, + ensemble_method = ensemble_method, + metric = metric, + evaluation_times = evaluation_times, + aggregate_results = aggregate_results, + message_indent = message_indent + 1L, + verbose = verbose + ) + + return(performance_data) + } +) + + +# extract_performance (prediction table) --------------------------------------- +setMethod( + "extract_performance", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + data, + cl = NULL, + metric = waiver(), + ensemble_method = waiver(), + evaluation_times = waiver(), + detail_level = waiver(), + estimation_type = waiver(), + aggregate_results = waiver(), + confidence_level = waiver(), + bootstrap_ci_method = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE, + ... + ) { - .check_parameter_value_is_valid( - x = bootstrap_ci_method, - var_name = "bootstrap_ci_method", - values = .get_available_bootstrap_confidence_interval_methods()) + if (is_empty(object)) return(NULL) - # Check the level detail. - detail_level <- .parse_detail_level( - x = detail_level, - object = object, - default = "hybrid", - data_element = "model_performance") + # Message extraction start + logger_message( + paste0("Computing model performance metrics from the prediction table."), + indent = message_indent, + verbose = verbose + ) - # Check the estimation type. - estimation_type <- .parse_estimation_type( - x = estimation_type, - object = object, - default = "bootstrap_confidence_interval", - data_element = "model_performance", - detail_level = detail_level, - has_internal_bootstrap = TRUE) + # Reference labels should be present. + if (!.has_reference_data(object)) { + ..warning_prediction_table_lacks_reference("model performance metrics") + return(NULL) + } + + # Load evaluation_times and ensemble method from the prediction table. + if (is.waive(evaluation_times) && methods::.hasSlot(object, "time")) { + evaluation_times <- object@time + } + if (is.waive(ensemble_method)) { + ensemble_method <- "median" + if (methods::.hasSlot(object, "ensemble_method")) ensemble_method <- object@ensemble_method + } + + # Set default metric + if (is.waive(metric)) metric <- .get_default_metric(outcome_type = object@outcome_type) + + # Default Values. + if (is.waive(detail_level)) detail_level <- "ensemble" + if (is.waive(estimation_type)) estimation_type <- "bootstrap_confidence_interval" + if (is.waive(confidence_level)) confidence_level <- 0.95 + if (is.waive(bootstrap_ci_method)) bootstrap_ci_method <- "bc" + if (is.waive(aggregate_results)) aggregate_results <- FALSE # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = FALSE, - data_element = "model_performance") - - # Load metric(s) from the object settings attribute if not provided - # externally. - if (is.waive(metric)) metric <- object@settings$metric + data_element = "model_performance" + ) - # Check metric input argument - sapply( - metric, - .check_metric_outcome_type, - object = object) - - # Test if models are properly loaded - if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() + # Copy object to prevent changing the provided object by reference. + object <- .copy(object) - # Generate a prototype data element. - proto_data_element <- new( - "familiarDataElementModelPerformance", + proto_data_element <- .create_extract_model_performance_object( + object = object, + metric = metric, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, detail_level = detail_level, estimation_type = estimation_type, confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method) + bootstrap_ci_method = bootstrap_ci_method + ) - # Generate elements to send to dispatch. performance_data <- extract_dispatcher( FUN = .extract_model_performance_data, has_internal_bootstrap = TRUE, @@ -183,7 +220,8 @@ setMethod( evaluation_times = evaluation_times, aggregate_results = aggregate_results, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(performance_data) } @@ -191,6 +229,89 @@ setMethod( +.create_extract_model_performance_object <- function( + object, + metric, + ensemble_method, + evaluation_times, + detail_level, + estimation_type, + confidence_level, + bootstrap_ci_method +) { + + # Check evaluation_times argument + if (object@outcome_type %in% c("survival")) { + sapply( + evaluation_times, + .check_number_in_valid_range, + var_name = "evaluation_times", + range = c(0.0, Inf), + closed = c(FALSE, TRUE) + ) + } + + # Check confidence_level input argument + .check_number_in_valid_range( + x = confidence_level, + var_name = "confidence_level", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + + # Check ensemble_method argument + .check_parameter_value_is_valid( + x = ensemble_method, + var_name = "ensemble_method", + values = .get_available_ensemble_prediction_methods() + ) + + # Check bootstrap_ci_method argument + .check_parameter_value_is_valid( + x = bootstrap_ci_method, + var_name = "bootstrap_ci_method", + values = .get_available_bootstrap_confidence_interval_methods() + ) + + # Check the level detail. + detail_level <- .parse_detail_level( + x = detail_level, + object = object, + default = "hybrid", + data_element = "model_performance" + ) + + # Check the estimation type. + estimation_type <- .parse_estimation_type( + x = estimation_type, + object = object, + default = "bootstrap_confidence_interval", + data_element = "model_performance", + detail_level = detail_level, + has_internal_bootstrap = TRUE + ) + + # Check metric input argument + sapply( + metric, + .check_metric_outcome_type, + object = object + ) + + # Generate a prototype data element. + proto_data_element <- new( + "familiarDataElementModelPerformance", + detail_level = detail_level, + estimation_type = estimation_type, + confidence_level = confidence_level, + bootstrap_ci_method = bootstrap_ci_method + ) + + return(proto_data_element) +} + + + .extract_model_performance_data <- function( object, proto_data_element, @@ -198,7 +319,6 @@ setMethod( aggregate_results, cl, ...) { - # Ensure that the object is loaded object <- load_familiar_object(object) @@ -206,10 +326,11 @@ setMethod( proto_data_element <- add_model_name(proto_data_element, object = object) # Add evaluation time as a identifier to the data element. - if (length(evaluation_times) > 0 && object@outcome_type == "survival") { + if (length(evaluation_times) > 0L && object@outcome_type == "survival") { data_elements <- add_data_element_identifier( x = proto_data_element, - evaluation_time = evaluation_times) + evaluation_time = evaluation_times + ) } else { data_elements <- list(proto_data_element) @@ -222,119 +343,187 @@ setMethod( object = object, aggregate_results = aggregate_results, cl = cl, - ...) + ... + ) return(performance_data) } +# ..extract_model_performance_data (generic) ----------------------------------- +setGeneric( + "..extract_model_performance_data", + function(object, ...) standardGeneric("..extract_model_performance_data") +) + + -..extract_model_performance_data <- function( - data_element, +# ..extract_model_performance_data (character) --------------------------------- +setMethod( + "..extract_model_performance_data", + signature(object = "character"), + function( + object, + ... + ){ + # Ensure that the object is loaded + object <- load_familiar_object(object) + + return(..extract_model_performance_data(object = object, ...)) + } +) + + + +# ..extract_model_performance_data (model, ensemble) --------------------------- +setMethod( + "..extract_model_performance_data", + signature(object = "familiarModelUnion"), + function( object, + data_element, data, - cl = NULL, is_pre_processed, ensemble_method, - metric, - aggregate_results, progress_bar = FALSE, verbose = FALSE, message_indent, - ...) { - - # Ensure that the object is loaded - object <- load_familiar_object(object) - - # Message the user concerning the time at which metrics are computed. This is - # only relevant for survival analysis. - if (length(data_element@identifiers$evaluation_time) > 0 && progress_bar) { - logger_message( - paste0( - "Computing metric value at time ", - data_element@identifiers$evaluation_time, "."), - indent = message_indent, - verbose = verbose) + ... + ) { + # Ensure that the object is loaded + object <- load_familiar_object(object) + + # Message the user concerning the time at which metrics are computed. This is + # only relevant for survival analysis. + if (length(data_element@identifiers$evaluation_time) > 0L && progress_bar) { + logger_message( + paste0( + "Computing metric value at time ", + data_element@identifiers$evaluation_time, "." + ), + indent = message_indent, + verbose = verbose + ) + } + + # Predict class probabilities. + prediction_data <- .predict( + object = object, + data = data, + time = data_element@identifiers$evaluation_time, + ensemble_method = ensemble_method, + is_pre_processed = is_pre_processed + ) + + # Capture empty or invalid prediction tables. + if (!all_predictions_valid(prediction_data)) return(NULL) + + return(..extract_model_performance_data( + object = prediction_data, + data_element = data_element, + ... + )) } - - # Predict class probabilities. - prediction_data <- .predict( - object = object, - data = data, - time = data_element@identifiers$evaluation_time, - ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed) - - # Check if any predictions are valid. - if (!all_predictions_valid( - prediction_data, - outcome_type = object@outcome_type)) { +) + + + +# ..extract_model_performance_data (prediction_table) -------------------------- +setMethod( + "..extract_model_performance_data", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + data_element, + data = NULL, + cl = NULL, + metric, + aggregate_results, + verbose = FALSE, + progress_bar = FALSE, + ... + ) { + # Check if that all predictions are valid. + if (!all_predictions_valid(object)) return(NULL) + + # Remove data with missing outcomes. + object <- filter_missing_outcome(data = object) + + # Check that any prediction data remain. + if (is_empty(object)) return(NULL) + + # Add metric as an identifier. + data_elements <- add_data_element_identifier( + x = data_element, + metric = metric + ) + + # Add bootstrap data. + bootstrap_data <- add_data_element_bootstrap(x = data_elements, ...) + + # Iterate over elements. + data_elements <- fam_mapply( + cl = cl, + assign = NULL, + FUN = .compute_model_performance, + data_element = bootstrap_data$data_element, + bootstrap = bootstrap_data$bootstrap, + bootstrap_seed = bootstrap_data$seed, + MoreArgs = list("data" = object), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) + + # Merge data elements + data_elements <- merge_data_elements(data_elements) + + if (aggregate_results) { + data_elements <- .compute_data_element_estimates(x = data_elements) + } + + return(data_elements) + } +) + + + +# ..extract_model_performance_data (NULL) -------------------------------------- +setMethod( + "..extract_model_performance_data", + signature(object = "NULL"), + function(object, ...) { return(NULL) } - - # Remove data with missing outcomes. - prediction_data <- remove_missing_outcomes( - data = prediction_data, - outcome_type = object@outcome_type) - - # Check that any prediction data remain. - if (is_empty(prediction_data)) return(NULL) - - # Add metric as an identifier. - data_elements <- add_data_element_identifier( - x = data_element, - metric = metric) - - # Add bootstrap data. - bootstrap_data <- add_data_element_bootstrap(x = data_elements, ...) - - # Iterate over elements. - data_elements <- fam_mapply( - cl = cl, - assign = NULL, - FUN = .compute_model_performance, - data_element = bootstrap_data$data_element, - bootstrap = bootstrap_data$bootstrap, - bootstrap_seed = bootstrap_data$seed, - MoreArgs = list( - "object" = object, - "data" = prediction_data), - progress_bar = progress_bar, - chopchop = TRUE) - - # Merge data elements - data_elements <- merge_data_elements(data_elements) - - if (aggregate_results) data_elements <- .compute_data_element_estimates(x = data_elements) - - return(data_elements) -} +) .compute_model_performance <- function( data_element, - object, data, bootstrap, - bootstrap_seed) { + bootstrap_seed +) { # Bootstrap the data. if (bootstrap) { data <- get_bootstrap_sample( data = data, - seed = bootstrap_seed) + seed = bootstrap_seed + ) } # Compute the score score <- compute_metric_score( metric = data_element@identifiers$metric, - object = object, data = data, - time = data_element@identifiers$evaluation_time) + time = data_element@identifiers$evaluation_time + ) # Set the value, if finite. - if (is.finite(score)) data_element@data <- list("value" = unname(score)) + if (is.finite(score)) { + data_element@data <- list("value" = unname(score)) + } return(data_element) } @@ -379,7 +568,8 @@ setGeneric( dir_path = NULL, aggregate_results = FALSE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_model_performance") } ) @@ -397,7 +587,8 @@ setMethod( dir_path = NULL, aggregate_results = FALSE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -409,7 +600,8 @@ setMethod( aggregate_results = aggregate_results, type = "performance", subtype = "metric", - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -426,7 +618,8 @@ setMethod( dir_path = NULL, aggregate_results = FALSE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -435,8 +628,11 @@ setMethod( list( "object" = object, "data_element" = "model_performance", - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_model_performance, @@ -445,7 +641,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationPermutationVimp.R b/R/FamiliarDataComputationPermutationVimp.R index 5ce04e9f..fe28b7e3 100644 --- a/R/FamiliarDataComputationPermutationVimp.R +++ b/R/FamiliarDataComputationPermutationVimp.R @@ -11,7 +11,9 @@ setClass( prototype = methods::prototype( value_column = "value", grouping_column = c("feature", "metric"), - similarity_metric = NA_character_)) + similarity_metric = NA_character_ + ) +) # extract_permutation_vimp (generic) ------------------------------------------- @@ -21,7 +23,7 @@ setClass( #'@description Computes and collects permutation variable importance from a #' `familiarEnsemble`. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@details This function also computes credibility intervals for the ensemble #' model, at the level of `confidence_level`. @@ -44,15 +46,18 @@ setGeneric( feature_similarity_threshold = waiver(), metric = waiver(), evaluation_times = waiver(), + sample_limit = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), confidence_level = waiver(), bootstrap_ci_method = waiver(), + n_important_features = waiver(), is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_permutation_vimp") } ) @@ -76,21 +81,24 @@ setMethod( feature_similarity_threshold = waiver(), metric = waiver(), evaluation_times = waiver(), + sample_limit = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), confidence_level = waiver(), bootstrap_ci_method = waiver(), + n_important_features = waiver(), is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, - ...) { - + ... + ) { # Message extraction start logger_message( paste0("Computing permutation variable importance for models in the dataset."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Load evaluation_times from the object settings attribute, if it is not # provided. @@ -105,7 +113,8 @@ setMethod( .check_number_in_valid_range, var_name = "evaluation_times", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) } # Obtain ensemble method from stored settings, if required. @@ -124,13 +133,15 @@ setMethod( x = confidence_level, var_name = "confidence_level", range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) + closed = c(FALSE, FALSE) + ) # Check ensemble_method argument .check_parameter_value_is_valid( x = ensemble_method, var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) + values = .get_available_ensemble_prediction_methods() + ) # Load the bootstrap method if (is.waive(bootstrap_ci_method)) { @@ -140,14 +151,16 @@ setMethod( .check_parameter_value_is_valid( x = bootstrap_ci_method, var_name = "bootstrap_ci_method", - values = .get_available_bootstrap_confidence_interval_methods()) + values = .get_available_bootstrap_confidence_interval_methods() + ) # Check the level detail. detail_level <- .parse_detail_level( x = detail_level, object = object, default = "hybrid", - data_element = "permutation_vimp") + data_element = "permutation_vimp" + ) # Check the estimation type. estimation_type <- .parse_estimation_type( @@ -156,14 +169,25 @@ setMethod( default = "bootstrap_confidence_interval", data_element = "permutation_vimp", detail_level = detail_level, - has_internal_bootstrap = TRUE) + has_internal_bootstrap = TRUE + ) # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = TRUE, - data_element = "permutation_vimp") + data_element = "permutation_vimp" + ) + + # Check the sample limit. This defines the subset of samples that are being + # assessed (if real data is used instead of a minimum subset). + sample_limit <- .parse_sample_limit( + x = sample_limit, + object = object, + default = 200L, + data_element = "permutation_vimp" + ) # Load metric(s) from the object settings attribute if not provided # externally. @@ -173,11 +197,12 @@ setMethod( sapply( metric, .check_metric_outcome_type, - object = object) + object = object + ) # Aggregate feature similarity data elements. feature_similarity <- .compute_data_element_estimates(feature_similarity) - feature_similarity <- feature_similarity[[1]] + feature_similarity <- feature_similarity[[1L]] # Obtain cluster method from stored settings, if required. if (is.waive(feature_cluster_method)) { @@ -235,11 +260,27 @@ setMethod( cluster_cut_method = feature_cluster_cut_method, cluster_similarity_threshold = feature_similarity_threshold, cluster_similarity_metric = feature_similarity_metric, - data_type = "feature") + data_type = "feature" + ) # Test if models are properly loaded if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() + # Check the number of important features. + n_important_features <- .parse_n_important_features( + x = n_important_features, + object = object, + default = 20, + data_element = "permutation_vimp" + ) + + # Set features to be shuffled for permutation. + important_features <- .select_important_features( + object = object, + data = data, + n_important_features = n_important_features + ) + # Generate a prototype data element. proto_data_element <- new( "familiarDataElementPermutationVimp", @@ -247,7 +288,8 @@ setMethod( estimation_type = estimation_type, confidence_level = confidence_level, bootstrap_ci_method = bootstrap_ci_method, - similarity_metric = feature_similarity_metric) + similarity_metric = feature_similarity_metric + ) # Generate elements and dispatch. vimp_data <- extract_dispatcher( @@ -260,7 +302,9 @@ setMethod( is_pre_processed = is_pre_processed, ensemble_method = ensemble_method, metric = metric, + sample_limit = sample_limit, evaluation_times = evaluation_times, + important_features = important_features, aggregate_results = aggregate_results, similarity_table = feature_similarity, cluster_method = feature_cluster_method, @@ -269,7 +313,8 @@ setMethod( cluster_similarity_threshold = feature_similarity_threshold, cluster_similarity_metric = feature_similarity_metric, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(vimp_data) } @@ -277,13 +322,27 @@ setMethod( +# extract_permutation_vimp (prediction table) ---------------------------------- +setMethod( + "extract_permutation_vimp", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("permutation variable importance") + + return(NULL) + } +) + + + .extract_permutation_vimp <- function( object, proto_data_element, evaluation_times = NULL, aggregate_results, cl, - ...) { + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -291,10 +350,11 @@ setMethod( proto_data_element <- add_model_name(proto_data_element, object = object) # Add evaluation time as a identifier to the data element. - if (length(evaluation_times) > 0 && object@outcome_type == "survival") { + if (length(evaluation_times) > 0L && object@outcome_type == "survival") { data_elements <- add_data_element_identifier( x = proto_data_element, - evaluation_time = evaluation_times) + evaluation_time = evaluation_times + ) } else { data_elements <- list(proto_data_element) @@ -307,7 +367,8 @@ setMethod( object = object, aggregate_results = aggregate_results, cl = cl, - ...) + ... + ) return(vimp_data) } @@ -321,6 +382,8 @@ setMethod( is_pre_processed, cl, ensemble_method, + sample_limit, + important_features, similarity_table, cluster_method, cluster_linkage, @@ -331,7 +394,8 @@ setMethod( progress_bar = FALSE, verbose = FALSE, message_indent, - ...) { + ... +) { # Compute prediction data. prediction_data <- .predict( @@ -339,32 +403,22 @@ setMethod( data = data, time = data_element@identifiers$evaluation_time, ensemble_method = ensemble_method, - is_pre_processed = is_pre_processed) + is_pre_processed = is_pre_processed + ) # Check if any predictions are valid. - if (!any_predictions_valid( - prediction_data, - outcome_type = object@outcome_type)) { - return(NULL) - } + if (!any_predictions_valid(prediction_data)) return(NULL) - # Remove data with missing predictions. - prediction_data <- remove_nonvalid_predictions( - prediction_data, - outcome_type = object@outcome_type) + # Remove data with invalid predictions. + prediction_data <- remove_invalid_predictions(prediction_data) # Remove data with missing outcomes. - prediction_data <- remove_missing_outcomes( - data = prediction_data, - outcome_type = object@outcome_type) + prediction_data <- filter_missing_outcome(prediction_data) # Check that any prediction data remain. if (is_empty(prediction_data)) return(NULL) - if (data.table::uniqueN( - prediction_data, - by = get_id_columns(id_depth = "sample")) < 5) { - return(NULL) - } + + if (get_n_samples(prediction_data) < 5L) return(NULL) # Explicitly load input data. We stop at the signature step because we want to # work with the unclustered input features, but may need to apply @@ -373,47 +427,48 @@ setMethod( object = object, data = data, is_pre_processed = is_pre_processed, - stop_at = "signature") + stop_at = "signature" + ) # Remove instances with missing outcomes. - data <- remove_missing_outcomes( - data = data, - outcome_type = object@outcome_type) + data <- filter_missing_outcome(data) # Perform some checks to see if there is sufficient data to perform a half-way # meaningful analysis. if (is_empty(data)) return(NULL) - if (data.table::uniqueN( - data@data, - by = get_id_columns(id_depth = "sample")) < 5) { - return(NULL) - } + if (get_n_samples(data) < 5L) return(NULL) # Message the user concerning the time at which metrics are computed. This is # only relevant for survival analysis. - if (length(data_element@identifiers$evaluation_time) > 0 && progress_bar) { + if (length(data_element@identifiers$evaluation_time) > 0L && progress_bar) { logger_message( paste0( "Computing permutation variable importance at time ", - data_element@identifiers$evaluation_time, "."), + data_element@identifiers$evaluation_time, "." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } + # Maintain only important features. The current set is based on the required # features. data <- filter_features( data = data, - available_features = object@model_features) + available_features = object@model_features + ) # Derive feature information feature_cluster_info <- .select_feature_clusters( + important_features = important_features, available_features = get_feature_columns(data), similarity_table = similarity_table, cluster_method = cluster_method, cluster_linkage = cluster_linkage, cluster_cut_method = cluster_cut_method, cluster_similarity_threshold = cluster_similarity_threshold, - cluster_similarity_metric = cluster_similarity_metric) + cluster_similarity_metric = cluster_similarity_metric + ) # Create full list of all instances that should be evaluated. bootstrap_data <- lapply( @@ -421,7 +476,8 @@ setMethod( .create_permutation_data_elements, data_element = data_element, similarity_threshold = feature_cluster_info$similarity_threshold, - ...) + ... + ) # Flatten the instance list. bootstrap_data <- .flatten_nested_list(bootstrap_data, flatten = TRUE) @@ -442,10 +498,15 @@ setMethod( "object" = object, "data" = data, "prediction_data" = prediction_data, - "ensemble_method" = ensemble_method), - list(...)), - progress_bar = progress_bar, - chopchop = TRUE) + "ensemble_method" = ensemble_method, + "important_features" = important_features, + "sample_limit" = sample_limit + ), + list(...) + ), + progress_bar = progress_bar && verbose, + chopchop = TRUE + ) # Merge data elements data_elements <- merge_data_elements(data_elements) @@ -462,7 +523,9 @@ setMethod( data_element, bootstrap, bootstrap_seed, + sample_limit, shuffled_features, + important_features, similarity_threshold, n_shuffles, object, @@ -477,22 +540,22 @@ setMethod( if (bootstrap) { data <- get_bootstrap_sample( data = data, - seed = bootstrap_seed) + seed = bootstrap_seed, + n_samples = sample_limit + ) } # Bootstrap the prediction data. if (bootstrap) { prediction_data <- get_bootstrap_sample( data = prediction_data, - seed = bootstrap_seed) + seed = bootstrap_seed, + n_samples = sample_limit + ) } # Check if any predictions are valid. - if (!any_predictions_valid( - prediction_data, - outcome_type = object@outcome_type)) { - return(NULL) - } + if (!any_predictions_valid(prediction_data)) return(NULL) # Determine metric scores for the real (unshuffled) data scores <- list() @@ -502,7 +565,8 @@ setMethod( data = NULL, prediction_data = prediction_data, shuffled_features = NULL, - ...) + ... + ) # Determine metric scores for the shuffled data. for (ii in seq_len(n_shuffles)) { @@ -512,30 +576,33 @@ setMethod( data = data, prediction_data = NULL, shuffled_features = shuffled_features, - ...) + ... + ) } # Combine to single data.table - scores <- data.table::rbindlist( - scores, - use.names = TRUE) + scores <- data.table::rbindlist(scores, use.names = TRUE) # Determine median score. - scores <- scores[, list( - "value" = stats::median(value, na.rm = TRUE)), - by = c("metric", "is_shuffled")] - + scores <- scores[ + , + list("value" = stats::median(value, na.rm = TRUE)), + by = c("metric", "is_shuffled") + ] + # Cast wide and compute difference between unshuffled and shuffled values. scores <- data.table::dcast( data = scores, metric ~ is_shuffled, - value.var = "value") + value.var = "value" + ) # Rename FALSE and TRUE columns to something that will not cause issues. data.table::setnames( x = scores, old = c("FALSE", "TRUE"), - new = c("unpermuted", "permuted")) + new = c("unpermuted", "permuted") + ) # Compute the difference between permuted and unpermuted values. scores[, "value" := unpermuted - permuted] @@ -543,12 +610,16 @@ setMethod( # Determine the number of metrics. n_metrics <- nrow(scores) + # Retain only important features for further mention. + important_features <- intersect(important_features, shuffled_features) + # Add features. - scores <- scores[rep(seq_len(n_metrics), each = length(shuffled_features))] + scores <- scores[rep(seq_len(n_metrics), each = length(important_features))] scores[, ":="( - "feature" = rep(shuffled_features, times = n_metrics), + "feature" = rep(important_features, times = n_metrics), "permuted" = NULL, - "unpermuted" = NULL)] + "unpermuted" = NULL + )] # Store to data element. data_element@data <- scores @@ -557,7 +628,8 @@ setMethod( # unchanged are multiplied. data_elements <- add_data_element_identifier( x = data_element, - similarity_threshold = similarity_threshold) + similarity_threshold = similarity_threshold + ) return(data_elements) } @@ -573,7 +645,8 @@ setMethod( shuffled_features = NULL, ensemble_method, is_pre_processed, - ...) { + ... +) { # Generate prediction data if it does not exist. if (is.null(prediction_data)) { @@ -593,7 +666,8 @@ setMethod( data.table::set( x = data@data, j = ii, - value = data@data[[ii]][shuffle_id]) + value = data@data[[ii]][shuffle_id] + ) } } } @@ -603,7 +677,8 @@ setMethod( object = object, data = data, time = data_element@identifiers$evaluation_time, - ensemble_method = ensemble_method) + ensemble_method = ensemble_method + ) } # Compute score. @@ -612,58 +687,69 @@ setMethod( compute_metric_score, object = object, data = prediction_data, - time = data_element@identifiers$evaluation_time) + time = data_element@identifiers$evaluation_time + ) return(data.table::data.table( "metric" = metric, "value" = score, - "is_shuffled" = !is.null(shuffled_features))) + "is_shuffled" = !is.null(shuffled_features) + )) } .select_feature_clusters <- function( + important_features, available_features, similarity_table, cluster_method, cluster_linkage, cluster_cut_method, cluster_similarity_threshold, - cluster_similarity_metric) { + cluster_similarity_metric +) { # Suppress NOTES due to non-standard evaluation in data.table name <- cluster_id <- similarity_threshold <- NULL + has_important_feature <- NULL if (is_empty(similarity_table)) { # Set the placeholder similarity threshold cluster_similarity_threshold <- ifelse( cluster_method %in% c("agnes", "diana", "hclust") && cluster_cut_method == "fixed_cut", 1.0, - Inf) + Inf + ) # Create method object. cluster_method_object <- create_cluster_method_object( cluster_method = "none", data_type = "feature", - cluster_representation_method = "none") + cluster_representation_method = "none" + ) # Update (no) similarity table. cluster_method_object@similarity_table <- methods::new( "noSimilarityTable", data = available_features, - data_type = cluster_method_object@data_type) + data_type = cluster_method_object@data_type + ) # Generate the clustering table. cluster_table <- create_clusters( object = cluster_method_object, - as_cluster_object = FALSE) + as_cluster_object = FALSE + ) # Add in the similarity threshold. cluster_table[, "similarity_threshold" := cluster_similarity_threshold] cluster_table[, "cluster_size" := .N, by = "cluster_id"] - } else if (cluster_method %in% c("agnes", "diana", "hclust") && - cluster_cut_method == "fixed_cut") { + } else if ( + cluster_method %in% c("agnes", "diana", "hclust") && + cluster_cut_method == "fixed_cut" + ) { # Solution for methods where multiple cuts are possible. # Create method object. @@ -674,14 +760,16 @@ setMethod( cluster_cut_method = cluster_cut_method, cluster_similarity_threshold = cluster_similarity_threshold, cluster_similarity_metric = cluster_similarity_metric, - cluster_representation_method = "none") + cluster_representation_method = "none" + ) # Update the similarity table and attach. cluster_method_object@similarity_table <- methods::new( "similarityTable", data = similarity_table@data[, mget(c("feature_name_1", "feature_name_2", "value"))], similarity_metric = cluster_similarity_metric, - data_type = cluster_method_object@data_type) + data_type = cluster_method_object@data_type + ) # Insert 1.0 if necessary. if (!1.0 %in% cluster_similarity_threshold) { @@ -691,7 +779,8 @@ setMethod( # Sort descending. cluster_similarity_threshold <- sort( cluster_similarity_threshold, - decreasing = TRUE) + decreasing = TRUE + ) # Obtain cluster tables for each threshold. cluster_table <- lapply( @@ -704,7 +793,8 @@ setMethod( # Generate the clustering table. cluster_table <- create_clusters( object = cluster_method_object, - as_cluster_object = FALSE) + as_cluster_object = FALSE + ) # Add in the similarity threshold and cluster size. cluster_table[, "similarity_threshold" := cluster_similarity_threshold] @@ -712,12 +802,11 @@ setMethod( return(cluster_table) }, - cluster_method_object = cluster_method_object) + cluster_method_object = cluster_method_object + ) # Concatenate to single table - cluster_table <- data.table::rbindlist( - cluster_table, - use.names = TRUE) + cluster_table <- data.table::rbindlist(cluster_table, use.names = TRUE) # Remove features that are not available. cluster_table <- cluster_table[name %in% available_features] @@ -733,19 +822,22 @@ setMethod( cluster_cut_method = cluster_cut_method, cluster_similarity_threshold = cluster_similarity_threshold, cluster_similarity_metric = cluster_similarity_metric, - cluster_representation_method = "none") + cluster_representation_method = "none" + ) # Update the similarity table and attach. cluster_method_object@similarity_table <- methods::new( "similarityTable", data = similarity_table@data[, mget(c("feature_name_1", "feature_name_2", "value"))], similarity_metric = cluster_similarity_metric, - data_type = cluster_method_object@data_type) + data_type = cluster_method_object@data_type + ) # Generate the clustering table. cluster_table <- create_clusters( object = cluster_method_object, - as_cluster_object = FALSE) + as_cluster_object = FALSE + ) # Add the similarity threshold. cluster_table[, "similarity_threshold" := -Inf] @@ -758,14 +850,30 @@ setMethod( # Identify the unique thresholds that were used. similarity_thresholds_used <- sort( unique(cluster_table$similarity_threshold), - decreasing = TRUE) + decreasing = TRUE + ) # Identify the unique clusters of features that should be computed. - cluster_table <- cluster_table[, list( - "similarity_threshold" = max(similarity_threshold), - "n_thresholds_same_cluster" = .N, - "cluster_id" = min(cluster_id)), - by = c("name", "cluster_size")] + cluster_table <- cluster_table[ + , + list( + "similarity_threshold" = max(similarity_threshold), + "n_thresholds_same_cluster" = .N, + "cluster_id" = min(cluster_id) + ), + by = c("name", "cluster_size") + ] + + # Determine which clusters have at least one unique feature. + cluster_table[, "has_important_feature" := name %in% important_features] + cluster_table[, "has_important_feature" := any(has_important_feature), by = c( + "similarity_threshold", + "n_thresholds_same_cluster", + "cluster_id", + "cluster_size" + )] + + cluster_table <- cluster_table[has_important_feature == TRUE][, "has_important_feature" := NULL] # Split the cluster table into clusters. cluster_list <- split( @@ -774,11 +882,14 @@ setMethod( "similarity_threshold", "n_thresholds_same_cluster", "cluster_id", - "cluster_size")) + "cluster_size" + ) + ) return(list( "similarity_threshold" = similarity_thresholds_used, - "feature_clusters" = cluster_list)) + "feature_clusters" = cluster_list + )) } @@ -787,7 +898,8 @@ setMethod( feature_cluster, data_element, similarity_threshold, - ...) { + ... +) { # Add bootstraps (if required). bootstrap_data <- add_data_element_bootstrap(x = data_element, ...) @@ -796,24 +908,27 @@ setMethod( bootstrap_data$features <- lapply( seq_along(bootstrap_data$data_element), function(ii, feature) (feature), - feature = feature_cluster$name) + feature = feature_cluster$name + ) # Identify the similarity threshold for which the current feature sets form # a cluster. - n <- feature_cluster$n_thresholds_same_cluster[1] + n <- feature_cluster$n_thresholds_same_cluster[1L] used_similarity_threshold <- head( - similarity_threshold[similarity_threshold <= feature_cluster$similarity_threshold[1]], - n = n) + similarity_threshold[similarity_threshold <= feature_cluster$similarity_threshold[1L]], + n = n + ) # Add similarity threshold. bootstrap_data$similarity_threshold <- lapply( seq_along(bootstrap_data$data_element), function(ii, similarity_threshold) (similarity_threshold), - similarity_threshold = used_similarity_threshold) + similarity_threshold = used_similarity_threshold + ) # Add number of shuffles. We don't introduce additional shuffles except for # point estimates. - n_shuffles <- ifelse(data_element@estimation_type == "point", 20, 1) + n_shuffles <- ifelse(data_element@estimation_type == "point", 20L, 1L) # Add shuffles. bootstrap_data$n_shuffles <- rep(n_shuffles, times = length(bootstrap_data$data_element)) @@ -882,7 +997,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_permutation_vimp") } ) @@ -900,7 +1016,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -912,7 +1029,8 @@ setMethod( aggregate_results = aggregate_results, type = "variable_importance", subtype = "permutation", - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -929,7 +1047,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -938,8 +1057,11 @@ setMethod( list( "object" = object, "data_element" = "permutation_vimp", - "aggregate_results" = aggregate_results), - list(...))) + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) return(do.call( export_permutation_vimp, @@ -948,7 +1070,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_results" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationPredictionData.R b/R/FamiliarDataComputationPredictionData.R index b1893573..d73f63c4 100644 --- a/R/FamiliarDataComputationPredictionData.R +++ b/R/FamiliarDataComputationPredictionData.R @@ -3,24 +3,6 @@ NULL -# familiarDataElementPredictionTable object ------------------------------------ -setClass( - "familiarDataElementPredictionTable", - contains = "familiarDataElement", - slots = list( - "ensemble_method" = "character", - "percentiles" = "ANY", - "type" = "ANY", - "outcome_type" = "ANY", - "class_levels" = "ANY"), - prototype = methods::prototype( - bootstrap_ci_method = "percentile", - ensemble_method = "median", - percentiles = NULL, - outcome_type = NULL, - class_levels = NULL, - type = "default")) - # extract_predictions (generic) ------------------------------------------------ @@ -28,7 +10,7 @@ setClass( #' #'@description Collects predicted values from models in a `familiarEnsemble`. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list with single-model and ensemble predictions. #'@md @@ -48,7 +30,8 @@ setGeneric( confidence_level = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_predictions") } ) @@ -72,7 +55,8 @@ setMethod( confidence_level = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # Extract predictions from the data using the models in the ensemble. Note: # we do not call the predict function on the familiarEnsemble directly as # this would cause predict to become highly convoluted, in particular with @@ -82,7 +66,8 @@ setMethod( logger_message( paste0("Computing ensemble predictions for the dataset."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Load evaluation_times from the object settings attribute, if it is not # provided. @@ -97,7 +82,8 @@ setMethod( .check_number_in_valid_range, var_name = "evaluation_times", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) } # Load confidence alpha from object settings attribute if not provided @@ -111,7 +97,8 @@ setMethod( x = confidence_level, var_name = "confidence_level", range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) + closed = c(FALSE, FALSE) + ) # Obtain ensemble method from stored settings, if required. if (is.waive(ensemble_method)) { @@ -122,14 +109,16 @@ setMethod( .check_parameter_value_is_valid( x = ensemble_method, var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) + values = .get_available_ensemble_prediction_methods() + ) # Check the level detail. detail_level <- .parse_detail_level( x = detail_level, object = object, default = "ensemble", - data_element = "prediction_data") + data_element = "prediction_data" + ) # Check the estimation type. estimation_type <- .parse_estimation_type( @@ -138,14 +127,16 @@ setMethod( default = "point", data_element = "prediction_data", detail_level = detail_level, - has_internal_bootstrap = FALSE) + has_internal_bootstrap = FALSE + ) # Check whether results should be aggregated. aggregate_results <- .parse_aggregate_results( x = aggregate_results, object = object, default = TRUE, - data_element = "prediction_data") + data_element = "prediction_data" + ) # Test if models are properly loaded if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() @@ -158,7 +149,8 @@ setMethod( "familiarDataElementPredictionTable", detail_level = detail_level, confidence_level = confidence_level, - estimation_type = estimation_type) + estimation_type = estimation_type + ) # Generate elements to send to dispatch. performance_data <- extract_dispatcher( @@ -173,7 +165,8 @@ setMethod( ensemble_method = ensemble_method, evaluation_times = evaluation_times, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(performance_data) } @@ -181,26 +174,41 @@ setMethod( +# extract_predictions (prediction table) --------------------------------------- +setMethod( + "extract_predictions", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + # A prediction table is already a prediction table :) + return(.complete(object)) + } +) + + + .extract_predictions <- function( object, proto_data_element, evaluation_times = NULL, cl, - ...) { - + ... +) { + # Ensure that the object is loaded object <- load_familiar_object(object) # Add model name. proto_data_element <- add_model_name( proto_data_element, - object = object) + object = object + ) # Add evaluation time as a identifier to the data element. - if (length(evaluation_times) > 0 && object@outcome_type == "survival") { + if (length(evaluation_times) > 0L && object@outcome_type == "survival") { data_elements <- add_data_element_identifier( x = proto_data_element, - evaluation_time = evaluation_times) + evaluation_time = evaluation_times + ) } else { data_elements <- list(proto_data_element) @@ -212,7 +220,8 @@ setMethod( ..extract_predictions, object = object, cl = cl, - ...) + ... + ) return(prediction_data) } @@ -235,43 +244,41 @@ setMethod( type <- c("default", "novelty") } - # Compute performance data. - prediction_data <- .predict( - object = object, - data = data, - ensemble_method = ensemble_method, - time = data_element@identifiers$evaluation_time, - type = type, - is_pre_processed = is_pre_processed, - aggregate_results = FALSE) - - # Store the type and ensemble method. - data_element@type <- type - data_element@ensemble_method <- ensemble_method - - if (object@outcome_type %in% c("binomial", "multinomial")) { - class_levels <- get_outcome_class_levels(x = object) - - } else { - class_levels <- NULL + data_element_list <- list() + for (ii in seq_along(type)) { + data_element_list[[ii]] <- .predict( + object = object, + data = data, + ensemble_method = ensemble_method, + time = data_element@identifiers$evaluation_time, + type = type[ii], + is_pre_processed = is_pre_processed, + aggregate_results = FALSE + ) } - # Set outcome type and class levels. - data_element@outcome_type <- object@outcome_type - data_element@class_levels <- class_levels - - # Store the prediction data in the data table. - data_element@data <- prediction_data - - # Set grouping columns - data_element@grouping_column <- get_non_feature_columns(object) - - # Set value columns - data_element@value_column <- setdiff( - colnames(prediction_data), - data_element@grouping_column) + data_element_list <- unlist(data_element_list) + data_element_list <- data_element_list[!sapply(data_element_list, is_empty)] + if (is_empty(data_element_list)) return(NULL) + + # Inherit from data_element + data_element_list <- lapply( + data_element_list, + function(x, ref) { + x@ensemble_method <- ref@ensemble_method + x@identifiers <- c(x@identifiers, ref@identifiers) + x@detail_level <- ref@detail_level + x@estimation_type <- ref@estimation_type + x@confidence_level <- ref@confidence_level + x@bootstrap_ci_method <- ref@bootstrap_ci_method + + return(.merge_slots_into_data(x)) + + }, + ref = data_element + ) - return(data_element) + return(data_element_list) } @@ -284,39 +291,34 @@ setMethod( x, x_list = NULL, object, - ...) { + ... + ) { # It might be that x was only used to direct to this method. if (!is.null(x_list)) x <- x_list if (!is.list(x)) x <- list(x) - + # Identify the estimation types of the current data elements. estimation_type <- sapply(x, function(x) (x@estimation_type)) - # Get prediction types - type <- unique(unlist(sapply(x, function(x) x@type))) - # Check percentiles and confidence level. - if (any(estimation_type %in% c("bci", "bootstrap_confidence_interval")) && - is.null(x[[1]]@percentiles) && - is.null(x[[1]]@confidence_level)) { + if ( + any(estimation_type %in% c("bci", "bootstrap_confidence_interval")) && + is.null(x[[1L]]@percentiles) && + is.null(x[[1L]]@confidence_level) + ) { ..error_reached_unreachable_code(paste0( "..compute_data_element_estimates: percentiles and confidence_level ", - "cannot both be NULL.")) + "cannot both be NULL." + )) } - + # Determine the bootstrap_ci_method and the aggregation function if (any(estimation_type %in% c("bci", "bootstrap_confidence_interval"))) { - bootstrap_ci_method <- ifelse(x[[1]]@ensemble_method == "median", "percentile", "bc") - aggregation_fun <- ..bootstrap_ci - - } else if (x[[1]]@ensemble_method == "median") { - bootstrap_ci_method <- NULL - aggregation_fun <- stats::median + ensemble_method <- ifelse(x[[1L]]@ensemble_method == "median", "percentile", "bc") } else { - bootstrap_ci_method <- NULL - aggregation_fun <- mean + ensemble_method <- x[[1L]]@ensemble_method } # Collate the data. @@ -332,322 +334,56 @@ setMethod( } # Select point estimate. - point_values <- data.table::as.data.table(x[estimation_type == "point"][[1]]@data) + point_values <- data.table::as.data.table(x[estimation_type == "point"][[1L]]@data) point_values[, "estimation_type" := "point"] # Select bootstrap values. bootstrap_values <- data.table::as.data.table( - x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1]]@data) + x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1L]]@data + ) bootstrap_values[, "estimation_type" := "bootstrap_confidence_interval"] # Combine to single table. data <- data.table::rbindlist( list(point_values, bootstrap_values), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) # Copy the familiarDataElement. - y <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1]] + y <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1L]] y@data <- NULL } else { # Select values. - data <- data.table::as.data.table(x[[1]]@data) - data[, "estimation_type" := x[[1]]@estimation_type] + data <- data.table::as.data.table(x[[1L]]@data) + data[, "estimation_type" := "ensemble"] # Copy the familiarDataElement. - y <- x[[1]] + y <- x[[1L]] y@data <- NULL } - if ("default" %in% type) { - y@data <- ..compute_ensemble_default_estimates( - data = data, - FUN = aggregation_fun, - bootstrap_ci_method = bootstrap_ci_method, - outcome_type = x[[1]]@outcome_type, - class_levels = x[[1]]@class_levels, - percentiles = x[[1]]@percentiles, - confidence_level = x[[1]]@confidence_level, - grouping_column = x[[1]]@grouping_column) - } - - # Determine if novelty is part of the columns. - if ("novelty" %in% type) { - temp_data <- ..compute_ensemble_novelty_estimates( - data = data, - FUN = aggregation_fun, - bootstrap_ci_method = bootstrap_ci_method, - percentiles = x[[1]]@percentiles, - confidence_level = x[[1]]@confidence_level, - grouping_column = x[[1]]@grouping_column) - - if (is.null(y@data)) { - y@data <- temp_data - - } else { - y@data <- merge( - x = y@data, - y = temp_data, - by = x[[1]]@grouping_column) - } - } - - # Determine if survival probabilities were computed. - if ("survival_probability" %in% type) { - temp_data <- ..compute_ensemble_survival_probability_estimates( - data = data, - FUN = aggregation_fun, - bootstrap_ci_method = bootstrap_ci_method, - percentiles = x[[1]]@percentiles, - confidence_level = x[[1]]@confidence_level, - grouping_column = x[[1]]@grouping_column) - - if (is.null(y@data)) { - y@data <- temp_data - - } else { - y@data <- merge( - x = y@data, - y = temp_data, - by = x[[1]]@grouping_column) - } - } - - # Determine if data were assigned to risk groups. - if ("risk_stratification" %in% type) { - temp_data <- ..compute_ensemble_risk_stratification( - data = data, - bootstrap_ci_method = bootstrap_ci_method, - ensemble_method = x[[1]]@ensemble_method, - grouping_column = x[[1]]@grouping_column) - - if (is.null(y@data)) { - y@data <- temp_data - - } else { - y@data <- merge( - x = y@data, - y = temp_data, - by = x[[1]]@grouping_column) - } - } + # Compute prediction data. + y@data <- ..compute_ensemble_prediction_estimates( + x = y, + data = data, + ensemble_method = ensemble_method + ) # Update value column - y@value_column <- setdiff( - names(y@data), - y@grouping_column) + y@value_column <- setdiff(names(y@data), y@grouping_column) return(y) } ) - -..compute_ensemble_default_estimates <- function( - data, - outcome_type, - class_levels = NULL, - grouping_column, - ...) { - - if (outcome_type %in% c("binomial", "multinomial")) { - - if (is.null(class_levels)) { - ..error_reached_unreachable_code( - "..compute_ensemble_default_estimates: class_levels cannot be NULL.") - } - - # Probability columns - prediction_columns <- get_class_probability_name(x = class_levels) - - } else if (outcome_type %in% c("continuous", "count", "survival")) { - # Outcome columns - prediction_columns <- "predicted_outcome" - - } else if (outcome_type == "competing_risk") { - ..error_outcome_type_not_implemented(outcome_type = outcome_type) - - } else { - ..error_no_known_outcome_type(outcome_type = outcome_type) - } - - # Compute ensemble estimates for the default predictions. - prediction_data <- data[, ...compute_ensemble_estimates( - x = .SD, - prediction_columns = prediction_columns, - ...), - by = c(grouping_column), - .SDcols = c("estimation_type", prediction_columns)] - - # Add the predicted class, if required - if (outcome_type %in% c("binomial", "multinomial")) { - - # Identify the name of the most probable class - new_predicted_class <- class_levels[max.col(prediction_data[, mget(prediction_columns)])] - - # Add the names as the predicted outcome - prediction_data[, "predicted_class" := new_predicted_class] - - # Convert to a factor - prediction_data$predicted_class <- factor( - prediction_data$predicted_class, - levels = class_levels) - } - - return(prediction_data) -} - - - -..compute_ensemble_novelty_estimates <- function( - data, - grouping_column, - ...) { - - # Compute ensemble estimates for the novelty score. - prediction_data <- data[, ...compute_ensemble_estimates( - x = .SD, - prediction_columns = "novelty", - ...), - by = c(grouping_column), - .SDcols = c("estimation_type", "novelty")] - - return(prediction_data) -} - - - -..compute_ensemble_survival_probability_estimates <- function( - data, - grouping_column, - ...) { - - # Compute ensemble estimates for the - prediction_data <- data[, ...compute_ensemble_estimates( - x = .SD, - prediction_columns = "survival_probability", - ...), - by = c(grouping_column), - .SDcols = c("estimation_type", "survival_probability")] - - return(prediction_data) -} - - - -..compute_ensemble_risk_stratification <- function( - data, - ensemble_method, - grouping_column, - bootstrap_ci_method = NULL, - ...) { - - # Suppress NOTES due to non-standard evaluation in data.table - risk_group <- estimation_type <- NULL - - if (!is.null(bootstrap_ci_method)) data <- data[estimation_type != "point"] - - # Create risk groups according to the corresponding method. - if (ensemble_method == "mean") { - prediction_data <- data[, list( - "risk_group" = get_mean_risk_group(risk_group)), - by = c(grouping_column)] - - } else if (ensemble_method == "median") { - prediction_data <- data[, list( - "risk_group" = get_mode(risk_group)), - by = c(grouping_column)] - } - - return(prediction_data) -} - - - -...compute_ensemble_estimates <- function( - x, - prediction_columns, - FUN, - bootstrap_ci_method = NULL, - confidence_level = NULL, - percentiles = NULL) { - - # Suppress NOTES due to non-standard evaluation in data.table - estimation_type <- NULL - - # Calculate ensemble value for the prediction columns. - if (is.null(bootstrap_ci_method)) { - ensemble_values <- lapply( - prediction_columns, - function(ii_col, x, aggregation_fun) { - values <- x[[ii_col]] - return(aggregation_fun(values[is.finite(values)])) - }, - x = x, - aggregation_fun = FUN) - - } else { - ensemble_values <- lapply( - prediction_columns, - function(ii_col, x, aggregation_fun) { - values <- x[estimation_type != "point"][[ii_col]] - - return(aggregation_fun( - x = values[is.finite(values)], - x0 = x[estimation_type == "point"][[ii_col]], - bootstrap_ci_method = bootstrap_ci_method, - confidence_level = confidence_level, - percentiles = percentiles)) - }, - x = x, - aggregation_fun = FUN) - } - - # Determine column names - column_names <- lapply( - seq_along(prediction_columns), - function(ii, prediction_columns, ensemble_values, parse_percentile) { - # If the content of element ii is not a list itself, it contains only a - # single value that should be named. - if (!is.list(ensemble_values[[ii]])) return(prediction_columns[ii]) - - if (!parse_percentile) { - # If the content of element ii is a list, assign the prediction column - # name to the first column, and add the name to the remainder. - - column_names <- prediction_columns[ii] - - if (length(ensemble_values[[ii]]) > 1) { - column_names <- c( - column_names, - paste0(prediction_columns[ii], "_", names(ensemble_values[[ii]])[2:length(ensemble_values[[ii]])])) - } - - return(column_names) - - } else { - # Assign the prediction column name to every column in case percentiles - # are returned. - return(paste0(prediction_columns[ii], "_", names(ensemble_values[[ii]]))) - } - }, - prediction_columns = prediction_columns, - ensemble_values = ensemble_values, - parse_percentile = !is.null(bootstrap_ci_method) && is.null(confidence_level) && !is.null(percentiles)) - - # Flatten list of column names - column_names <- unlist(column_names) - - # Flatten list of ensemble values. - ensemble_values <- unlist(ensemble_values, recursive = FALSE) - if (!is.list(ensemble_values)) ensemble_values <- as.list(ensemble_values) - - # Set column names. - names(ensemble_values) <- column_names - - return(ensemble_values) -} +# ..compute_ensemble_prediction_estimates (generic) ---------------------------- +setGeneric( + "..compute_ensemble_prediction_estimates", + function(x, ...) standardGeneric("..compute_ensemble_prediction_estimates") +) @@ -688,40 +424,14 @@ setGeneric( object, dir_path = NULL, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_prediction_data") } ) -# #export_prediction_data (collection) ----------------------------------------- - -#'@rdname export_prediction_data-methods -setMethod( - "export_prediction_data", - signature(object = "familiarCollection"), - function( - object, - dir_path = NULL, - export_collection = FALSE, - ...) { - - # Make sure the collection object is updated. - object <- update_object(object = object) - - return(.export( - x = object, - data_slot = "prediction_data", - dir_path = dir_path, - type = "prediction", - subtype = NULL, - export_collection = export_collection)) - } -) - - - # export_prediction_data (general) --------------------------------------------- #'@rdname export_prediction_data-methods @@ -732,7 +442,8 @@ setMethod( object, dir_path = NULL, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -740,8 +451,11 @@ setMethod( args = c( list( "object" = object, - "data_element" = "prediction_data"), - list(...))) + "data_element" = "prediction_data" + ), + list(...) + ) + ) return(do.call( export_prediction_data, @@ -749,7 +463,10 @@ setMethod( list( "object" = object, "dir_path" = dir_path, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationRiskStratificationData.R b/R/FamiliarDataComputationRiskStratificationData.R index a24cc599..e41fad60 100644 --- a/R/FamiliarDataComputationRiskStratificationData.R +++ b/R/FamiliarDataComputationRiskStratificationData.R @@ -1,34 +1,26 @@ #' @include FamiliarS4Generics.R #' @include FamiliarS4Classes.R -#' @include FamiliarDataComputationPredictionData.R +#' @include PredictionTable.R NULL -# familiarDataElementRiskStratification (object) ------------------------------- -setClass( - "familiarDataElementRiskStratification", - contains = "familiarDataElementPredictionTable", - slots = list("time" = "ANY"), - prototype = methods::prototype( - bootstrap_ci_method = "percentile", - ensemble_method = "median", - estimation_type = "point", - type = "risk_stratification", - time = NULL)) # familiarDataElementRiskStrata (object) --------------------------------------- setClass( "familiarDataElementRiskStrata", - contains = "familiarDataElement") + contains = "familiarDataElement" +) # familiarDataElementRiskHazardRatio (object) ---------------------------------- setClass( "familiarDataElementRiskHazardRatio", - contains = "familiarDataElement") + contains = "familiarDataElement" +) # familiarDataElementRiskLogrank (object) -------------------------------------- setClass( "familiarDataElementRiskLogrank", - contains = "familiarDataElement") + contains = "familiarDataElement" +) @@ -41,7 +33,7 @@ setClass( #' Kaplan-Meier plots, as well as logrank and hazard-ratio tests between the #' respective risk groups. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list with data.tables containing information concerning risk group #' stratification. @@ -59,7 +51,8 @@ setGeneric( confidence_level = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_risk_stratification_data") } ) @@ -81,7 +74,8 @@ setMethod( stratification_method = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # This mostly follows the same routines as extract_prediction_data. In # addition, tests are created during export. @@ -93,7 +87,8 @@ setMethod( logger_message( paste0("Assessing stratification into risk groups."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Load confidence alpha from object settings attribute if not provided # externally. @@ -106,7 +101,8 @@ setMethod( x = confidence_level, var_name = "confidence_level", range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) + closed = c(FALSE, FALSE) + ) # Obtain ensemble method from stored settings, if required. if (is.waive(ensemble_method)) { @@ -117,14 +113,16 @@ setMethod( .check_parameter_value_is_valid( x = ensemble_method, var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) + values = .get_available_ensemble_prediction_methods() + ) # Check the level detail. detail_level <- .parse_detail_level( x = detail_level, object = object, default = "ensemble", - data_element = "risk_stratification_data") + data_element = "risk_stratification_data" + ) # Test if models are properly loaded if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() @@ -136,7 +134,8 @@ setMethod( # Check available stratification methods. available_stratification_method <- unique(unlist(lapply( model_list, - function(fam_model) (fam_model@km_info$stratification_method)))) + function(fam_model) (fam_model@km_info$stratification_method) + ))) # Check that any are available. if (is.null(available_stratification_method)) return(NULL) @@ -151,16 +150,19 @@ setMethod( .check_parameter_value_is_valid( x = stratification_method, var_name = "stratification_method", - values = available_stratification_method) + values = available_stratification_method + ) # Aggregate data. It does not make sense to keep duplicate rows here. data <- aggregate_data(data = data) # Generate a prototype data element. proto_data_element <- new( - "familiarDataElementRiskStratification", + "predictionTableRiskGroups", detail_level = detail_level, - confidence_level = confidence_level) + confidence_level = confidence_level, + estimation_type = "point" + ) # Generate elements to send to dispatch. performance_data <- extract_dispatcher( @@ -176,7 +178,8 @@ setMethod( ensemble_method = ensemble_method, time = object@settings$time_max, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(performance_data) } @@ -184,20 +187,180 @@ setMethod( +# extract_risk_stratification_data (risk groups) ------------------------------- +setMethod( + "extract_risk_stratification_data", + signature(object = "predictionTableRiskGroups"), + function( + object, + confidence_level = waiver(), + ... + ) { + if (is_empty(object)) return(NULL) + + # Reference labels should be present. + if (!.has_reference_data(object)) { + ..warning_prediction_table_lacks_reference("risk stratification") + return(NULL) + } + + # Ensure that all slots are merged into data. + object <- .copy(object) + object <- .merge_slots_into_data(object) + + # Load confidence alpha from object settings attribute if not provided + # externally. + if (is.waive(confidence_level)) { + confidence_level <- 0.95 + } + + # Check confidence_level input argument + .check_number_in_valid_range( + x = confidence_level, + var_name = "confidence_level", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + + # Set confidence level. + object@confidence_level <- confidence_level + + return(object) + } +) + + + +# extract_risk_stratification_data (dataObject) -------------------------------- +setMethod( + "extract_risk_stratification_data", + signature(object = "dataObject"), + function( + object, + data, + cl = NULL, + is_pre_processed = FALSE, + ensemble_method = waiver(), + detail_level = waiver(), + confidence_level = waiver(), + stratification_method = waiver(), + message_indent = 0L, + verbose = FALSE, + risk_group_column = waiver(), + ... + ) { + + # This mostly follows the same routines as extract_prediction_data. In + # addition, tests are created during export. + + # Only assess stratification for survival outcomes. + if (!object@outcome_type %in% c("survival")) return(NULL) + + # Message extraction start + logger_message( + paste0("Assessing stratification into risk groups."), + indent = message_indent, + verbose = verbose + ) + + # Set default confidence alpha from object settings attribute if not provided + # externally. + if (is.waive(confidence_level)) confidence_level <- 0.95 + + # Check confidence_level input argument + .check_number_in_valid_range( + x = confidence_level, + var_name = "confidence_level", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + + if (is.waive(risk_group_column)) risk_group_column <- get_id_columns("batch") + + # Check if only one column is provided as risk_group_column. + .check_argument_length( + x = risk_group_column, + var_name = "risk_group_column", + min = 1L, + max = 1L + ) + + # Check that the risk group column can be found in the dataset. + if (!risk_group_column %in% colnames(object@data)) { + ..error(paste0(risk_group_column, " is not a column in the data.")) + } + + # Convert to prediction table. + prediction_data <- as_prediction_table( + x = object@data[[risk_group_column]], + type = "risk_stratification", + data = object + ) + prediction_data <- .merge_slots_into_data(prediction_data) + + # Manually set attributes for this dataElement. + prediction_data@detail_level <- "ensemble" + prediction_data@estimation_type <- "point" + prediction_data@confidence_level <- confidence_level + prediction_data@bootstrap_ci_method <- "percentile" + prediction_data@is_aggregated <- FALSE + prediction_data@learner <- "none" + prediction_data@vimp_method <- "none" + + # Add model name. + prediction_data <- add_model_name(prediction_data, object = object) + + # Add stratification methods. + prediction_data <- add_data_element_identifier( + x = prediction_data, + stratification_method = "external" + ) + + return(prediction_data) + } +) + + + +# extract_risk_stratification_data (prediction table) -------------------------- +setMethod( + "extract_risk_stratification_data", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("risk stratification") + + return(NULL) + } +) + + + +# extract_risk_stratification_data (NULL) -------------------------------------- +setMethod( + "extract_risk_stratification_data", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) + + + .extract_risk_stratification_data <- function( object, proto_data_element, cl = NULL, stratification_method, - ...) { - + ... +) { # Add model name. proto_data_element <- add_model_name(proto_data_element, object = object) # Add stratification methods. data_elements <- add_data_element_identifier( x = proto_data_element, - stratification_method = stratification_method) + stratification_method = stratification_method + ) # Iterate over data elements. data_elements <- lapply( @@ -205,7 +368,8 @@ setMethod( ..extract_risk_stratification_data, object = object, cl = cl, - ...) + ... + ) return(data_elements) } @@ -220,7 +384,8 @@ setMethod( is_pre_processed, ensemble_method, time, - ...) { + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -232,31 +397,24 @@ setMethod( time = time, type = "risk_stratification", stratification_method = data_element@identifiers$stratification_method, - is_pre_processed = is_pre_processed, - aggregate_results = FALSE) - - # Store the type and ensemble method. - data_element@type <- "risk_stratification" - data_element@ensemble_method <- ensemble_method - - # Set outcome type. - data_element@outcome_type <- object@outcome_type - - # Store the prediction data in the data table. - data_element@data <- prediction_data - - # Set grouping columns - data_element@grouping_column <- get_non_feature_columns(object) + is_pre_processed = is_pre_processed + ) + + # Ensure that all slots are merged into data. + prediction_data <- .merge_slots_into_data(prediction_data) - # Set value columns - data_element@value_column <- setdiff( - colnames(prediction_data), - data_element@grouping_column) + if (is_empty(prediction_data)) return(NULL) - # Set time attribute - data_element@time <- time + # We will actually use prediction_data from here, but need to update some + # attributes. + prediction_data@detail_level <- data_element@detail_level + prediction_data@estimation_type <- data_element@estimation_type + prediction_data@confidence_level <- data_element@confidence_level + prediction_data@bootstrap_ci_method <- data_element@bootstrap_ci_method + prediction_data@is_aggregated <- FALSE + prediction_data@identifiers <- c(prediction_data@identifiers, data_element@identifiers) - return(data_element) + return(prediction_data) } @@ -264,45 +422,49 @@ setMethod( .compute_risk_stratification_curves <- function(x, time_range = NULL) { if (is_empty(x)) return(NULL) - if (!all_predictions_valid(x@data, outcome_type = "survival")) return(NULL) + if (!all_predictions_valid(x)) return(NULL) if (!x@is_aggregated) { ..error_reached_unreachable_code( - ".compute_risk_stratification_curves: expecting aggregated data.") + ".compute_risk_stratification_curves: expecting aggregated data." + ) } - - # Copy the data element. - data <- data.table::copy(x@data) + + # Make local copy. + data <- .copy(x) # Remove data with missing predictions. - data <- remove_nonvalid_predictions( - data, - outcome_type = "survival") + data <- remove_invalid_predictions(data) # Remove data with missing outcomes. - data <- remove_missing_outcomes( - data = data, - outcome_type = "survival") + data <- filter_missing_outcome(data, outcome_type = "survival") # Check that any prediction data remain. if (is_empty(data)) return(NULL) # Create new element with strata based on x. data_element <- methods::new( - "familiarDataElementRiskLogrank", + "familiarDataElementRiskStrata", x, grouping_column = c( setdiff(x@grouping_column, c(get_non_feature_columns(x = "survival"))), - "risk_group"), - value_column = "survival") + "group" + ), + value_column = "survival" + ) # Collect strata - strata <- data[, ..compute_risk_stratification_curves( - .SD, - confidence_level = data_element@confidence_level, - time_range = time_range), + data <- .merge_slots_into_data(data) + strata <- data@data[ + , + ..compute_risk_stratification_curves( + .SD, + confidence_level = data_element@confidence_level, + time_range = time_range + ), by = c(data_element@grouping_column), - .SDcols = c("outcome_time", "outcome_event")] + .SDcols = c("outcome_time", "outcome_event") + ] # Check that strata are not empty. if (is_empty(strata)) return(NULL) @@ -327,8 +489,10 @@ setMethod( survival::survfit( Surv(outcome_time, outcome_event) ~ 1, data = x, - conf.int = confidence_level), - error = identity) + conf.int = confidence_level + ), + error = identity + ) # Check if the survival curve could be generated at all. Causes could be lack # of events, no events beyond the first time point, etc. @@ -342,59 +506,69 @@ setMethod( "n_censor" = km_fit$n.censor, "survival" = km_fit$surv, "ci_low" = km_fit$lower, - "ci_up" = km_fit$upper) + "ci_up" = km_fit$upper + ) # Add in data at time = 0 if necessary. - if (min(km_data$time) > 0) { - km_data <- rbind(data.table::data.table( - "time" = 0.0, - "group_size" = km_fit$n, - "n_event" = 0, - "n_censor" = 0, - "survival" = 1.00, - "ci_low" = km_fit$lower[1], - "ci_up" = 1.0), - km_data) + if (min(km_data$time) > 0.0) { + km_data <- rbind( + data.table::data.table( + "time" = 0.0, + "group_size" = km_fit$n, + "n_event" = 0L, + "n_censor" = 0L, + "survival" = 1.00, + "ci_low" = km_fit$lower[1L], + "ci_up" = 1.0 + ), + km_data + ) } # Update absent censoring (notably when survival is 0). - km_data[survival == 0 & is.na(ci_low), "ci_low" := 0.0] - km_data[survival == 0 & is.na(ci_up), "ci_up" := 0.0] + km_data[survival == 0.0 & is.na(ci_low), "ci_low" := 0.0] + km_data[survival == 0.0 & is.na(ci_up), "ci_up" := 0.0] # In rare circumstances (i.e. single-sample risk groups), ci_low may be # missing at the initial time point. - km_data[time == 0 & is.na(ci_low), "ci_low" := 0.0] + km_data[time == 0.0 & is.na(ci_low), "ci_low" := 0.0] if (!is.null(time_range)) { # Add an entry at the proximal and distal range edges. This prevents the # curve from being cut off prematurely, or starting too late. - if (is_empty(km_data[time == time_range[1]]) && - time_range[1] > min(km_data$time) && - time_range[1] < max(km_data$time)) { + if ( + is_empty(km_data[time == time_range[1L]]) && + time_range[1L] > min(km_data$time) && + time_range[1L] < max(km_data$time) + ) { # Select the closest entry prior to the proximal edge, make changes and # introduce it back into the data. - proximal_data <- tail(km_data[time < time_range[1]][order(time)], n = 1L) + proximal_data <- tail(km_data[time < time_range[1L]][order(time)], n = 1L) proximal_data[, ":="( - "time" = time_range[1], - "n_event" = 0, - "n_censor" = 0)] + "time" = time_range[1L], + "n_event" = 0L, + "n_censor" = 0L + )] km_data <- rbind(km_data, proximal_data)[order(time)] } - if (is_empty(km_data[time == time_range[2]]) && - time_range[2] > min(km_data$time) && - time_range[2] < max(km_data$time)) { + if ( + is_empty(km_data[time == time_range[2L]]) && + time_range[2L] > min(km_data$time) && + time_range[2L] < max(km_data$time) + ) { # Do the same for the distal edge. - distal_data <- tail(km_data[time < time_range[2]][order(time)], n = 1) + distal_data <- tail(km_data[time < time_range[2L]][order(time)], n = 1L) distal_data[, ":="( - "time" = time_range[2], - "n_event" = 0, - "n_censor" = 0)] + "time" = time_range[2L], + "n_event" = 0L, + "n_censor" = 0L + )] km_data <- rbind(km_data, distal_data)[order(time)] } # Limit strata to the time range. - km_data <- km_data[time >= time_range[1] & time <= time_range[2]] + km_data <- km_data[time >= time_range[1L] & time <= time_range[2L]] } return(as.list(km_data)) @@ -408,52 +582,49 @@ setMethod( outcome_time <- NULL if (is_empty(x)) return(NULL) - if (!all_predictions_valid(x@data, outcome_type = "survival")) return(NULL) if (!x@is_aggregated) { ..error_reached_unreachable_code( - ".compute_risk_stratification_test: expecting aggregated data.") + ".compute_risk_stratification_test: expecting aggregated data." + ) } - # Copy the data element. - data <- data.table::copy(x@data) + # Make local copy. + x <- .copy(x) - # Remove data without known outcome time, or failed risk-group predictions. - data <- remove_nonvalid_predictions( - data, - outcome_type = "survival") - data <- remove_missing_outcomes( - data = data, - outcome_type = "survival") + # Remove data with missing predictions or missing outcomes. + x <- remove_invalid_predictions(x) + x <- filter_missing_outcome(x, outcome_type = "survival") - if (is_empty(data)) return(NULL) + # Check that any prediction data remain. + if (is_empty(x)) return(NULL) # Right-censor the data to the desired time window. if (!is.null(time_range)) { # Right censor data past the time range. - data[outcome_time > time_range[2], "outcome_event" := 0] + x@data[outcome_time > time_range[2L], "outcome_event" := 0L] } - - # Determine the number of groups. - n_groups <- data.table::uniqueN(x@data$risk_group) - + # Check that 2 (or more risk groups) are present. - if (n_groups < 2) return(NULL) + if (length(x@groups) < 2L) return(NULL) # Get data from logrank tests. logrank_data <- .compute_risk_stratification_logrank_test( x = x, - time_range = time_range) + time_range = time_range + ) # Get data from hazard ratio tests. hr_data <- .compute_risk_stratification_hazard_ratio_test( x = x, - confidence_level = x@confidence_level) + confidence_level = x@confidence_level + ) # Return test results return(list( "logrank" = logrank_data, - "hazard_ratio" = hr_data)) + "hazard_ratio" = hr_data + )) } @@ -469,38 +640,50 @@ setMethod( x, grouping_column = c(setdiff( x@grouping_column, - c(get_non_feature_columns(x = "survival")))), - value_column = c("p_value", "p_value_adjusted")) + c(get_non_feature_columns(x = "survival")) + )), + value_column = c("p_value", "p_value_adjusted") + ) # Compute logrank test over all risk groups. - overall_results <- x@data[, ..compute_risk_stratification_logrank_test( - x = .SD), + data <- .as_data_table(x) + overall_results <- data[ + , + ..compute_risk_stratification_logrank_test(x = .SD), by = c(data_element@grouping_column), - .SDcols = c("outcome_time", "outcome_event", "risk_group")] + .SDcols = c("outcome_time", "outcome_event", "group") + ] # Get all pairs pairs <- utils::combn( - x = unique(x@data$risk_group), + x = x@groups, m = 2L, - simplify = FALSE) + simplify = FALSE + ) # Compute logrank test results over all risk groups. - pairwise_results <- x@data[, dmapply( - ..compute_risk_stratification_logrank_test, - selected_groups = pairs, - MoreArgs = list("x" = .SD)), + pairwise_results <- data[ + , + dmapply( + ..compute_risk_stratification_logrank_test, + selected_groups = pairs, + MoreArgs = list("x" = .SD) + ), by = c(data_element@grouping_column), - .SDcols = c("outcome_time", "outcome_event", "risk_group")] + .SDcols = c("outcome_time", "outcome_event", "group") + ] # Compute multiple-testing corrected p-value. - pairwise_results[, "p_value_adjusted" := stats::p.adjust(p_value, method = "holm"), - by = c(data_element@grouping_column)] + pairwise_results[ + , + "p_value_adjusted" := stats::p.adjust(p_value, method = "holm"), + by = c(data_element@grouping_column) + ] # Combine to single table and return. data_element@data <- data.table::rbindlist( - list(overall_results, pairwise_results), - use.names = TRUE, - fill = TRUE) + list(overall_results, pairwise_results), use.names = TRUE, fill = TRUE + ) return(data_element) } @@ -510,25 +693,27 @@ setMethod( ..compute_risk_stratification_logrank_test <- function(x, selected_groups = NULL) { # Suppress NOTES due to non-standard evaluation in data.table - risk_group <- NULL + group <- NULL # Select indicated risk groups and make sure they are both present. - if (!is.null(selected_groups)) x <- x[risk_group %in% selected_groups] + if (!is.null(selected_groups)) x <- x[group %in% selected_groups] # Determine the number of groups. - n_groups <- data.table::uniqueN(x$risk_group) + n_groups <- data.table::uniqueN(x$group) # Check that 2 (or more risk groups) are present. - if (n_groups < 2) return(NULL) + if (n_groups < 2L) return(NULL) # Determine chi-square of log-rank test chi_sq <- tryCatch( survival::survdiff( - survival::Surv(time = outcome_time, event = outcome_event) ~ risk_group, + survival::Surv(time = outcome_time, event = outcome_event) ~ group, data = x, subset = NULL, - na.action = "na.omit")$chisq, - error = identity) + na.action = "na.omit" + )$chisq, + error = identity + ) # Check if the test statistic could be computed. Causes could be lack of # events, no events beyond the first time point, etc. @@ -537,23 +722,25 @@ setMethod( # Derive p-value p_value <- stats::pchisq( q = chi_sq, - df = n_groups - 1, - lower.tail = FALSE) + df = n_groups - 1L, + lower.tail = FALSE + ) # In case all groups should be compared, add a place-holder name. if (is.null(selected_groups)) { - risk_group_1 <- risk_group_2 <- "all" + group_1 <- group_2 <- "all" } else { - risk_group_1 <- selected_groups[1] - risk_group_2 <- selected_groups[2] + group_1 <- selected_groups[1L] + group_2 <- selected_groups[2L] } # Set data. test_data <- data.table::data.table( - "risk_group_1" = risk_group_1, - "risk_group_2" = risk_group_2, - "p_value" = p_value) + "group_1" = group_1, + "group_2" = group_2, + "p_value" = p_value + ) return(as.list(test_data)) } @@ -570,29 +757,39 @@ setMethod( x, grouping_column = c(setdiff( x@grouping_column, - get_non_feature_columns(x = "survival"))), - value_column = c("p_value", "p_value_adjusted")) + get_non_feature_columns(x = "survival") + )), + value_column = c("p_value", "p_value_adjusted") + ) # Isolate data. - data <- x@data - data$risk_group <- droplevels(data$risk_group) + data <- .as_data_table(x) + data$group <- droplevels(data$group) # Use the first group as reference for ordinal variables. - reference_groups <- levels(data$risk_group)[1] + reference_groups <- levels(data$group)[1L] # Compute hazard test results over all risk groups. - hr_results <- data[, dmapply( - ..compute_risk_stratification_hazard_ratio_test, - reference_group = reference_groups, - MoreArgs = list( - "x" = .SD, - "confidence_level" = confidence_level)), + hr_results <- data[ + , + dmapply( + ..compute_risk_stratification_hazard_ratio_test, + reference_group = reference_groups, + MoreArgs = list( + "x" = .SD, + "confidence_level" = confidence_level + ) + ), by = c(data_element@grouping_column), - .SDcols = c("outcome_time", "outcome_event", "risk_group")] + .SDcols = c("outcome_time", "outcome_event", "group") + ] # Compute multiple-testing corrected p-value. - hr_results[, "p_value_adjusted" := stats::p.adjust(p_value, method = "holm"), - by = c(data_element@grouping_column)] + hr_results[ + , + "p_value_adjusted" := stats::p.adjust(p_value, method = "holm"), + by = c(data_element@grouping_column) + ] # Store to data element. data_element@data <- hr_results @@ -605,41 +802,45 @@ setMethod( ..compute_risk_stratification_hazard_ratio_test <- function( x, reference_group, - confidence_level) { + confidence_level +) { # Determine the number of groups. - n_groups <- data.table::uniqueN(x$risk_group) + n_groups <- data.table::uniqueN(x$group) # Check that 2 (or more risk groups) are present. - if (n_groups < 2) return(NULL) + if (n_groups < 2L) return(NULL) # Check if the reference group is present. - if (!any(x$risk_group == reference_group)) return(NULL) + if (!any(x$group == reference_group)) return(NULL) # Make local copy of x. x <- data.table::copy(x) - # Force the risk_group column to be categorical. - if (is.factor(x$risk_group)) { - x$risk_group <- droplevels(x$risk_group) + # Force the group column to be categorical. + if (is.factor(x$group)) { + x$group <- droplevels(x$group) } else { - x$risk_group <- as.factor(x = x$risk_group) + x$group <- as.factor(x$group) } # Reset the reference risk group - if (!is.ordered(x$risk_group)) { - x$risk_group <- stats::relevel( - x$risk_group, - ref = reference_group) + if (!is.ordered(x$group)) { + x$group <- stats::relevel( + x$group, + ref = reference_group + ) } # Create Cox proportional hazards model. model <- suppressWarnings(tryCatch( survival::coxph( - survival::Surv(time = outcome_time, event = outcome_event) ~ risk_group, - data = x), - error = identity)) + survival::Surv(time = outcome_time, event = outcome_event) ~ group, + data = x + ), + error = identity + )) # Check if the Cox PH model could not be computed. Causes could be lack of # events, no events beyond the first time point, etc. @@ -651,11 +852,12 @@ setMethod( # Fill test data. test_data <- data.table::data.table( "reference_group" = reference_group, - "risk_group" = levels(x$risk_group)[-1], - "hazard_ratio" = summary_info$conf.int[, 1], - "ci_low" = summary_info$conf.int[, 3], - "ci_up" = summary_info$conf.int[, 4], - "p_value" = summary_info$coefficients[, 5]) + "group" = levels(x$group)[-1L], + "hazard_ratio" = summary_info$conf.int[, 1L], + "ci_low" = summary_info$conf.int[, 3L], + "ci_up" = summary_info$conf.int[, 4L], + "p_value" = summary_info$coefficients[, 5L] + ) # Return test results return(as.list(test_data)) @@ -714,7 +916,8 @@ setGeneric( export_strata = TRUE, time_range = NULL, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_risk_stratification_data") } ) @@ -733,8 +936,8 @@ setMethod( export_strata = TRUE, time_range = NULL, export_collection = FALSE, - ...) { - + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -743,14 +946,16 @@ setMethod( .check_argument_length( time_range, var_name = "time_range", - min = 2, - max = 2) + min = 2L, + max = 2L + ) sapply( time_range, .check_number_in_valid_range, var_name = "time_range", - range = c(0, Inf)) + range = c(0.0, Inf) + ) } if (export_strata) { @@ -758,14 +963,16 @@ setMethod( strata_data <- lapply( object@km_data, .compute_risk_stratification_curves, - time_range = time_range) + time_range = time_range + ) # Determine hazard ratio and logrank tests. We do this here because the # data needs to be aggregated. test_data <- lapply( object@km_data, .compute_risk_stratification_tests, - time_range = time_range) + time_range = time_range + ) # Export raw data. raw_data <- .export( @@ -774,7 +981,8 @@ setMethod( dir_path = dir_path, aggregate_results = TRUE, type = "stratification", - subtype = "data") + subtype = "data" + ) # Export strata. strata_data <- .export( @@ -783,7 +991,8 @@ setMethod( dir_path = dir_path, aggregate_results = TRUE, type = "stratification", - subtype = "strata") + subtype = "strata" + ) # Export logrank data. logrank_data <- .export( @@ -793,7 +1002,8 @@ setMethod( aggregate_results = TRUE, object_class = "familiarDataElementRiskLogrank", type = "stratification", - subtype = "logrank") + subtype = "logrank" + ) # Export hazard ratio data. hazard_ratio_data <- .export( @@ -803,18 +1013,21 @@ setMethod( aggregate_results = TRUE, object_class = "familiarDataElementRiskHazardRatio", type = "stratification", - subtype = "hazard_ratio") + subtype = "hazard_ratio" + ) data_list <- list( "data" = raw_data, "strata" = strata_data, "logrank" = logrank_data, - "hazard_ratio_data" = hazard_ratio_data) + "hazard_ratio_data" = hazard_ratio_data + ) if (export_collection) { data_list <- c( data_list, - list("collection" = object)) + list("collection" = object) + ) } return(data_list) @@ -827,7 +1040,8 @@ setMethod( aggregate_results = TRUE, type = "stratification", subtype = "data", - export_collection = export_collection)) + export_collection = export_collection + )) } } ) @@ -846,7 +1060,8 @@ setMethod( export_strata = TRUE, time_range = NULL, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -854,8 +1069,11 @@ setMethod( args = c( list( "object" = object, - "data_element" = "risk_stratification_data"), - list(...))) + "data_element" = "risk_stratification_data" + ), + list(...) + ) + ) return(do.call( export_risk_stratification_data, @@ -864,7 +1082,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "export_strata" = export_strata, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationRiskStratificationInfo.R b/R/FamiliarDataComputationRiskStratificationInfo.R index dd845a4d..892e8a29 100644 --- a/R/FamiliarDataComputationRiskStratificationInfo.R +++ b/R/FamiliarDataComputationRiskStratificationInfo.R @@ -7,7 +7,8 @@ NULL setClass( "familiarDataElementRiskStratificationInfo", contains = "familiarDataElement", - prototype = methods::prototype(estimation_type = "point")) + prototype = methods::prototype(estimation_type = "point") +) # extract_risk_stratification_info (generic) ----------------------------------- @@ -15,7 +16,7 @@ setClass( #' #'@description Collects risk stratification information. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list of familiarDataElements with risk stratification information. #'@md @@ -27,7 +28,8 @@ setGeneric( detail_level = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_risk_stratification_info") } ) @@ -42,27 +44,32 @@ setMethod( object, detail_level = waiver(), message_indent = 0L, - verbose = FALSE) { + verbose = FALSE + ) { - # Test if the outcome type is survival. Other outcome types do not + # Test if the outcome type is survival. Other outcome types do not have risk + # stratification data associated with them. if (!object@outcome_type %in% c("survival")) return(NULL) # Message extraction start logger_message( paste0("Extracting stratification information."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Check the level detail. detail_level <- .parse_detail_level( x = detail_level, object = object, default = "hybrid", - data_element = "risk_stratification_info") + data_element = "risk_stratification_info" + ) proto_data_element <- methods::new( "familiarDataElementRiskStratificationInfo", - detail_level = detail_level) + detail_level = detail_level + ) # Generate elements to send to dispatch. stratification_info <- extract_dispatcher( @@ -73,7 +80,8 @@ setMethod( proto_data_element = proto_data_element, aggregate_results = FALSE, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(stratification_info) } @@ -81,11 +89,24 @@ setMethod( +# extract_risk_stratification_info (prediction table) -------------------------- +setMethod( + "extract_risk_stratification_info", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("risk stratification info") + + return(NULL) + } +) + + + .extract_risk_stratification_info <- function( object, proto_data_element, - ...) { - + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -104,15 +125,15 @@ setMethod( data <- data.table::data.table( "stratification_method" = x$method, "cutoff" = x$cutoff, - "group_id" = seq_len(length(x$cutoff))) + "group_id" = seq_len(length(x$cutoff)) + ) return(data) - }) + } + ) # Combine to single list data <- data.table::rbindlist(data, use.names = TRUE) - - # Check that any data is available.. if (is_empty(data)) return(NULL) } else { @@ -120,14 +141,14 @@ setMethod( risk_stratification_data <- extract_risk_stratification_info( object = object, detail_level = "hybrid", - verbose = FALSE) + verbose = FALSE + ) risk_stratification_data <- .compute_data_element_estimates(risk_stratification_data) - if (is_empty(risk_stratification_data)) return(NULL) # Extract data. - data <- risk_stratification_data[[1]]@data + data <- risk_stratification_data[[1L]]@data } # Attach data to the corresponding attribute. @@ -199,7 +220,8 @@ setGeneric( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_risk_stratification_info") } ) @@ -217,7 +239,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -228,7 +251,8 @@ setMethod( dir_path = dir_path, aggregate_results = aggregate_results, type = "stratification", - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -245,7 +269,8 @@ setMethod( dir_path = NULL, aggregate_results = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -253,8 +278,11 @@ setMethod( args = c( list( "object" = object, - "data_element" = "risk_stratification_info"), - list(...))) + "data_element" = "risk_stratification_info" + ), + list(...) + ) + ) return(do.call( export_risk_stratification_info, @@ -263,7 +291,10 @@ setMethod( "object" = object, "dir_path" = dir_path, "aggregate_resuls" = aggregate_results, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataComputationSHAP.R b/R/FamiliarDataComputationSHAP.R new file mode 100644 index 00000000..c1508fcd --- /dev/null +++ b/R/FamiliarDataComputationSHAP.R @@ -0,0 +1,2114 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# familiarDataElementSHAP object ----------------------------------------------- +setClass( + "familiarDataElementSHAP", + contains = "familiarDataElement", + slots = list( + "sample_identifiers" = "ANY", + "data_mapping" = "ANY", + "predicted_values" = "ANY", + "lookup_table" = "ANY" + ), + prototype = methods::prototype( + detail_level = "ensemble", + estimation_type = "point", + value_column = "shap_value", + grouping_column = c("feature_name", "feature_value_mapping", "sample_id", "phi_0"), + sample_identifiers = NULL, + data_mapping = NULL, + predicted_values = NULL, + lookup_table = NULL + ) +) + + +# familiarDataElementSHAPSummary object ---------------------------------------- + +# Objects for creating SHAP summary plots. These are created at run-time from +# data included in familiarDataElementSHAP objects. +setClass( + "familiarDataElementSHAPSummary", + contains = "familiarDataElement" +) + + +# familiarDataElementSHAPForce object ------------------------------------------ + +# Objects for creating SHAP force plots. These are created at run-time from +# data included in familiarDataElementSHAP objects. +setClass( + "familiarDataElementSHAPForce", + contains = "familiarDataElement" +) + + +# familiarDataElementSHAPDependence object ------------------------------------- + +# Objects for creating SHAP dependence plots. These are created at run-time from +# data included in familiarDataElementSHAP objects. +setClass( + "familiarDataElementSHAPDependence", + contains = "familiarDataElement" +) + + + + +# extract_shap (generic) ------------------------------------------------------- + +#'@title Internal function for computing SHAP values. +#' +#'@description Computes SHAP values for feature values using a +#' `familiarEnsemble`. +#' +#'@param features Features for whose values SHAP values need to be computed. +#' defaults to all features in the model. +#'@param n_sample_points Minimum number of values to sample for numeric +#' features. By default, this is based on input dataset. But if the number of +#' values of a feature within that dataset is too low, additional values are +#' drawn from the feature distribution (stored with the model). +#'@param shap_tolerance Relative tolerance for convergence of SHAP values. The +#' tolerance is scaled with the range in SHAP values. Default: 0.05. +#'@param shap_max_iterations Maximum iterations for convergence of SHAP values. +#' Default: 1000 +#'@param shap_phi_0 Reference predicted value(s). Determined from data by +#' default. +#' +#'@inheritParams .extract_data +#' +#'@return A list of familiarDataElements with SHAP values. +#'@md +#'@keywords internal +setGeneric( + "extract_shap", + function( + object, + data, + cl = NULL, + features = NULL, + n_sample_points = 20L, + shap_tolerance = waiver(), + shap_max_iterations = waiver(), + shap_phi_0 = waiver(), + ensemble_method = waiver(), + evaluation_times = waiver(), + sample_limit = waiver(), + detail_level = waiver(), + aggregate_results = waiver(), + n_important_features = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE, + ... + ) { + standardGeneric("extract_shap") + } +) + + + +# extract_shap (familiarEnsemble) ---------------------------------------------- +setMethod( + "extract_shap", + signature(object = "familiarEnsemble"), + function( + object, + data, + cl = NULL, + features = NULL, + n_sample_points = 20L, + shap_tolerance = waiver(), + shap_max_iterations = waiver(), + shap_phi_0 = NULL, + ensemble_method = waiver(), + evaluation_times = waiver(), + sample_limit = waiver(), + detail_level = waiver(), + aggregate_results = waiver(), + n_important_features = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE, + ... + ) { + # Compute SHAP values. + + # Message extraction start + logger_message( + paste0("Extracting SHAP values for the ensemble."), + indent = message_indent, + verbose = verbose + ) + + if (is.null(features)) { + logger_message( + paste0( + "Computing SHAP values for features in the dataset." + ), + indent = message_indent + 1L, + verbose = verbose + ) + + } else { + logger_message( + paste0( + "Computing SHAP values for selected features: ", paste_s(features), "." + ), + indent = message_indent + 1L, + verbose = verbose + ) + } + + # Load evaluation_times from the object settings attribute, if it is not provided. + if (is.waive(evaluation_times)) evaluation_times <- object@settings$eval_times + + # Check evaluation_times argument + if (object@outcome_type %in% c("survival")) { + sapply( + evaluation_times, + .check_number_in_valid_range, + var_name = "evaluation_times", + range = c(0.0, Inf), + closed = c(FALSE, TRUE) + ) + } + + # Check n_sample_points argument. This defines the maximum number of feature + # values for which SHAP values are computed. + .check_number_in_valid_range( + x = n_sample_points, + var_name = "n_sample_points", + range = c(2L, Inf), + closed = c(TRUE, TRUE) + ) + + # Check shap_tolerance argument. This sets stopping criteria for convergence + # of SHAP values. + if (is.waive(shap_tolerance)) shap_tolerance <- object@settings$shap_tolerance + + .check_number_in_valid_range( + x = shap_tolerance, + var_name = "shap_tolerance", + range = c(0.0, Inf), + closed = c(FALSE, FALSE) + ) + + # Check shap_max_iterations argument. This sets the maximum number of + # iterations for computing SHAP values. + if (is.waive(shap_max_iterations)) shap_max_iterations <- object@settings$shap_max_iterations + + .check_number_in_valid_range( + x = shap_max_iterations, + var_name = "shap_max_iterations", + range = c(1L, Inf), + closed = c(TRUE, TRUE) + ) + + # Check shap_phi_0. + if (is.waive(shap_phi_0)) shap_phi_0 <- object@settings$shap_phi_0 + + if (!is.null(shap_phi_0)) { + if (object@outcome_type == "survival") { + .check_argument_length( + x = shap_phi_0, + var_name = "shap_phi_0", + min = length(evaluation_times), + max = length(evaluation_times) + ) + + .check_is_numeric( + x = shap_phi_0, + var_name = "shap_phi_0" + ) + + } else if (object@outcome_type == "multinomial") { + .check_argument_length( + x = shap_phi_0, + var_name = "shap_phi_0", + min = length(get_outcome_class_levels(object)), + max = length(get_outcome_class_levels(object)) + ) + + .check_is_numeric( + x = shap_phi_0, + var_name = "shap_phi_0" + ) + + } else { + .check_is_numeric( + x = shap_phi_0, + var_name = "shap_phi_0" + ) + } + } + + # Obtain ensemble method from stored settings, if required. + if (is.waive(ensemble_method)) ensemble_method <- object@settings$ensemble_method + + # Check ensemble_method argument + .check_parameter_value_is_valid( + x = ensemble_method, + var_name = "ensemble_method", + values = .get_available_ensemble_prediction_methods() + ) + + # Check the sample limit. This defines the subset of samples that are being + # assessed (if real data is used instead of a minimum subset). + sample_limit <- .parse_sample_limit( + x = sample_limit, + object = object, + default = 200L, + data_element = "shap" + ) + + # Check the level detail. + detail_level <- .parse_detail_level( + x = detail_level, + object = object, + default = "ensemble", + data_element = "shap" + ) + + # Check whether results should be aggregated. + aggregate_results <- .parse_aggregate_results( + x = aggregate_results, + object = object, + default = FALSE, + data_element = "shap" + ) + + # Test if models are properly loaded + if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() + + # Test if any model in the ensemble was successfully trained. + if (!model_is_trained(object = object)) return(NULL) + + # Check the number of important features. + n_important_features <- .parse_n_important_features( + x = n_important_features, + object = object, + default = 20, + data_element = "shap" + ) + + # Set features to be assessed using SHAP. + important_features <- .select_important_features( + object = object, + data = data, + n_important_features = n_important_features + ) + + # Get and process the input data. Since we define SHAP values using the + # features in their original scales, we need to apply only minimal + # pre-processing. + data <- process_input_data( + object = object, + data = data, + stop_at = "signature" + ) + + # Use sample limit to cap the number of samples that are assessed. + data <- get_subsample( + data = data, + size = sample_limit, + seed = 0L + ) + + # Generate a prototype data element. + proto_data_element <- new( + "familiarDataElementSHAP", + detail_level = detail_level + ) + + # Generate elements to send to dispatch. + shap_data <- extract_dispatcher( + FUN = .extract_shap, + has_internal_bootstrap = FALSE, + cl = cl, + object = object, + data = data, + features = features, + n_sample_points = n_sample_points, + tolerance = shap_tolerance, + n_max_iter = shap_max_iterations, + phi_0 = shap_phi_0, + proto_data_element = proto_data_element, + important_features = important_features, + is_pre_processed = is_pre_processed, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + aggregate_results = aggregate_results, + message_indent = message_indent + 1L, + verbose = verbose + ) + } +) + + + +# extract_shap (prediction table) ---------------------------------------------- +setMethod( + "extract_shap", + signature(object = "familiarDataElementSHAP"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("SHAP values") + + return(NULL) + } +) + + + +.extract_shap <- function( + object, + data = NULL, + proto_data_element, + important_features, + evaluation_times = NULL, + features = NULL, + n_sample_points, + aggregate_results, + is_pre_processed = FALSE, + ensemble_method, + cl, + tolerance = 0.005, + n_max_iter = 1000L, + phi_0 = NULL, + mapping_method = "fixed", + sampling_method = "importance", + message_indent = 0L, + verbose = FALSE, + progress_bar = FALSE, + ... +) { + # Step 1: Determine feature values that are to be sampled for determining SHAP + # values. + # + # Step 2: Determine the minimum sampleset X required to determine SHAP values. + # The number of samples (n) is equal to the feature with the largest number of + # values (m_i) to sample. Feature values can be randomly ordered for each + # feature. Features with m_i < n can randomly draw additional features. + # + # Alternative: Use the actual dataset X (trigger on function argument). + # + # Step 3: Create coalition sets for coalitions with all but one off and all but + # one on. + # + # Step 4: Iterate samples in sampleset X. Generate samples corresponding to + # coalitions for each sample. Concatenate generated samples and add to table + # with previously generated samples X_gen. + # + # Step 5: Select samples without existing predictions. + # + # Step 6: Predict samples. Merge new predictions into existing predictions. + # + # Step 7: Compute average predicted value (phi_0). + # + # Step 8: For each sample in sampleset X, determine coalition represented by + # each sample in X_gen. Compute kernel weight based on coalition. Compute SHAP + # values by solving linear equation. + # + # Step 9: Average SHAP value for each feature value. + # + # Step 10: Determine convergence and repeat steps 4-9 until convergence is + # reached, or capacity is exhausted. + # + # Parallel processing: perform steps 4-6 multiple times within a parallel loop. + # This allows for faster convergence. + + shap_value <- NULL + + # Check that the model requires any features. + if (is_empty(important_features)) return(NULL) + + # Get set of feature values. + feature_set <- .get_shap_feature_set( + data = data, + features = object@model_features, + feature_info = object@feature_info[object@model_features], + n_sample_points = n_sample_points + ) + + # Generate data if absent. + if (is_empty(data)) { + data <- .get_shap_sample_set( + object = object, + feature_set = feature_set + ) + } + + # Ensure that data is unique. + data <- select_unique_data(data = data) + + # Get sample identifiers. + sample_identifiers <- get_unique_row_names(data) + + # From here, work with mapping representations of the data (h). + mapping_input <- .shap_data_to_mapping( + data = data, + feature_set = feature_set + ) + + # Predict outcome values from the input data. Output may be more than one + # column. + predicted_values_input <- .predict_from_coalition( + mapping = mapping_input, + feature_set = feature_set, + object = object, + ensemble_method = ensemble_method, + evaluation_time = evaluation_times + ) + + if (is_empty(predicted_values_input)) return(NULL) + + # Compute phi_0. + if (is.null(phi_0)) phi_0 <- colMeans(predicted_values_input) + + if (length(important_features) == 1L) { + # Single feature (shapley) ------------------------------------------------- + shap_values <- .compute_shap_value_single_feature( + important_features = important_features, + mapping = mapping_input, + sample_id = sample_identifiers, + feature_set = feature_set, + predicted_values = predicted_values_input, + phi_0 = phi_0 + ) + + } else { + # Multiple features (kernel) ----------------------------------------------- + + # Generate coalitions (Z) + input_coalitions <- .get_shap_coalitions( + important_features = important_features, + depth = 1L + ) + + # Check that coalitions are not empty: this happens if the data contains a + # single feature: SHAP values cannot be computed. + if (is.null(input_coalitions)) return(NULL) + + # Provide the initial set of coalitions. + coalitions <- list(input_coalitions) + + # Compute weights for each coalition in a coalition set. + kernel_weights <- .compute_shap_kernel_weights( + n = ncol(input_coalitions), + individual_coalition = TRUE + ) + + # Looping variables. + iter_id <- 0L + all_shap_converged <- FALSE + shap_values <- NULL + shap_matrices <- NULL + n_parallel <- max(c(length(cl), 1L)) + + while (!all_shap_converged && iter_id < n_max_iter) { + # Determine the iteration identifiers. + current_ids <- iter_id + seq_len(n_parallel) + + # Distribute computation. + shap_values_iter <- fam_lapply( + cl = cl, + X = current_ids, + FUN = .compute_shap_iterative, + object = object, + ensemble_method = ensemble_method, + evaluation_times = evaluation_times, + mapping_input = mapping_input, + sample_identifiers = sample_identifiers, + sample_predictions = predicted_values_input, + important_features = important_features, + phi_0 = phi_0, + coalitions = coalitions, + kernel_weights = kernel_weights, + feature_set = feature_set, + mapping_method = mapping_method + ) + + # Combine with previous shap_values. + shap_values <- data.table::rbindlist(c(list(shap_values), shap_values_iter)) + + # Compute variance of each SHAP value. + shap_variance <- shap_values[ + , + list("shap_var" = stats::var(shap_value), "n" = .N), + by = c("sample_id", "feature_name", "feature_value_mapping", "shap_outcome") + ] + + # Check convergence. + all_shap_converged <- .evaluate_shap_convergence( + shap_variance = shap_variance, + tolerance = max(c( + tolerance * diff(range(shap_values$shap_value)), + tolerance * diff(range(c(predicted_values_input))) / sqrt(length(feature_set)) + )) + ) + + # Update coalitions. + coalitions <- .sample_shap_coalitions( + coalitions = input_coalitions, + kernel_weights = kernel_weights, + shap_variance = shap_variance, + sampling_method = sampling_method, + seed = 19L + iter_id + ) + + # Update iteration id. + iter_id <- tail(current_ids, n = 1L) + } + } + + # Compute final SHAP values. + shap_values <- shap_values[ + , + list("shap_value" = mean(shap_value)), + by = c("sample_id", "feature_name", "feature_value_mapping", "shap_outcome") + ] + + # Add model name to data element. + proto_data_element <- add_model_name( + proto_data_element, + object = object + ) + + # Store data mapping of feature values for input data. + proto_data_element@data_mapping <- mapping_input + + # Store lookup-table translate feature mapping back to feature values. + proto_data_element@lookup_table <- feature_set + + # Add predictions for input data. + proto_data_element@predicted_values <- predicted_values_input + + # Add sample identifiers. + proto_data_element@sample_identifiers <- sample_identifiers + + # Store shap data. Value column is "shap_value", grouping columns are + # "feature_name" and "feature_value_mapping". For multinomial and survival + # outcomes, "shap_outcome" is an additional grouping column. + if (object@outcome_type %in% c("multinomial", "survival")) { + # Add phi_0 + if (object@outcome_type == "survival") { + phi_0_data <- data.table::data.table( + "shap_outcome" = as.character(evaluation_times), + "phi_0" = phi_0 + ) + + } else if (object@outcome_type == "multinomial") { + phi_0_data <- data.table::data.table( + "shap_outcome" = get_outcome_class_levels(object), + "phi_0" = phi_0 + ) + } + + shap_values <- merge( + x = shap_values, + y = phi_0_data, + by = "shap_outcome" + ) + + proto_data_element@data <- data.table::copy( + shap_values[, mget(c("feature_name", "feature_value_mapping", "shap_outcome", "shap_value", "phi_0", "sample_id"))] + ) + + # Add shap_outcome as additional grouping level. + proto_data_element@grouping_column <- c(proto_data_element@grouping_column, "shap_outcome") + + if (object@outcome_type %in% c("multinomial")) { + # Convert shap_outcome to categorical values corresponding to the levels + # in the modelled endpoint. + proto_data_element@data$shap_outcome <- factor( + proto_data_element@data$shap_outcome, + levels = get_outcome_class_levels(object) + ) + + } else if (object@outcome_type == "survival") { + # Convert shap_outcome to categorical values corresponding to the + # evaluation time + proto_data_element@data$shap_outcome <- factor( + proto_data_element@data$shap_outcome, + levels = as.character(evaluation_times) + ) + } + + } else { + # Add phi_0. + shap_values[, "phi_0" := phi_0] + + proto_data_element@data <- data.table::copy( + shap_values[, mget(c("feature_name", "feature_value_mapping", "shap_value", "phi_0", "sample_id"))] + ) + } + + return(proto_data_element) +} + + + +.compute_shap_iterative <- function( + iter_id, + object, + ensemble_method, + evaluation_times, + mapping_input, + important_features, + sample_identifiers, + sample_predictions, + phi_0, + coalitions, + kernel_weights, + feature_set, + mapping_method +) { + # Determine additional mapping. + mapping_iter <- .shap_randomise_mapping_from_coalition( + important_features = important_features, + samples = mapping_input, + coalitions = coalitions, + feature_set = feature_set, + seed = iter_id, + mapping_method = mapping_method + ) + + # Predict from new unique mappings. + predicted_values_iter <- .predict_from_coalition( + mapping = mapping_iter, + feature_set = feature_set, + object = object, + ensemble_method = ensemble_method, + evaluation_time = evaluation_times + ) + + if (is.null(predicted_values_iter)) return(NULL) + + # Compute and update A and b matrices. + shap_matrices <- .compute_shap_matrices( + important_features = important_features, + samples = mapping_input, + sample_predictions = sample_predictions, + sample_id = sample_identifiers, + mapping = mapping_iter, + predicted_values = predicted_values_iter, + phi_0 = phi_0, + kernel_weights = kernel_weights + ) + + # Compute SHAP values for this iteration. + shap_values <- .compute_shap_value( + shap_matrices = shap_matrices + ) + + if (is.null(shap_values)) return(NULL) + + return(shap_values) +} + + + +.get_shap_feature_set <- function( + data = NULL, + features, + feature_info, + n_sample_points +) { + # Gets set of feature values for the features of interest. For categorical + # features, all levels are used. For numerical features, the data is sampled + # (if available), and additional values are drawn based on the known + # distribution of feature values for each feature. + feature_set <- list() + for (feature in features) { + # For categorical features, use all levels. + if (feature_info[[feature]]@feature_type == "factor") { + feature_set[[feature]] <- factor(feature_info[[feature]]@levels, levels = feature_info[[feature]]@levels) + next + } + + # Select (numeric) feature values from the data. + feature_values <- NULL + if (!is_empty(data)) { + feature_values <- unique_na(data@data[[feature]]) + } + + # Check number of values to sample. + n_to_sample <- n_sample_points - length(feature_values) + if (n_to_sample <= 0L) { + feature_set[[feature]] <- feature_values + next + } + + # Add feature values by sampling distribution. + feature_set[[feature]] <- unique(c( + feature_values, + stats::spline( + x = (seq_along(feature_info[[feature]]@distribution$pctl) - 1L) / + (length(feature_info[[feature]]@distribution$pctl) - 1L), + y = as.numeric(feature_info[[feature]]@distribution$pctl), + xout = get_percentiles(n_to_sample), + method = "hyman" + )$y + )) + } + + return(feature_set) +} + + + +.get_shap_sample_set <- function( + object, + feature_set +) { + # Determine the number of samples that are required. + n_samples <- max(lengths(feature_set)) + + # Fill sample set. Feature values are randomly ordered and then distributed + # over features. + sample_set <- list() + for (ii in seq_along(feature_set)) { + feature <- names(feature_set)[ii] + feature_values <- feature_set[[feature]] + feature_values <- feature_values[fam_sample( + seq_along(feature_values), + n = length(feature_values), + replace = FALSE, + seed = ii + )] + sample_set[[feature]] <- rep_len(feature_values, length.out = n_samples) + } + + # Convert to data.table and batch and sample identifiers. + data <- data.table::as.data.table(sample_set) + data[, ":="( + "batch_id" = "generated", + "sample_id" = seq_len(nrow(data)) + )] + + return(as_data_object( + data = data, + object = object, + batch_id_column = "batch_id", + sample_id_column = "sample_id", + check_stringency = "external" + )) +} + + + +.get_shap_coalitions <- function( + important_features, + depth = 1L +) { + # Get initial set of coalitions. Antithetic coalitions are created within + # ...shap_randomise_mapping_from_coalition + + # Helper function that inserts TRUE at the indices indicated by ones. + ..fun <- function(ones, n_features) { + x <- logical(n_features) + x[ones] <- TRUE + return(x) + } + + # Set number of features. + n_features <- length(important_features) + + # Check that depth is at most n_features - 1L. + if (depth >= n_features) depth <- n_features - 1L + if (depth < 1L) return(NULL) + + z <- list() + for (ii in seq_len(depth)) { + z <- c( + z, + utils::combn( + n_features, + m = ii, + FUN = ..fun, + simplify = FALSE, + n_features = n_features + ) + ) + } + + # To matrix. Data are stored row-wise. + z <- matrix(unlist(z), ncol = n_features, byrow = TRUE) + colnames(z) <- important_features + + return(z) +} + + + +.sample_shap_coalitions <- function( + coalitions, + kernel_weights, + shap_variance, + sampling_method, + seed +) { + shap_var <- coalition_id <- NULL + if (sampling_method == "fixed") { + sampled_coalitions <- list(coalitions) + + } else if (sampling_method == "importance") { + # Probabilistic selection of coalitions. This is very much similar to + # importance sampling in MCMC. The central concept is that SHAP values for + # some features are more difficult to determine than those of others. The + # more difficult features will have a larger overall variance. Therefore we + # want to focus more on coalitions where these features are present. + + # Check if shap_variance contains useful info. Particularly, it cannot be + # empty, or contain NA or inf values. In that case, just return the fixed + # coalitions + if (is_empty(shap_variance)) return(list(coalitions)) + if (any(!is.finite(shap_variance$shap_var))) return(list(coalitions)) + + # Determine the cost of each input coalition, normalised by their total + # cost. We want to sample coalitions until the budget (1.0) is exceeded. + # This is the same budget available to the input coalition. The cost is + # equal to the corresponding kernel weight for the individual coalition. + + coalition_size <- rowSums(coalitions) + coalition_cost <- kernel_weights[coalition_size + 1L] + coalition_cost <- coalition_cost / sum(coalition_cost) + + # The selection probability for each individual coalition is the variance(s) + # of the on-feature(s) times the kernel weight, normalised by the total + # probability over all input coalitions. + shap_variance <- shap_variance[, list("feature_shap_var" = sum(shap_var)), by = "feature_name"] + + # Ensure that feature shap variance and the respective features in the + # coalition matrix are ordered the same way. + feature_shap_variance <- shap_variance$feature_shap_var + names(feature_shap_variance) <- shap_variance$feature_name + feature_shap_variance <- feature_shap_variance[colnames(coalitions)] + + # Compute selection likelihood. + coalition_probability <- colSums(t(coalitions * kernel_weights[coalition_size + 1L]) * feature_shap_variance) + coalition_probability <- coalition_probability / sum(coalition_probability) + + # Draw 1 / min(coalition_cost) coalitions with resampling, and use these up to + # and including the coalition where the budget is exceeded. + n_to_sample <- ceiling(1.0 / min(coalition_cost)) + u_sampled <- fam_runif(n = n_to_sample, seed = seed) + + selected_coalition <- sapply( + u_sampled, + function(x, u) (which.min(u < x)), + u = cumsum(coalition_probability) + ) + + selected_coalition <- head( + selected_coalition, + n = which.min(cumsum(coalition_cost[selected_coalition]) < 1.0) + ) + + # Form subsets of coalitions so that each individual coalition only appears + # once in its bag. This is important so that a different sample will be drawn + # when the fixed mapping method in ...shap_randomise_mapping_from_coalition is + # used. + coalition_table <- data.table::data.table("coalition_id" = selected_coalition) + coalition_table[, "bag_id" := data.table::rowid(coalition_id)] + + sampled_coalitions <- lapply( + split(coalition_table, by = "bag_id"), + function(x, coalitions){ + coalitions[x$coalition_id, , drop = FALSE] + }, + coalitions = coalitions + ) + + # Note that antithetic sampling is done later in + # ...shap_randomise_mapping_from_coalition. + + } else { + ..error_reached_unreachable_code(paste0("unknown sampling_method: ", sampling_method)) + } + + return(sampled_coalitions) +} + + + +.shap_data_to_mapping <- function( + data, + feature_set +) { + # Convert data to mapping matrix. This uses the fact that all the values in + # the feature set + mapping <- list() + + # Maps data to a matrix of integers that establishes a mapping to the feature + # values in feature set. + for (feature in names(feature_set)) { + mapping[[feature]] <- match(data@data[[feature]], feature_set[[feature]]) + } + + # Create matrix. + h <- matrix(unlist(mapping), ncol = length(feature_set)) + colnames(h) <- names(feature_set) + + return(h) +} + + + +.shap_mapping_to_data <- function( + mapping, + feature_set, + object +) { + ..fun <- function(feature, y, x) { + # Use column in mapping matrix x to lookup value from y. + return(y[x[, feature]]) + } + + # Use lookup to fill data. + data <- mapply( + ..fun, + feature = names(feature_set), + y = feature_set, + MoreArgs = list("x" = mapping), + SIMPLIFY = FALSE + ) + + # Set names of list elements. + names(data) <- names(feature_set) + + # Convert to data.table and add identifiers. + data <- data.table::as.data.table(data) + + data <- as_data_object( + data = data, + object = object, + check_stringency = "external" + ) + + # Update pre-processing level from none to signature, because we are strictly + # working with model features here. + data@preprocessing_level <- "signature" + + return(data) +} + + + +.shap_mapping_to_feature_list <- function( + feature, + mapping_value, + lookup_table +) { + y <- lookup_table[[feature[1L]]] + if (is.factor(y)) { + feature_value <- as.numeric(y)[mapping_value] + feature_label <- as.character(y)[mapping_value] + } else { + feature_value <- y[mapping_value] + feature_label <- rep_len(NA_character_, length(mapping_value)) + } + + return(list( + "feature_value" = feature_value, + "feature_label" = feature_label + )) +} + + + +.shap_randomise_mapping_from_coalition <- function( + important_features, + samples, + coalitions, + feature_set, + seed, + n_min_mappings = 300L, + mapping_method = "fixed" +) { + # Determine the number of feature values for each value. + n_feature_values <- lengths(feature_set) + + # Start random stream + rstream_object <- .start_random_number_stream(seed) + + mapping <- list() + n_mappings <- 0L + + # Ensure that sufficient mappings are generated to limit the effect of + # overhead on the computation of SHAP values. + while (n_mappings < n_min_mappings) { + + # Generate random values. + if (mapping_method == "fixed") { + # Generate a random number for each feature and each sample and coalition + # set. + n_random <- nrow(samples) * length(coalitions) * length(important_features) + + } else if (mapping_method == "random") { + # Generate a random number for each feature and each sample and each + # single coalition. Due to antithetic sampling, the number of coalitions + # is doubled. + n_random <- nrow(samples) * 2L * sum(sapply(coalitions, nrow)) * length(important_features) + + } else { + ..error_reached_unreachable_code(paste0("unknown mapping_method: ", mapping_method)) + } + + # Stream random numbers. + x_random <- fam_runif(n = n_random, rstream_object = rstream_object) + + random_mapping <- mapply( + FUN = ..shap_randomise_mapping_from_coalition, + x = asplit(samples, 1L), + x_random = split(x_random, fam_cut(seq_along(x_random), nrow(samples))), + MoreArgs = list( + "coalitions" = coalitions, + "n_feature_values" = n_feature_values, + "mapping_method" = mapping_method + ), + USE.NAMES = FALSE, + SIMPLIFY = FALSE + ) + + mapping <- c(mapping, random_mapping) + n_mappings <- n_mappings + sum(sapply(random_mapping, nrow)) + } + + # Concatenate by rows. + mapping <- do.call(rbind, mapping) + + # Remove duplicates. + mapping <- unique(mapping) + + return(mapping) +} + + + +..shap_randomise_mapping_from_coalition <- function( + x, + x_random, + coalitions, + n_feature_values, + mapping_method +) { + # Split random values. + if (length(coalitions) == 1L) { + x_random <- list(x_random) + + } else { + if (mapping_method == "fixed") { + # Each coalition set requires the same number of random values. + x_random <- split(x_random, fam_cut(seq_along(x_random), length(coalitions))) + + } else if (mapping_method == "random") { + # Due to antithetic sampling, the number of coalitions is doubled. + n_coalitions_in_bag <- 2L * sapply(coalitions, nrow) + x_random <- split( + x_random, + rep(seq_along(coalitions), n_coalitions_in_bag * length(n_feature_values)) + ) + } + } + + # Loop over coalition sets. + mapping <- mapply( + FUN = ...shap_randomise_mapping_from_coalition, + coalitions = coalitions, + x_random = x_random, + MoreArgs = list( + "x" = x, + "n_feature_values" = n_feature_values, + "mapping_method" = mapping_method + ), + USE.NAMES = FALSE, + SIMPLIFY = FALSE + ) + + return(do.call(rbind, mapping)) +} + + + +...shap_randomise_mapping_from_coalition <- function( + coalitions, + x_random, + x, + n_feature_values, + mapping_method +) { + + ..select_shap_feature_mapping <- function( + available_feature_values, + random_values + ) { + # Sample with replacement. + x_indices <- as.integer(ceiling(random_values * length(available_feature_values))) + x_indices[x_indices == 0L] <- 1L + + return(available_feature_values[x_indices]) + } + + # Generate antithetic coalitions from input. + coalitions <- rbind(coalitions, !coalitions) + + # Get important features. + important_features <- colnames(coalitions) + unimportant_features <- setdiff(names(n_feature_values), important_features) + + # The mapping method determines how values are drawn. + # + # - "fixed": a single sample, not_x, that is fully distinct from x is + # randomly drawn. on-features are copied from x, and off-features from + # not_x. + # - "random": off-features are drawn randomly. + + mapping <- list() + if (mapping_method == "fixed") { + for (ii in seq_along(important_features)) { + # Determine eligible features from in-coalition (on) and off-coalition + # (off) features. + feature <- important_features[ii] + on_feature_set <- unname(x[feature]) + off_feature_set <- seq_len(n_feature_values[feature])[-on_feature_set] + + # Sample a single value from the off-feature set, and append to the + # on-feature set. This forms the look-up table for forming coalitions. + feature_set <- c( + on_feature_set, + ..select_shap_feature_mapping( + available_feature_values = off_feature_set, + random_values = x_random[ii] + ) + ) + + # Determine which value from feature_set should be used. Index 1L + # corresponds to the in-coalition feature value, and index 2L to the + # off-coalition feature value. + lookup_vector <- 1L + !coalitions[, feature] + + # Add features to mapping. + mapping[[feature]] <- feature_set[lookup_vector] + } + + for (ii in seq_along(unimportant_features)) { + # Unimportant features are simply repeated without coalition. + feature <- unimportant_features[ii] + mapping[[feature]] <- rep(unname(x[feature]), nrow(coalitions)) + } + + } else if (mapping_method == "random") { + # Determine the number of feature values to samples for off-coalition + # features. This should be the same number for each feature in antithetical + # sampling. + n_to_draw <- colSums(!coalitions) + jj <- 0L + + for (ii in seq_along(important_features)) { + # Determine eligible features from in-coalition (on) and off-coalition + # (off) features. + feature <- important_features[ii] + on_feature_set <- unname(x[feature]) + off_feature_set <- seq_len(n_feature_values[feature])[-on_feature_set] + + # Sample the off-feature set, and append to the on-feature set. This forms + # the look-up table for forming coalitions. + feature_set <- c( + on_feature_set, + ..select_shap_feature_mapping( + available_feature_values = off_feature_set, + random_values = x_random[(1L:n_to_draw[feature]) + jj] + ) + ) + + # Update offset. + jj <- jj + n_to_draw[feature] + + # Accumulate off-coalition elements. E.g. with coalitions (across samples + # for each feature) [0, 1, 1, 0], the lookup-vector is [1, 1, 1, 2]. + lookup_vector <- cumsum(!coalitions[, feature]) + + # Reset in-coalition elements of the lookup vector, yielding, e.g. [1, 0, 0, + # 2], and increment by 1. This results in indices (e.g. [2, 1, 1, 3]) + # referring to the feature set, with index 1 corresponding to the + # in-coalition value. + lookup_vector <- 1L + lookup_vector * !coalitions[, feature] + + # Add features to mapping. + mapping[[feature]] <- feature_set[lookup_vector] + } + + for (ii in seq_along(unimportant_features)) { + # Unimportant features are simply repeated without coalition. + feature <- unimportant_features[ii] + mapping[[feature]] <- rep(unname(x[feature]), nrow(coalitions)) + } + + } else { + ..error_reached_unreachable_code(paste0("unknown mapping_method: ", mapping_method)) + } + + # Convert to matrix. Mapping consists of columns (that are first ordered + # correctly before being flattened), and the matrix is then filled by column. + mapping <- matrix( + unlist(mapping[names(n_feature_values)]), + ncol = length(n_feature_values) + ) + colnames(mapping) <- names(n_feature_values) + + return(mapping) +} + + + +.compute_shap_kernel_weights <- function(n, individual_coalition = FALSE) { + # Form a lookup-table for kernel weights. + n_present <- seq_len(n + 1L) - 1L + n_permutations <- choose(n, n_present) + kernel_weights <- (n - 1.0) / (n_permutations * n_present * (n - n_present)) + kernel_weights[!is.finite(kernel_weights)] <- 0.0 + + # Normalise kernel-weights to 1. + kernel_weights <- kernel_weights / sum(kernel_weights) + + if (individual_coalition) { + # Determine weights for individual unique coalitions. + kernel_weights <- kernel_weights / n_permutations + } + + return(kernel_weights) +} + + + +.compute_shap_matrices <- function( + important_features, + samples, + sample_predictions, + sample_id, + mapping, + predicted_values, + phi_0, + kernel_weights +) { + # Replace NA in samples and mapping. + samples[is.na(samples)] <- 0L + mapping[is.na(mapping)] <- 0L + + # Select only important features. + samples <- samples[, important_features, drop = FALSE] + mapping <- mapping[, important_features, drop = FALSE] + + # Compute A and b matrices for each sample. + new_matrices <- mapply( + ..compute_shap_matrices, + x = asplit(samples, MARGIN = 1L), + v_0 = asplit(sample_predictions, MARGIN = 1L), + sample_id = sample_id, + MoreArgs = list( + "kernel_weights" = kernel_weights, + "mapping" = mapping, + "predicted_values" = predicted_values, + "phi_0" = phi_0 + ), + SIMPLIFY = FALSE, + USE.NAMES = FALSE + ) + + return(new_matrices) + + # Update full matrix. THIS IS CURRENTLY NOT USED. + # We follow the recipe by Covert and Lee (2021), which means that we update + # the A and b matrices each iteration. + # if (is.null(matrices)) { + # matrices <- new_matrices + # names(matrices) <- sample_id + # matrices <- lapply( + # matrices, + # function(x) { + # x$n_iter <- 1L + # return(x) + # } + # ) + # + # } else { + # matrices <- mapply( + # FUN = .update_shap_matrices, + # old = matrices, + # new = new_matrices, + # SIMPLIFY = FALSE, + # USE.NAMES = FALSE + # ) + # } + + # Return both the full and temporary matrices. +} + + + +..compute_shap_matrices <- function( + x, + v_0, + sample_id, + kernel_weights, + mapping, + predicted_values, + phi_0 +) { + # Prevent notes due to data.table. + weight <- NULL + + # x is the mapping corresponding to the sample. First we determine the + # coalitions pertaining to current sample. Since `==` is operating by column, + # we can simply transpose the mapping matrix so that rows become columns. Then + # the comparison is performed on the columns representing each row, and the + # result is transposed again. + coalitions <- t(t(mapping) == c(x)) + + # Compute the number of features "present" in each coalition. + n_coalition_size <- rowSums(coalitions) + weights <- kernel_weights[n_coalition_size + 1L] + non_zero_weights <- weights > 0.0 + + # Check for empty weights. + if (!any(non_zero_weights)) return(NULL) + + # Weighted least squares solves for coefficients beta as follows: + # beta = (t(X) W X)^-1 t(X)W y + # In the context of kernelSHAP, this means: + # beta = phi + # X = Z (coalitions), + # W = diag(pi) (kernel_weights) + # and y = f(h(z)) - phi_0 + X <- coalitions[non_zero_weights, , drop = FALSE] + + # This ensures that phi_0 is subtracted row-wise. + y <- t(t(predicted_values[non_zero_weights, , drop = FALSE] - phi_0)) + + # kernelSHAP originally was defined by sampling coalitions, with each + # coalition drawn probabilistically according to the SHAP kernel weights. This + # means that the appearance of coalitions would stochastically mirror their + # probabilities. Here we have a fixed set of coalitions, and coalitions that + # are randomly formed from the entire set of decisions that should be + # explained (and their fixed coalitions). This means that our coalitions are + # not distributed as expected, and cannot be used without updating the + # weights. + + # First determine how often individual coalitions appear. This is currently + # the most expensive part of this function. I thought of solutions to speed up + # the process, other than data.table::frank. Hashing each row using + # rlang::hash or paste0 is several times slower. Using a filter technique + # where we count which individual coalitions are present is not scalable for + # large feature sets due to large number of permutations of coalitions. Even + # though that solution could be quite fast when few features are present (and + # thus a non-sparse coalition set is present in `coalitions`), the likely + # gains will be minimal. Another alternative is to encode coalitions as a sum + # of positional powers of 2 ( feature 1: TRUE / FALSE * 2^0; feature 2: TRUE / + # FALSE 2^1; etc.), but that would still be problematic with large numbers of + # features due to integer bit precision. + coalition_id <- data.table::frank(data.table::as.data.table(X), ties.method = "dense") + n_coalition_instances <- integer(length(coalition_id)) + for (ii in seq_len(max(coalition_id))) { + instance_in_coalition <- coalition_id == ii + n_coalition_instances[instance_in_coalition] <- sum(instance_in_coalition) + } + + # Then re-weight probability of individual coalitions, and normalise. + w <- weights[non_zero_weights] + w <- w / n_coalition_instances + w <- w / sum(w) + + # Instead of computing a diagonal matrix, we rely on equivalent element-wise + # multiplications (which are considerably cheaper). + return(list( + "A" = t(X) %*% (X * w), + "b" = t(X) %*% (y * w), + "v_0" = as.numeric(v_0), + "phi_0" = phi_0, + "sample_id" = sample_id, + "sample_mapping" = x + )) +} + + + +.update_shap_matrices <- function( + old, + new +) { + old$A <- old$A + new$A + old$b <- old$b + new$b + old$n_iter <- old$n_iter + 1L + old$phi_0 <- new$phi_0 + + return(old) +} + + + +.compute_shap_value <- function( + shap_matrices +) { + # Compute shap values. + shap_values <- lapply( + shap_matrices, + ..compute_shap_value + ) + shap_values <- data.table::rbindlist(shap_values) + + return(shap_values) +} + + + +..compute_shap_value <- function(x) { + if (is.null(x)) return(NULL) + + A_inv <- matrix_pseudo_inverse(x$A) + b <- x$b + + # Compute initial coefficients. + phi <- A_inv %*% b + + # Due to the local accuracy criterion the sum of of the SHAP values plus phi_0 + # should be equal to the predicted value. We estimate the SHAP values under + # this constraint. + phi <- A_inv %*% t(t(b) - (colSums(phi) - (x$v_0 - x$phi_0)) / sum(A_inv)) + + shap_values <- list( + "sample_id" = x$sample_id, + "feature_name" = rep(colnames(x$A), times = ncol(x$b)), + "feature_value_mapping" = rep(x$sample_mapping, times = ncol(x$b)), + "shap_value" = c(phi), + "shap_outcome" = rep(colnames(x$b), each = ncol(x$A)) + ) + + return(shap_values) +} + + + +.compute_shap_value_single_feature <- function( + important_features, + mapping, + sample_id, + feature_set, + predicted_values, + phi_0 +) { + # Get value mapping. + mapping <- mapping[, important_features] + + data <- data.table::data.table( + "sample_id" = sample_id, + "feature_name" = important_features, + "feature_value_mapping" = rep(mapping, times = ncol(predicted_values)), + "shap_value" = c(t(t(predicted_values) - phi_0)), + "shap_outcome" = rep(colnames(predicted_values), each = nrow(predicted_values)) + ) + + return(data) +} + + + +.evaluate_shap_convergence <- function( + shap_variance, + tolerance +) { + # Compute sample error of the mean for each shap value. + sem_values <- sqrt(shap_variance$shap_var / shap_variance$n) + if (any(!is.finite(sem_values))) return(FALSE) + # TODO: remove + # cat(paste0("sum SEM: ", sum(sem_values), " ; total converged: ", sum(sem_values <= tolerance), "\n")) + return(all(sem_values <= tolerance)) +} + + + +.predict_from_coalition <- function( + mapping, + feature_set, + object, + ensemble_method, + evaluation_time +) { + # Set prediction type. + prediction_type <- ifelse( + object@outcome_type %in% c("survival", "competing_risk"), + "survival_probability", + "default" + ) + + # Convert input to dataObject + data <- .shap_mapping_to_data( + mapping = mapping, + feature_set = feature_set, + object = object + ) + + if (object@outcome_type == "survival") { + prediction_list <- list() + + for (ii in seq_along(evaluation_time)) { + # Predict input data + prediction_data <- predict( + object = object, + newdata = data, + ensemble_method = ensemble_method, + time = evaluation_time[ii], + type = prediction_type, + .as_prediction_table = TRUE + ) + + # Check if all predictions are valid. + if (!all_predictions_valid(prediction_data)) return(NULL) + + # Convert to data.table. + prediction_data <- .as_data_table(prediction_data)[, mget(prediction_data@value_column)] + prediction_list[[ii]] <- matrix(prediction_data$predicted_outcome, ncol = 1L) + } + + prediction_data <- do.call(cbind, prediction_list) + colnames(prediction_data) <- as.character(evaluation_time) + + } else { + # Predict input data + prediction_data <- predict( + object = object, + newdata = data, + ensemble_method = ensemble_method, + type = prediction_type, + .as_prediction_table = TRUE + ) + + # Check if all predictions are valid. + if (!all_predictions_valid(prediction_data)) return(NULL) + + # Convert to data.table. + prediction_data <- .as_data_table(prediction_data)[, mget(prediction_data@value_column)] + + if (object@outcome_type == "continuous") { + prediction_data <- matrix(prediction_data$predicted_outcome, ncol = 1L) + colnames(prediction_data) <- "predicted_outcome" + + } else if (object@outcome_type %in% c("multinomial")) { + probability_columns <- get_outcome_class_levels(object) + prediction_data <- as.matrix(prediction_data[, mget(probability_columns)]) + + } else if (object@outcome_type %in% c("binomial")) { + probability_column <- utils::tail(get_outcome_class_levels(object), n = 1L) + prediction_data <- as.matrix(prediction_data[, mget(probability_column)]) + + } else { + ..error_outcome_type_not_implemented(object@outcome_type) + } + } + + return(prediction_data) +} + + + +.hash_mapping <- function(x) { + return(apply( + x, + MARGIN = 1L, + FUN = rlang::hash, + simplify = TRUE + )) +} + + + +.extract_shap_summary <- function( + x +) { + # Prevent NOTES due to non-standard evaluation + feature_name <- feature_value_mapping <- NULL + + # Generate object using the incoming familiarDataElementSHAP object as a + # template. + data_element <- methods::new( + "familiarDataElementSHAPSummary", + x + ) + + # Clean reporting elements. + data_element@data <- NULL + + if (is_empty(x@data)) return(data_element) + + # Get data_mapping and turn into a long data.table. + mapping_data <- data.table::as.data.table(x@data_mapping) + mapping_data[, "sample_id" := x@sample_identifiers] + mapping_data <- data.table::melt( + data = mapping_data, + id.vars = "sample_id", + variable.name = "feature_name", + value.name = "feature_value_mapping" + ) + + # Insert feature values in mapping data. + mapping_data[ + , + c("feature_value", "feature_label") := .shap_mapping_to_feature_list( + feature = feature_name, + mapping_value = feature_value_mapping, + lookup_table = x@lookup_table + ), + by = "feature_name" + ] + + # Cartesian merge. + summary_data <- merge( + x = x@data, + y = mapping_data, + by = c("feature_name", "feature_value_mapping", "sample_id"), + allow.cartesian = TRUE + ) + + # Drop unused columns. + summary_data[, feature_value_mapping := NULL] + + # Set data. + data_element@data <- summary_data + + # Set identifiers + data_element@grouping_column <- c( + setdiff(data_element@grouping_column, "feature_value_mapping"), + c("feature_value", "feature_label") + ) + + return(data_element) +} + + + +.extract_shap_force <- function( + x +) { + # Prevent NOTES due to non-standard evaluation + feature_name <- feature_value_mapping <- NULL + + # Generate object using the incoming familiarDataElementSHAP object as a + # template. + data_element <- methods::new( + "familiarDataElementSHAPForce", + x + ) + + # Clean reporting elements. + data_element@data <- NULL + + if (is_empty(x@data)) return(data_element) + + # Get data_mapping and turn into a long data.table. + mapping_data <- data.table::as.data.table(x@data_mapping) + mapping_data[, "sample_id" := x@sample_identifiers] + mapping_data <- data.table::melt( + data = mapping_data, + id.vars = "sample_id", + variable.name = "feature_name", + value.name = "feature_value_mapping" + ) + + # Insert feature values in mapping data. + mapping_data[ + , + c("feature_value", "feature_label") := .shap_mapping_to_feature_list( + feature = feature_name, + mapping_value = feature_value_mapping, + lookup_table = x@lookup_table + ), + by = "feature_name" + ] + + # Prediction data + prediction_data <- data.table::as.data.table(x@predicted_values) + prediction_data[, "sample_id" := x@sample_identifiers] + prediction_data <- data.table::melt( + data = prediction_data, + id.vars = "sample_id", + variable.name = "shap_outcome", + value.name = "prediction" + ) + + # Cartesian merge. + force_data <- merge( + x = x@data, + y = mapping_data, + by = c("feature_name", "feature_value_mapping", "sample_id"), + allow.cartesian = TRUE + ) + + merge_cols <- "sample_id" + if ("shap_outcome" %in% colnames(force_data)) merge_cols <- c(merge_cols, "shap_outcome") + + force_data <- merge( + x = force_data, + y = prediction_data, + by = merge_cols + ) + + # Drop unused columns. + force_data[, feature_value_mapping := NULL] + + # Set data. + data_element@data <- force_data + + # Set identifiers + data_element@grouping_column <- c( + setdiff(data_element@grouping_column, "feature_value_mapping"), + c("feature_value", "feature_label", "prediction") + ) + + return(data_element) +} + + + +.extract_shap_dependence <- function( + x, + feature_x, + feature_y +) { + data_element_list <- list() + iter_id <- 1L + for (current_feature_x in feature_x) { + if (!current_feature_x %in% names(x@lookup_table)) { + ..warning(paste0( + current_feature_x, " is not part of the feature set used by the model. ", + "The following features were used: ", paste_s(names(x@lookup_table)) + )) + next + } + + for (current_feature_y in feature_y) { + if (!current_feature_y %in% names(x@lookup_table)) { + ..warning(paste0( + current_feature_y, " is not part of the feature set used by the model. ", + "The following features were used: ", paste_s(names(x@lookup_table)) + )) + next + } + + data_element_list[[iter_id]] <- ..extract_shap_dependence( + x = x, + feature_x = current_feature_x, + feature_y = current_feature_y + ) + + iter_id <- iter_id + 1L + } + } + + if (is_empty(data_element_list)) return(NULL) + + return(data_element_list) +} + + + +..extract_shap_dependence <- function( + x, + feature_x, + feature_y +) { + # Prevent NOTES due to non-standard evaluation + feature_name <- feature_value_mapping <- NULL + + # Generate object using the incoming familiarDataElementSHAP object as a + # template. + data_element <- methods::new( + "familiarDataElementSHAPDependence", + x + ) + + # Add feature x and feature y as identifiers to the dataset. + data_element <- add_data_element_identifier( + x = data_element, + feature_x = feature_x + )[[1L]] + data_element <- add_data_element_identifier( + x = data_element, + feature_y = feature_y + )[[1L]] + + # Clean reporting elements. + data_element@data <- NULL + + if (is_empty(x@data)) return(data_element) + + # Get data_mapping and turn into a long data.table. + mapping_data <- data.table::as.data.table(x@data_mapping) + mapping_data[, "sample_id" := x@sample_identifiers] + mapping_data <- data.table::melt( + data = mapping_data, + id.vars = "sample_id", + variable.name = "feature_name", + value.name = "feature_value_mapping" + ) + + # Insert feature values in mapping data. + mapping_data[ + , + c("feature_value", "feature_label") := .shap_mapping_to_feature_list( + feature = feature_name, + mapping_value = feature_value_mapping, + lookup_table = x@lookup_table + ), + by = "feature_name" + ] + + # To create a dependence plot, we need for: + # feature x: its value and its SHAP value. + # feature y: its value + # These are linked by the sample identifier. + + feature_x_data <- data.table::copy(mapping_data[feature_name == feature_x]) + feature_y_data <- data.table::copy(mapping_data[feature_name == feature_y]) + + # Cartesian merge. + dependence_data <- merge( + x = x@data, + y = feature_x_data, + by = c("feature_name", "feature_value_mapping", "sample_id"), + allow.cartesian = TRUE + ) + + # Update column names. + data.table::setnames( + dependence_data, + old = c("feature_value", "feature_label"), + new = c("feature_value_x", "feature_label_x") + ) + dependence_data[, feature_value_mapping := NULL] + dependence_data[, feature_name := NULL] + + # Add feature_y_data. + dependence_data <- merge( + x = dependence_data, + y = feature_y_data, + by = "sample_id" + ) + + # Update column names. + data.table::setnames( + dependence_data, + old = c("feature_value", "feature_label"), + new = c("feature_value_y", "feature_label_y") + ) + dependence_data[, feature_value_mapping := NULL] + dependence_data[, feature_name := NULL] + + # Update column order. + col_order <- c("sample_id", "feature_value_x", "feature_label_x") + if ("shap_outcome" %in% colnames(dependence_data)) col_order <- c(col_order, "shap_outcome") + col_order <- c(col_order, "shap_value", "feature_value_y", "feature_label_y") + data.table::setcolorder( + dependence_data, + neworder = col_order + ) + + # Set data. + data_element@data <- dependence_data + + # Update grouping columns. + data_element@grouping_column <- c( + setdiff(data_element@grouping_column, c("feature_name", "feature_value_mapping")), + c("feature_value_x", "feature_label_x", "feature_value_y", "feature_label_y") + ) + + return(data_element) +} + + +# export_shap (generic) -------------------------------------------------------- + +#'@title Extract and export individual conditional expectation data. +#' +#'@description Extract and export individual conditional expectation data. +#' +#'@param feature_x (*optional*) Feature(s) whose SHAP values are used for +#' determining dependence. +#'@param feature_y (*optional*) Feature(s) whose values are used to show +#' interaction with the feature(s) in `feature_x`. +#' +#'@inheritParams export_all +#'@inheritParams export_univariate_analysis_data +#' +#'@inheritDotParams as_familiar_collection +#' +#'@details Data is usually collected from a `familiarCollection` object. +#' However, you can also provide one or more `familiarData` objects, that will +#' be internally converted to a `familiarCollection` object. It is also +#' possible to provide a `familiarEnsemble` or one or more `familiarModel` +#' objects together with the data from which data is computed prior to export. +#' Paths to the previous files can also be provided. +#' +#' All parameters aside from `object` and `dir_path` are only used if `object` +#' is not a `familiarCollection` object, or a path to one. +#' +#'@return A list of data.tables (if `dir_path` is not provided), or nothing, as +#' all data is exported to `csv` files. +#'@exportMethod export_ice_data +#'@md +#'@rdname export_shap-methods +setGeneric( + "export_shap", + function( + object, + dir_path = NULL, + aggregate_results = TRUE, + export_collection = FALSE, + feature_x = NULL, + feature_y = NULL, + ... + ) { + standardGeneric("export_shap") + } +) + + + +# export_shap (collection) ----------------------------------------------------- + +#'@rdname export_shap-methods +setMethod( + "export_shap", + signature(object = "familiarCollection"), + function( + object, + dir_path = NULL, + aggregate_results = TRUE, + export_collection = FALSE, + feature_x = NULL, + feature_y = NULL, + ... + ) { + + # Make sure the collection object is updated. + object <- update_object(object = object) + + # Generate data for summary plots. + summary_data_elements <- lapply( + object@shap_data, + .extract_shap_summary + ) + + # Export summary data. + summary_data <- .export( + x = object, + data_elements = summary_data_elements, + dir_path = dir_path, + aggregate_results = TRUE, + object_class = "familiarDataElementSHAPSummary", + type = "explanation", + subtype = "shap_summary" + ) + + # Generate data for force plots. + force_data_elements <- lapply( + object@shap_data, + .extract_shap_force + ) + + # Export data for force plots. + force_data <- .export( + x = object, + data_elements = force_data_elements, + dir_path = dir_path, + aggregate_results = TRUE, + object_class = "familiarDataElementSHAPForce", + type = "explanation", + subtype = "shap_force" + ) + + dependence_data <- NULL + if (!is.null(feature_x) && !is.null(feature_y)) { + # Generate data for SHAP dependence plots. + dependence_data_elements <- lapply( + object@shap_data, + .extract_shap_dependence, + feature_x = feature_x, + feature_y = feature_y + ) + + dependence_data <- .export( + x = object, + data_elements = dependence_data_elements, + dir_path = dir_path, + aggregate_results = TRUE, + object_class = "familiarDataElementSHAPDependence", + type = "explanation", + subtype = "shap_dependence" + ) + } + + # Add to list. + data_list <- c( + "shap_summary" = summary_data, + "shap_force" = force_data, + "shap_dependence" = dependence_data + ) + + if (export_collection) { + data_list <- c( + data_list, + list("collection" = object) + ) + } + + return(data_list) + } +) + + + +# export_shap (general) ---------------------------------------------------- + +#'@rdname export_shap-methods +setMethod( + "export_shap", + signature(object = "ANY"), + function( + object, + dir_path = NULL, + aggregate_results = TRUE, + export_collection = FALSE, + ... + ) { + + # Attempt conversion to familiarCollection object. + object <- do.call( + as_familiar_collection, + args = c( + list( + "object" = object, + "data_element" = "export_shap", + "aggregate_results" = aggregate_results + ), + list(...) + ) + ) + + return(do.call( + export_shap, + args = c( + list( + "object" = object, + "dir_path" = dir_path, + "aggregate_results" = aggregate_results, + "export_collection" = export_collection + ), + list(...) + ) + )) + } +) diff --git a/R/FamiliarDataComputationSampleSimilarity.R b/R/FamiliarDataComputationSampleSimilarity.R index 9b3c00a8..947ccf47 100644 --- a/R/FamiliarDataComputationSampleSimilarity.R +++ b/R/FamiliarDataComputationSampleSimilarity.R @@ -14,7 +14,8 @@ setClass( "linkage_method" = "character", "cluster_cut_method" = "character", "similarity_threshold" = "ANY", - "dendrogram" = "ANY"), + "dendrogram" = "ANY" + ), prototype = methods::prototype( detail_level = "ensemble", estimation_type = "point", @@ -25,7 +26,9 @@ setClass( similarity_threshold = NULL, dendrogram = NULL, value_column = "value", - grouping_column = c("sample_1", "sample_2"))) + grouping_column = c("sample_1", "sample_2") + ) +) @@ -38,12 +41,13 @@ setClass( #' This table can be used to cluster samples, and is exported directly by #' `extract_feature_expression`. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' -#'@return A data.table containing pairwise distance between samples. This data +#'@return An object containing pairwise distance between samples. This data #' is only the upper triangular of the complete matrix (i.e. the sparse #' unitriangular representation). Diagonals will always be 0.0 and the lower #' triangular is mirrored. +#' #'@md #'@keywords internal setGeneric( @@ -59,12 +63,14 @@ setGeneric( sample_similarity_metric = waiver(), verbose = FALSE, message_indent = 0L, - ...) { + ... + ) { standardGeneric("extract_sample_similarity") } ) + # extract_sample_similarity (familiarEnsemble) --------------------------------- setMethod( "extract_sample_similarity", @@ -80,13 +86,15 @@ setMethod( sample_similarity_metric = waiver(), verbose = FALSE, message_indent = 0L, - ...) { + ... + ) { # Message extraction start logger_message( paste0("Computing pairwise similarity between samples."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Obtain sample cluster method from stored settings, if required. if (is.waive(sample_cluster_method)) { @@ -112,21 +120,24 @@ setMethod( cluster_method = sample_cluster_method, cluster_linkage = sample_linkage_method, cluster_similarity_metric = sample_similarity_metric, - data_type = "sample") + data_type = "sample" + ) # Check the sample limit. sample_limit <- .parse_sample_limit( x = sample_limit, object = object, default = Inf, - data_element = "sample_similarity") + data_element = "sample_similarity" + ) # Generate a prototype data element. proto_data_element <- new( "familiarDataElementSampleSimilarity", similarity_metric = sample_similarity_metric, cluster_method = sample_cluster_method, - linkage_method = sample_linkage_method) + linkage_method = sample_linkage_method + ) # Generate elements to send to dispatch. similarity_data <- extract_dispatcher( @@ -140,7 +151,119 @@ setMethod( is_pre_processed = is_pre_processed, aggregate_results = TRUE, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) + + return(similarity_data) + } +) + + + +# extract_sample_similarity (familiarDataElementPredictionTable) --------------- +setMethod( + "extract_sample_similarity", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("sample similarity") + + return(NULL) + } +) + + + +# extract_sample_similarity (dataObject) --------------------------------------- +setMethod( + "extract_sample_similarity", + signature(object = "dataObject"), + function( + object, + data, + cl = NULL, + is_pre_processed = FALSE, + sample_limit = waiver(), + sample_cluster_method = waiver(), + sample_linkage_method = waiver(), + sample_similarity_metric = waiver(), + verbose = FALSE, + message_indent = 0L, + ... + ) { + + # Message extraction start + logger_message( + paste0("Computing pairwise similarity between samples."), + indent = message_indent, + verbose = verbose + ) + + settings <- .parse_sample_clustering( + sample_cluster_method = sample_cluster_method, + sample_linkage_method = sample_linkage_method, + sample_similarity_metric = sample_similarity_metric + ) + + # Set default cluster method, if required. + if (is.waive(sample_cluster_method)) { + sample_cluster_method <- settings$sample_cluster_method + } + + # Set default linkage function, if required. + if (is.waive(sample_linkage_method)) { + sample_linkage_method <- settings$sample_linkage_method + } + + # Set default similarity metric, if required. + if (is.waive(sample_similarity_metric)) { + sample_similarity_metric <- settings$sample_similarity_metric + } + + # Replace sample cluster method == "none" with "hclust" + if (sample_cluster_method == "none") { + sample_cluster_method <- "hclust" + } + + # Check the sample limit. + sample_limit <- .parse_sample_limit( + x = sample_limit, + object = object, + default = Inf, + data_element = "sample_similarity" + ) + + # Generate a prototype data element. + proto_data_element <- new( + "familiarDataElementSampleSimilarity", + similarity_metric = sample_similarity_metric, + cluster_method = sample_cluster_method, + linkage_method = sample_linkage_method + ) + + # Assume data is transformed. + object@preprocessing_level <- "transformation" + + # Generate feature info by running the familiarTaskGenericFeatureInfo task. + generic_feature_info_task <- new("familiarTaskGenericFeatureInfo") + object@feature_info <- .perform_task( + object = generic_feature_info_task, + data = object + ) + + # Generate elements to send to dispatch. + similarity_data <- extract_dispatcher( + FUN = .extract_sample_similarity, + has_internal_bootstrap = FALSE, + cl = cl, + object = object, + data = object, + sample_limit = sample_limit, + proto_data_element = proto_data_element, + is_pre_processed = is_pre_processed, + aggregate_results = TRUE, + message_indent = message_indent + 1L, + verbose = verbose + ) return(similarity_data) } @@ -158,45 +281,48 @@ setMethod( message_indent, aggregate_results = TRUE, verbose = FALSE, - ...) { + ... +) { # Add the name of the ensemble model data_element <- add_model_name( data = proto_data_element, - object = object) + object = object + ) # Retrieve input data. data <- process_input_data( object = object, data = data, stop_at = "imputation", - is_pre_processed = is_pre_processed) + is_pre_processed = is_pre_processed + ) # Check if the input data is not empty if (is_empty(data)) return(NULL) # Check if the number of samples is sufficient to form pairs (>= 2), and # return an empty table if not. - if (data.table::uniqueN( - data@data, - by = get_id_columns(id_depth = "sample")) < 2) { - return(data_element) - } + if (get_n_samples(data) < 2L) return(data_element) # Select samples up to sample_limit. data <- get_subsample( data = data, size = sample_limit, - seed = 0L) - - # Maintain only important features. The current set is based on the required - # features. - data <- filter_features( - data = data, - available_features = object@model_features) + seed = 0L + ) - # Aggregate features. - data <- aggregate_data(data = data) + if (is(object, "familiarEnsemble")){ + # Maintain only important features when assessing data from the perspective + # of an ensemble. The current set is based on the required features. + data <- filter_features( + data = data, + available_features = object@model_features + ) + + # Aggregate features. + data <- aggregate_data(data = data) + } # Identify eligible columns. feature_columns <- get_feature_columns(x = data) @@ -209,7 +335,8 @@ setMethod( data_type = "sample", cl = cl, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) # Merge data elements data_elements <- merge_data_elements(list(data_element)) @@ -252,7 +379,8 @@ setMethod( # Compute the cluster table. cluster_table <- create_clusters( object = cluster_method_object, - as_cluster_object = FALSE) + as_cluster_object = FALSE + ) return(cluster_table) } @@ -263,7 +391,7 @@ setMethod( if (is_empty(x)) return(NULL) - if (length(x@similarity_threshold) > 1) { + if (length(x@similarity_threshold) > 1L) { # Remove 1.0 because that does not yield clustering info. available_thresholds <- setdiff(x@similarity_threshold, 1.0) @@ -278,14 +406,16 @@ setMethod( cluster_linkage = x@linkage_method, cluster_cut_method = "none", cluster_similarity_metric = x@similarity_metric, - cluster_representation_method = "none") + cluster_representation_method = "none" + ) # Attach the similarity table to the cluster_method_object. cluster_method_object@similarity_table <- methods::new( "similarityTable", data = x@data[, mget(c("sample_1", "sample_2", "value"))], similarity_metric = x@similarity_metric, - data_type = cluster_method_object@data_type) + data_type = cluster_method_object@data_type + ) return(cluster_method_object) } @@ -311,7 +441,8 @@ setMethod( sample_names, size = sample_limit, replace = FALSE, - seed = 0) + seed = 0L + ) # Select only the selected samples. x@data <- x@data[sample_1 %in% sample_names & sample_2 %in% sample_names] @@ -331,21 +462,19 @@ setMethod( #'@param export_dendrogram Add dendrogram in the data element objects. #' #'@inheritParams export_all -#'@inheritParams extract_data +#'@inheritParams .extract_data #'@inheritParams export_univariate_analysis_data #' #'@inheritDotParams as_familiar_collection +#'@inheritDotParams as_data_object #' -#'@details Data is usually collected from a `familiarCollection` object. -#' However, you can also provide one or more `familiarData` objects, that will -#' be internally converted to a `familiarCollection` object. It is also -#' possible to provide a `familiarEnsemble` or one or more `familiarModel` -#' objects together with the data from which data is computed prior to export. -#' Paths to the previous files can also be provided. -#' +#'@details #' All parameters aside from `object` and `dir_path` are only used if `object` #' is not a `familiarCollection` object, or a path to one. #' +#' Sample similarity data can be created from `dataObject`, or `data.table` objects. +#' For `data.table`, see \code{\link{as_data_object}} for additional arguments. +#' #'@return A list containing a data.table (if `dir_path` is not provided), or #' nothing, as all data is exported to `csv` files. #'@exportMethod export_sample_similarity @@ -362,7 +491,8 @@ setGeneric( sample_linkage_method = waiver(), export_dendrogram = FALSE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_sample_similarity") } ) @@ -384,7 +514,8 @@ setMethod( sample_linkage_method = waiver(), export_dendrogram = FALSE, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -405,7 +536,8 @@ setMethod( x@cluster_method <- sample_cluster_method return(x) }, - sample_cluster_method = sample_cluster_method) + sample_cluster_method = sample_cluster_method + ) } # Check sample linkage method. @@ -418,7 +550,8 @@ setMethod( x@linkage_method <- sample_linkage_method return(x) }, - sample_linkage_method = sample_linkage_method) + sample_linkage_method = sample_linkage_method + ) } # Check the sample limit. @@ -426,7 +559,8 @@ setMethod( .check_number_in_valid_range( x = sample_limit, var_name = "sample_limit", - range = c(20L, Inf)) + range = c(20L, Inf) + ) } else { sample_limit <- Inf @@ -435,12 +569,13 @@ setMethod( # Check whether the input parameters are valid and create a cluster # object. .check_cluster_parameters( - cluster_method = x[[1]]@cluster_method, + cluster_method = x[[1L]]@cluster_method, data_type = "sample", - cluster_linkage = x[[1]]@linkage_method, + cluster_linkage = x[[1L]]@linkage_method, cluster_cut_method = "none", - cluster_similarity_metric = x[[1]]@similarity_metric, - cluster_representation_method = "none") + cluster_similarity_metric = x[[1L]]@similarity_metric, + cluster_representation_method = "none" + ) if (aggregate_results || export_dendrogram) { x <- .compute_data_element_estimates(x) @@ -450,7 +585,8 @@ setMethod( x <- lapply( x, ..limit_sample_similarity_samples, - sample_limit = sample_limit) + sample_limit = sample_limit + ) } # Add clustering information. @@ -465,9 +601,10 @@ setMethod( dir_path = dir_path, aggregate_results = aggregate_results, type = "sample_similarity", - subtype = x[[1]]@similarity_metric, + subtype = x[[1L]]@similarity_metric, export_dendrogram = export_dendrogram, - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -486,7 +623,8 @@ setMethod( sample_cluster_method = waiver(), sample_linkage_method = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -498,8 +636,11 @@ setMethod( "sample_limit" = sample_limit, "aggregate_results" = aggregate_results, "sample_cluster_method" = sample_cluster_method, - "sample_linkage_method" = sample_linkage_method), - list(...))) + "sample_linkage_method" = sample_linkage_method + ), + list(...) + ) + ) return(do.call( export_sample_similarity, @@ -510,8 +651,11 @@ setMethod( "aggregate_results" = aggregate_results, "sample_cluster_method" = sample_cluster_method, "sample_linkage_method" = sample_linkage_method, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -526,7 +670,8 @@ setMethod( x_list, aggregate_results = FALSE, export_dendrogram, - ...) { + ... + ) { # This is like .export,familiarDataElement, but the elements are merged # prior to computing estimates. @@ -537,7 +682,8 @@ setMethod( x = x_list, as_data = "all", as_grouping_column = TRUE, - force_data_table = TRUE) + force_data_table = TRUE + ) } else { x <- x_list diff --git a/R/FamiliarDataComputationUnivariateAnalysis.R b/R/FamiliarDataComputationUnivariateAnalysis.R index ae8fc55f..5595babb 100644 --- a/R/FamiliarDataComputationUnivariateAnalysis.R +++ b/R/FamiliarDataComputationUnivariateAnalysis.R @@ -10,7 +10,9 @@ setClass( contains = "familiarDataElement", prototype = methods::prototype( detail_level = "ensemble", - estimation_type = "point")) + estimation_type = "point" + ) +) # familiarDataElementRobustness object ----------------------------------------- setClass( @@ -20,7 +22,9 @@ setClass( prototype = methods::prototype( detail_level = "ensemble", estimation_type = "point", - icc_type = "1")) + icc_type = "1" + ) +) @@ -30,9 +34,9 @@ setClass( #' #'@description Computes and extracts univariate analysis for the features used #' in a `familiarEnsemble` object. This assessment includes the computation of -#' p and q-values, as well as robustness (in case of repeated measurements). +#' p-values, as well as robustness (in case of repeated measurements). #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list with a data.table containing information concerning the #' univariate analysis of important features. @@ -53,7 +57,8 @@ setGeneric( feature_similarity_metric = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_univariate_analysis") } ) @@ -75,7 +80,8 @@ setMethod( feature_similarity_threshold = waiver(), feature_similarity_metric = waiver(), message_indent = 0L, - verbose = FALSE) { + verbose = FALSE + ) { # Suppress NOTES due to non-standard evaluation in data.table p_value <- NULL @@ -84,7 +90,8 @@ setMethod( logger_message( paste0("Extracting univariate analysis information."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Obtain from settings, if unset. if (is.waive(icc_type)) icc_type <- object@settings$icc_type @@ -93,13 +100,15 @@ setMethod( .check_parameter_value_is_valid( x = icc_type, var_name = "icc_type", - values = .get_available_icc_types()) + values = .get_available_icc_types() + ) # Get and process the input data data <- process_input_data( object = object, data = data, - stop_at = "normalisation") + stop_at = "normalisation" + ) # Check if the data object is empty. if (is_empty(data)) return(NULL) @@ -108,39 +117,34 @@ setMethod( # features. data <- filter_features( data = data, - available_features = object@model_features) + available_features = object@model_features + ) # Determine feature columns feature_columns <- get_feature_columns(x = data) # Check if there are any features in the model. - if (length(feature_columns) == 0) return(NULL) + if (length(feature_columns) == 0L) return(NULL) ## Univariate p-values ----------------------------------------------------- # Remove data with missing outcomes. - feature_data <- remove_missing_outcomes( - data = data, - outcome_type = object@outcome_type) + feature_data <- filter_missing_outcome(data) if (is_empty(feature_data)) { # Check that data are not empty univariate_data <- NULL - } else if (data.table::uniqueN( - feature_data@data, - by = get_id_columns(id_depth = "sample")) <= 5) { + } else if (get_n_samples(feature_data) <= 5L) { # Check if the number of samples is sufficient (>5). univariate_data <- NULL } else { - # Check that the qvalue package is installed. - has_qvalue_package <- is_package_installed(name = "qvalue") - # Calculate univariate P values, based on aggregated data regression_p_values <- compute_univariable_p_values( cl = cl, data_obj = aggregate_data(data = feature_data), - feature_columns = feature_columns) + feature_columns = feature_columns + ) # Find and replace non-finite values regression_p_values[!is.finite(regression_p_values)] <- NA_real_ @@ -148,39 +152,16 @@ setMethod( # Collect to table univariate_data <- data.table::data.table( "feature" = names(regression_p_values), - "p_value" = regression_p_values)[order(p_value)] - - # Only introduce q-values if the qvalue package is installed. - if (has_qvalue_package) { - ..deprecation_qvalue() - - if (all(!is.finite(regression_p_values))) { - # q-values can only be computed if any p-values are not NA. - computed_q_value <- NA_real_ - - } else { - # q-values can only be computed for larger numbers of features - computed_q_value <- tryCatch( - qvalue::qvalue(p = univariate_data$p_value)$qvalues, - warning = identity, - error = identity) - - if (inherits(computed_q_value, "error")) computed_q_value <- NA_real_ - if (inherits(computed_q_value, "warning")) computed_q_value <- NA_real_ - } - - # Set q-value - univariate_data[, "q_value" := computed_q_value] - } + "p_value" = regression_p_values + )[order(p_value)] # Set univariate data. univariate_data <- methods::new( "familiarDataElementUnivariateAnalysis", data = univariate_data, - value_column = ifelse( - has_qvalue_package, - c("p_value", "q_value"), "p_value"), - grouping_column = "feature") + value_column = "p_value", + grouping_column = "feature" + ) # Add model name. univariate_data <- add_model_name(univariate_data, object) @@ -188,15 +169,16 @@ setMethod( ## Feature robustness ------------------------------------------------------ - if (!all(data@data$repetition_id == 1)) { + if (!all(data@data$repetition_id == 1L)) { # Determine which columns actually contains numeric data numeric_columns <- feature_columns[sapply( feature_columns, function(ii, data) (is.numeric(data@data[[ii]])), - data = data)] + data = data + )] - if (length(numeric_columns) == 0) { + if (length(numeric_columns) == 0L) { icc_data <- NULL } else { @@ -210,7 +192,9 @@ setMethod( progress_bar = FALSE, MoreArgs = list( "id_data" = data@data[, mget(get_id_columns(id_depth = "repetition"))], - "type" = icc_type)) + "type" = icc_type + ) + ) # Compute values icc_data <- data.table::rbindlist(icc_data, use.names = TRUE) @@ -220,7 +204,8 @@ setMethod( "familiarDataElementRobustness", data = icc_data, value_column = c("icc", "icc_low", "icc_up", "icc_panel", "icc_panel_low", "icc_panel_up"), - grouping_column = "feature") + grouping_column = "feature" + ) # Add model name. icc_data <- add_model_name(icc_data, object) @@ -236,6 +221,19 @@ setMethod( +# extract_univariate_analysis (prediction table) ------------------------------- +setMethod( + "extract_univariate_analysis", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("univariate feature importance") + + return(NULL) + } +) + + + # export_univariate_analysis_data (generic) ------------------------------------ #'@title Extract and export univariate analysis data of features. @@ -259,7 +257,7 @@ setMethod( #' All parameters aside from `object` and `dir_path` are only used if `object` #' is not a `familiarCollection` object, or a path to one. #' -#' Univariate analysis includes the computation of p and q-values, as well as +#' Univariate analysis includes the computation of p-values, as well as #' robustness (in case of repeated measurements). p-values are derived from #' Wald's test. #' @@ -275,7 +273,8 @@ setGeneric( dir_path = NULL, p_adjustment_method = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_univariate_analysis_data") } ) @@ -293,7 +292,8 @@ setMethod( dir_path = NULL, p_adjustment_method = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -310,13 +310,15 @@ setMethod( aggregate_results = FALSE, type = "variable_importance", subtype = "univariate", - object_class = "familiarDataElementUnivariateAnalysis") + object_class = "familiarDataElementUnivariateAnalysis" + ) # Compute the adjusted p-values. univariate_data <- lapply( univariate_data, .compute_adjusted_univariate_p_value, - method = p_adjustment_method) + method = p_adjustment_method + ) # Obtain robustness data. icc_data <- .export( @@ -326,12 +328,14 @@ setMethod( aggregate_results = FALSE, type = "variable_importance", subtype = "robustness", - object_class = "familiarDataElementRobustness") + object_class = "familiarDataElementRobustness" + ) # Set data list. data_list <- list( "univariate" = univariate_data, - "icc" = icc_data) + "icc" = icc_data + ) if (!is.null(dir_path)) data_list <- NULL if (export_collection) data_list <- c(data_list, list("collection" = object)) @@ -353,7 +357,8 @@ setMethod( dir_path = NULL, p_adjustment_method = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( @@ -361,8 +366,11 @@ setMethod( args = c( list( "object" = object, - "data_element" = "univariate_analysis"), - list(...))) + "data_element" = "univariate_analysis" + ), + list(...) + ) + ) return(do.call( export_univariate_analysis_data, @@ -371,8 +379,11 @@ setMethod( "object" = object, "dir_path" = dir_path, "p_adjustment_method" = p_adjustment_method, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -395,11 +406,14 @@ setMethod( # Make a local copy of the data. data <- data.table::copy(x@data) - if (length(grouping_column) == 0) { + if (length(grouping_column) == 0L) { data[, "adjusted_p_value" := stats::p.adjust(p = p_value, method = method)] } else { - data[, "adjusted_p_value" := stats::p.adjust(p = p_value, method = method), - by = c(grouping_column)] + data[ + , + "adjusted_p_value" := stats::p.adjust(p = p_value, method = method), + by = c(grouping_column) + ] } # Add to data element. diff --git a/R/FamiliarDataComputationUtilities.R b/R/FamiliarDataComputationUtilities.R new file mode 100644 index 00000000..b9ec2a37 --- /dev/null +++ b/R/FamiliarDataComputationUtilities.R @@ -0,0 +1,401 @@ + +.get_available_data_elements <- function( + check_has_estimation_type = FALSE, + check_has_detail_level = FALSE, + check_has_sample_limit = FALSE, + check_has_n_important_features = FALSE, + check_from_prediction_table = FALSE, + check_from_data_object = FALSE +) { + + # All data elements. + all_data_elements <- c( + "auc_data", "calibration_data", "calibration_info", "confusion_matrix", + "decision_curve_analyis", "feature_expressions", + "fs_vimp", "hyperparameters", "model_performance", + "model_vimp", "permutation_vimp", "prediction_data", + "risk_stratification_data", "risk_stratification_info", + "univariate_analysis", "feature_similarity", "sample_similarity", "ice_data", + "shap" + ) + + # Data elements that allow setting an estimation type. + can_set_estimation_type <- c( + "auc_data", "calibration_data", "decision_curve_analyis", + "model_performance", "permutation_vimp", "prediction_data", "ice_data" + ) + + # Data elements that allow setting a detail level. + can_set_detail_level <- c( + can_set_estimation_type, "calibration_info", "confusion_matrix", + "risk_stratification_data", "risk_stratification_info", "shap" + ) + + # Data elements that allow for setting an estimation type but not detail + # level. + can_set_estimation_type <- c(can_set_estimation_type, "feature_similarity") + + # Data elements that allow for setting a sample limit. + can_set_sample_limit <- c("sample_similarity", "ice_data", "shap", "permutation_vimp") + + # Data elements that allow for setting the number of important features. + can_set_n_important_features <- c("permutation_vimp", "ice_data", "shap") + + # Data elements that can be computed from prediction table objects. + can_use_prediction_table <- c( + "prediction_data", "auc_data", "calibration_data", "decision_curve_analyis", + "model_performance", "risk_stratification_data" + ) + + # Data elements that can be computed from data objects. + can_use_data_object <- c("risk_stratification_data", "feature_similarity", "sample_similarity", "feature_expressions") + + if (check_has_sample_limit) { + all_data_elements <- intersect(all_data_elements, can_set_sample_limit) + } + + if (check_has_estimation_type) { + all_data_elements <- intersect(all_data_elements, can_set_estimation_type) + } + + if (check_has_detail_level) { + all_data_elements <- intersect(all_data_elements, can_set_detail_level) + } + + if (check_from_prediction_table) { + all_data_elements <- intersect(all_data_elements, can_use_prediction_table) + } + + if (check_from_data_object) { + all_data_elements <- intersect(all_data_elements, can_use_data_object) + } + + return(all_data_elements) +} + + + +.parse_detail_level <- function( + x, + object, + default, + data_element) { + + if (is.waive(x)) x <- object@settings$detail_level + + if (is.null(x)) return(default) + + # detail level is stored in a list, by data_element. + if (is.list(x)) x <- x[[data_element]] + + if (is.null(x)) return(default) + + .check_parameter_value_is_valid( + x = x, + var_name = "detail_level", + values = c("ensemble", "hybrid", "model") + ) + + return(x) +} + + + +.parse_estimation_type <- function( + x, + object, + default, + data_element, + detail_level, + has_internal_bootstrap +) { + + # Change to default to point if the detail_level is model. + if (detail_level == "model") default <- "point" + + # In case there is no internal bootstrap, we can only determine point + # estimates for ensemble and model detail levels (but potentially more for + # hybrid). + if ( + !has_internal_bootstrap && + detail_level %in% c("ensemble", "model") && + default != "point" + ) { + default <- "point" + } + + if (is.waive(x) && .hasSlot(object, "settings")) x <- object@settings$estimation_type + + if (is.null(x)) return(default) + + # detail level is stored in a list, by data_element. + if (is.list(x)) x <- x[[data_element]] + + if (is.null(x)) return(default) + + .check_parameter_value_is_valid( + x = x, + var_name = "estimation_type", + values = c( + "point", "bias_correction", "bc", + "bootstrap_confidence_interval", "bci" + ) + ) + + return(x) +} + + + +.parse_aggregate_results <- function( + x, + object, + default, + data_element) { + + if (is.waive(x) && methods::.hasSlot(object, "settings")) { + x <- object@settings$aggregate_results + + } else if (is.waive(x)) { + return(default) + } + + if (is.null(x)) return(default) + + # detail level is stored in a list, by data_element. + if (is.list(x)) x <- x[[data_element]] + + if (is.null(x)) return(default) + + x <- tolower(x) + .check_parameter_value_is_valid( + x = x, + var_name = "aggregate_results", + values = c("true", "false", "none", "all", "default") + ) + + if (x == "default") return(default) + if (x %in% c("true", "all")) return(TRUE) + + return(FALSE) +} + + + +.parse_sample_limit <- function( + x, + object, + default, + data_element +) { + if (is.waive(x) && .hasSlot(object, "settings")) x <- object@settings$sample_limit + + if (is.null(x)) return(default) + + # detail level is stored in a list, by data_element. + if (is.list(x)) x <- x[[data_element]] + + if (is.null(x)) return(default) + + if (x == "default") return(default) + + .check_number_in_valid_range( + x = x, + var_name = "sample_limit", + range = c(20L, Inf) + ) + + return(x) +} + + + +.parse_n_important_features <- function( + x, + object, + default, + data_element +) { + if (is.waive(x)) x <- object@settings$n_important_features + + if (is.null(x)) return(default) + + # detail level is stored in a list, by data_element. + if (is.list(x)) x <- x[[data_element]] + + if (is.null(x)) return(default) + + if (x == "default") return(default) + + .check_number_in_valid_range( + x = x, + var_name = "n_important_features", + range = c(1L, Inf) + ) + + return(x) +} + + + +.select_important_features <- function( + object, + data, + fallback_vimp_method = "mim", + n_important_features = Inf +) { + # Suppress NOTES due to non-standard evaluation in data.table + name <- rank <- NULL + + if (!(is(object, "familiarModel") || is(object, "familiarNoveltyDetector") || is(object, "familiarEnsemble"))) { + ..error_reached_unreachable_code(paste0("invalid object class: ", class(object))) + } + + # Check that the model has any features, i.e. is not naive. + if (object@vimp_method %in% .get_available_no_features_vimp_methods()) return(NULL) + if (length(object@model_features) == 0L) return(NULL) + + if (is(object, "familiarEnsemble")) { + # Make sure that models are loaded: + object <- load_models(object, suppress_auto_detach = TRUE) + if (!model_is_trained(object)) return(NULL) + + vimp_table <- lapply(object@model_list, function(x) (x@vimp_table)) + vimp_aggregation_method <- object@model_list[[1L]]@vimp_aggregation_method + vimp_rank_threshold <- object@model_list[[1L]]@vimp_rank_threshold + + } else { + if (!model_is_trained(object)) return(NULL) + + vimp_table <- object@vimp_table + vimp_aggregation_methpd <- object@vimp_aggregation_method + vimp_rank_threshold <- object@vimp_rank_threshold + } + + # Flatten lists, if necessary. + if (rlang::is_bare_list(vimp_table)) { + vimp_table <- unlist(vimp_table) + } + + # Get available features for the model or ensemble. + features <- features_after_clustering( + features = object@model_features, + feature_info_list = object@feature_info + ) + if (length(features) <= n_important_features) return(features) + + # Determine which features are pre-assigned to the signature. + signature_features <- names(object@feature_info)[sapply(object@feature_info, is_in_signature)] + + # Check that fallback is required: in case of none, random, or no features + # being selected. + use_fallback <- object@vimp_method %in% c( + .get_available_none_vimp_methods(), + .get_available_random_vimp_methods() + ) + + # Check that fallback is required: in case there is no variable importance + # table. + if (!use_fallback) { + if (rlang::is_bare_list(vimp_table)) { + use_fallback <- all(sapply(vimp_table, is_empty)) + } else { + use_fallback <- is_empty(vimp_table) + } + } + + # If signature is used, don't use fall-back option. + if (object@vimp_method %in% .get_available_signature_only_vimp_methods()) use_fallback <- FALSE + + # Set-up fallback vimp-table + if (use_fallback) { + # Spawn task to obtain variable importance tables. + vimp_task <- methods::new( + "familiarTaskVimp", + project_id = object@project_id, + vimp_method = fallback_vimp_method, + data_id = object@data_id, + run_id = object@run_id, + file = NA_character_ + ) + + # Fill details required to get the data, in case the data is delayed. + # Note that training data is used for obtaining variable importance. + if (is(data, "delayedDataObject")) { + data@data_id <- object@data_id + data@run_id <- object@run_id + } + + # Create variable importance table. + vimp_table <- .perform_task( + object = vimp_task, + feature_info_list = object@feature_info, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + data = data + ) + } + + # For signature-only, return all signature features, with no preference. + 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" + ) + } + + return(signature_features) + } + + # Select signature and any additional features according to rank. + selected_features <- signature_features + + # Get number remaining available features + n_allowed_features <- n_important_features - length(signature_features) + + # Check that features may be added, and the rank table is not empty. + if (n_allowed_features > 0L && !is_empty(vimp_table)) { + + # 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 = 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 = vimp_aggregation_method, + rank_threshold = 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 + ) + } + + if (length(selected_features) == 0L) return(NULL) + + return(selected_features) +} diff --git a/R/FamiliarDataComputationVimp.R b/R/FamiliarDataComputationVimp.R index dade192d..25ba56c9 100644 --- a/R/FamiliarDataComputationVimp.R +++ b/R/FamiliarDataComputationVimp.R @@ -9,12 +9,15 @@ setClass( contains = "familiarDataElement", slots = list( "rank_threshold" = "numeric", - "rank_aggregation_method" = "character"), + "rank_aggregation_method" = "character" + ), prototype = methods::prototype( detail_level = "hybrid", estimation_type = "point", rank_threshold = NA_real_, - rank_aggregation_method = NA_character_)) + rank_aggregation_method = NA_character_ + ) +) @@ -25,7 +28,7 @@ setClass( #'@description Aggregate variable importance from models in a #' `familiarEnsemble`. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list containing variable importance information. #'@md @@ -39,7 +42,8 @@ setGeneric( rank_threshold = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_model_vimp") } ) @@ -57,20 +61,22 @@ setMethod( rank_threshold = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # Message extraction start logger_message( paste0("Extracting variable importance obtained from the models."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Test if models are properly loaded if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() # Obtain aggregation method from stored settings, if required. if (is.waive(aggregation_method)) { - if (length(object@model_list) > 1) { + if (length(object@model_list) > 1L) { aggregation_method <- object@settings$aggregation } else { @@ -83,7 +89,8 @@ setMethod( .check_parameter_value_is_valid( x = aggregation_method, var_name = "aggregation_method", - values = .get_available_rank_aggregation_methods()) + values = .get_available_rank_aggregation_methods() + ) # Obtain rank thresholds from stored settings, if required if (is.waive(rank_threshold)) rank_threshold <- object@settings$aggr_rank_threshold @@ -93,14 +100,16 @@ setMethod( .check_number_in_valid_range( x = rank_threshold, var_name = "rank_threshold", - range = c(1, Inf)) + range = c(1L, Inf) + ) } # Generate a prototype data element proto_data_element <- methods::new( "familiarDataElementVimpData", rank_threshold = rank_threshold, - rank_aggregation_method = aggregation_method) + rank_aggregation_method = aggregation_method + ) # Generate elements to send to dispatch. vimp_info <- extract_dispatcher( @@ -113,7 +122,8 @@ setMethod( aggregation_method = aggregation_method, aggregate_results = FALSE, message_indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) return(vimp_info) } @@ -121,11 +131,25 @@ setMethod( +# extract_model_vimp (prediction table) ---------------------------------------- +setMethod( + "extract_model_vimp", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("model-based variable importance") + + return(NULL) + } +) + + + .extract_model_vimp <- function( object, data, proto_data_element, - ...) { + ... +) { # Ensure that the object is loaded object <- load_familiar_object(object) @@ -137,7 +161,8 @@ setMethod( vimp_table <- get_vimp_table( x = object, data = data, - as_object = TRUE) + as_object = TRUE + ) # Check that the variable importance table is not empty. if (is_empty(vimp_table)) return(NULL) @@ -159,7 +184,7 @@ setMethod( #' This information can only be obtained as part of the main `summon_familiar` #' process. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@return A list containing feature selection variable importance information. #'@md @@ -172,7 +197,8 @@ setGeneric( rank_threshold = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { standardGeneric("extract_fs_vimp") } ) @@ -188,7 +214,8 @@ setMethod( rank_threshold = waiver(), message_indent = 0L, verbose = FALSE, - ...) { + ... + ) { # Test if models are properly loaded if (!is_model_loaded(object = object)) ..error_ensemble_models_not_loaded() @@ -202,7 +229,8 @@ setMethod( .check_parameter_value_is_valid( x = aggregation_method, var_name = "aggregation_method", - values = .get_available_rank_aggregation_methods()) + values = .get_available_rank_aggregation_methods() + ) # Obtain rank thresholds from stored settings, if required if (is.waive(rank_threshold)) { @@ -214,41 +242,33 @@ setMethod( .check_number_in_valid_range( x = rank_threshold, var_name = "rank_threshold", - range = c(1, Inf)) + range = c(1L, Inf) + ) } - # Load project list and file_paths - file_paths <- tryCatch(get_file_paths(), error = identity) - project_list <- tryCatch(get_project_list(), error = identity) - - if (inherits(file_paths, "error") || inherits(project_list, "error")) return(NULL) - - # Message extraction start - logger_message( - paste0("Extracting variable importance obtained during feature selection."), - indent = message_indent, - verbose = verbose) - - # Retrieve variable importance table objects. - vimp_table_list <- .retrieve_feature_selection_data( - fs_method = object@fs_method, - project_list = project_list, - file_paths = file_paths)[[object@fs_method]] - - # Define the run table -> at the pooling level - run <- .get_run_list( - iteration_list = project_list$iter_list, - data_id = object@run_table$ensemble_data_id, - run_id = object@run_table$ensemble_run_id) - - # Collect the correct vimp tables from the full list. - vimp_table_list <- collect_vimp_table( - x = vimp_table_list, - run_table = run$run_table) - - # Check if the variable importance table has been set. - if (is_empty(vimp_table_list)) return(NULL) - if (all(sapply(vimp_table_list, is_empty))) return(NULL) + # Extract variable importance tables from models. + vimp_table_list <- unlist( + lapply( + object@model_list, + function(x) { + x <- load_familiar_object(x) + return(x@vimp_table) + } + ), + use.names = FALSE + ) + if (!rlang::is_bare_list(vimp_table_list)) vimp_table_list <- list(vimp_table_list) + + # Remove missing entries. + vimp_table_list <- vimp_table_list[sapply(vimp_table_list, is, class2 = "vimpTable")] + if (length(vimp_table_list) == 0L) return(NULL) + + # Select only non-duplicate variable importance tables. + table_identifiers <- sapply( + vimp_table_list, + function(x) paste(x@project_id, x@data_id, x@run_id, x@vimp_method, sep = "_") + ) + vimp_table_list <- vimp_table_list[!duplicated(table_identifiers)] # Create list of data elements. data_element_list <- lapply( @@ -258,10 +278,12 @@ setMethod( "familiarDataElementVimpData", data = x, rank_threshold = rank_threshold, - rank_aggregation_method = aggregation_method)) + rank_aggregation_method = aggregation_method + )) }, rank_threshold = rank_threshold, - aggregation_method = aggregation_method) + aggregation_method = aggregation_method + ) # Merge data elements data_element <- merge_data_elements(data_element_list) @@ -271,6 +293,19 @@ setMethod( ) +# extract_fs_vimp (prediction table) ------------------------------------------- +setMethod( + "extract_fs_vimp", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + ..warning_no_data_extraction_from_prediction_table("variable importance") + + return(NULL) + } +) + + + # merge_data_elements (familiarDataElementVimpData) ---------------------------- setMethod( "merge_data_elements", @@ -278,7 +313,8 @@ setMethod( function( x, x_list, - ...) { + ... + ) { # Identify items that can be joined. id_table <- identify_element_sets(x = x_list, ...) @@ -286,7 +322,8 @@ setMethod( # Identify the element identifiers that should be grouped. grouped_data_element_ids <- lapply( split(id_table[, c("element_id", "group_id")], by = "group_id"), - function(id_table) (id_table$element_id)) + function(id_table) (id_table$element_id) + ) # List of data elements. data_elements <- list() @@ -294,21 +331,23 @@ setMethod( for (current_group_data_element_ids in grouped_data_element_ids) { # Copy the first data element in the group and use it as a # prototype. - prototype_data_element <- x_list[[current_group_data_element_ids[1]]] + prototype_data_element <- x_list[[current_group_data_element_ids[1L]]] if (any(sapply(x_list[current_group_data_element_ids], function(x) (is(x@data, "vimpTable"))))) { # Data attribute contains a variable importance table object. data_attribute <- lapply( x_list[current_group_data_element_ids], - function(x) (x@data)) + function(x) (x@data) + ) # Set data attribute. prototype_data_element@data <- data_attribute - } else if (length(current_group_data_element_ids) != 1) { + } else if (length(current_group_data_element_ids) != 1L) { ..error_reached_unreachable_code( - "merge_data_elements,familiarDataElementVimpData: exactly one element is expected") + "merge_data_elements,familiarDataElementVimpData: exactly one element is expected." + ) } # Add merged data element to the list. @@ -328,7 +367,8 @@ setMethod( function( x, x_list = NULL, - ...) { + ... + ) { # It might be that x was only used to direct to this method. if (!is.null(x_list)) x <- x_list @@ -344,11 +384,12 @@ setMethod( # Aggregate list of vimp tables. vimp_object <- aggregate_vimp_table( x = vimp_table_list, - aggregation_method = x[[1]]@rank_aggregation_method, - rank_threshold = x[[1]]@rank_threshold) + aggregation_method = x[[1L]]@rank_aggregation_method, + rank_threshold = x[[1L]]@rank_threshold + ) # Copy data element. - y <- x[[1]] + y <- x[[1L]] y@data <- vimp_object return(y) @@ -365,7 +406,8 @@ setMethod( x, x_list, aggregate_results = FALSE, - ...) { + ... + ) { if (aggregate_results) { x_list <- .compute_data_element_estimates(x_list) @@ -379,7 +421,7 @@ setMethod( vimp_table <- data.table::rbindlist(vimp_table, use.names = TRUE) # Form prototype. - x <- x_list[[1]] + x <- x_list[[1L]] x@data <- vimp_table return(x) @@ -417,7 +459,8 @@ setMethod( x <- .identifier_as_data_attribute( x = x, identifier = "all", - as_grouping_column = TRUE) + as_grouping_column = TRUE + ) return(x) } @@ -520,7 +563,8 @@ setGeneric( aggregation_method = waiver(), rank_threshold = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_model_vimp") } ) @@ -540,7 +584,8 @@ setMethod( aggregation_method = waiver(), rank_threshold = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Extract data. x <- object@model_vimp @@ -553,7 +598,8 @@ setMethod( .check_parameter_value_is_valid( x = aggregation_method, var_name = "aggregation_method", - values = .get_available_rank_aggregation_methods()) + values = .get_available_rank_aggregation_methods() + ) # Set aggregation method. x <- lapply( @@ -562,7 +608,8 @@ setMethod( x@rank_aggregation_method <- aggregation_method return(x) }, - aggregation_method = aggregation_method) + aggregation_method = aggregation_method + ) } if (!is.waive(rank_threshold)) { @@ -570,7 +617,8 @@ setMethod( .check_number_in_valid_range( x = rank_threshold, var_name = "rank_threshold", - range = c(1, Inf)) + range = c(1L, Inf) + ) # Set threshold. x <- lapply( @@ -579,10 +627,11 @@ setMethod( x@rank_threshold <- rank_threshold return(x) }, - rank_threshold = rank_threshold) + rank_threshold = rank_threshold + ) } - subtype <- paste("learner", x[[1]]@rank_aggregation_method, sep = "_") + subtype <- paste("learner", x[[1L]]@rank_aggregation_method, sep = "_") return(.export( x = object, @@ -591,7 +640,8 @@ setMethod( aggregate_results = aggregate_results, type = "variable_importance", subtype = subtype, - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -610,7 +660,8 @@ setMethod( aggregation_method = waiver(), rank_threshold = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. Note that we pass # on aggregation_method and rank_threshold values. @@ -621,8 +672,11 @@ setMethod( "object" = object, "data_element" = "model_vimp", "aggregation_method" = aggregation_method, - "rank_threshold" = rank_threshold), - list(...))) + "rank_threshold" = rank_threshold + ), + list(...) + ) + ) return(do.call( export_model_vimp, @@ -633,8 +687,11 @@ setMethod( "aggregate_results" = aggregate_results, "aggregation_method" = aggregation_method, "rank_threshold" = rank_threshold, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -735,7 +792,8 @@ setGeneric( aggregation_method = waiver(), rank_threshold = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("export_fs_vimp") } ) @@ -755,7 +813,8 @@ setMethod( aggregation_method = waiver(), rank_threshold = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Extract data. x <- object@fs_vimp @@ -768,7 +827,8 @@ setMethod( .check_parameter_value_is_valid( x = aggregation_method, var_name = "aggregation_method", - values = .get_available_rank_aggregation_methods()) + values = .get_available_rank_aggregation_methods() + ) # Set aggregation method. x <- lapply( @@ -777,7 +837,8 @@ setMethod( x@rank_aggregation_method <- aggregation_method return(x) }, - aggregation_method = aggregation_method) + aggregation_method = aggregation_method + ) } if (!is.waive(rank_threshold)) { @@ -785,7 +846,8 @@ setMethod( .check_number_in_valid_range( x = rank_threshold, var_name = "rank_threshold", - range = c(1, Inf)) + range = c(1L, Inf) + ) # Set threshold. x <- lapply( @@ -794,11 +856,12 @@ setMethod( x@rank_threshold <- rank_threshold return(x) }, - rank_threshold = rank_threshold) + rank_threshold = rank_threshold + ) } # Get subtype - subtype <- paste("feature_selection", x[[1]]@rank_aggregation_method, sep = "_") + subtype <- paste("feature_selection", x[[1L]]@rank_aggregation_method, sep = "_") return(.export( x = object, @@ -807,7 +870,8 @@ setMethod( aggregate_results = aggregate_results, type = "variable_importance", subtype = subtype, - export_collection = export_collection)) + export_collection = export_collection + )) } ) @@ -825,7 +889,8 @@ setMethod( aggregation_method = waiver(), rank_threshold = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. Note that we pass on # aggregation_method and rank_threshold values. @@ -836,8 +901,11 @@ setMethod( "object" = object, "data_element" = "fs_vimp", "aggregation_method" = aggregation_method, - "rank_threshold" = rank_threshold), - list(...))) + "rank_threshold" = rank_threshold + ), + list(...) + ) + ) return(do.call( export_fs_vimp, @@ -848,7 +916,10 @@ setMethod( "aggregate_results" = aggregate_results, "aggregation_method" = aggregation_method, "rank_threshold" = rank_threshold, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) diff --git a/R/FamiliarDataElement.R b/R/FamiliarDataElement.R index 52da5737..b4cfdc8a 100644 --- a/R/FamiliarDataElement.R +++ b/R/FamiliarDataElement.R @@ -28,9 +28,10 @@ setMethod( # Get dots, which contains the identifier to be set. dots <- list(...) - if (length(dots) > 1) { + if (length(dots) > 1L) { ..error_reached_unreachable_code( - "add_data_element_identifier: can only add one identifier at a time.") + "add_data_element_identifier: can only add one identifier at a time." + ) } # Find the name of the identifier. @@ -54,7 +55,8 @@ setMethod( return(x) }, x = x, - identifier_name = identifier_name) + identifier_name = identifier_name + ) return(data_elements) } @@ -83,9 +85,10 @@ setMethod( n_bootstraps, n_instances, bootstrap_seed_offset, - ...) { + ... + ) { - if (n_bootstraps > 0) { + if (n_bootstraps > 0L) { # Repeat elements. data_element <- rep(x, each = n_bootstraps) @@ -98,9 +101,10 @@ setMethod( # Iterate over elements to check whether a point estimate should # be computed in addition. for (current_element in x) { - if (current_element@detail_level %in% c("ensemble", "model") && - current_element@estimation_type %in% c("bci", "bootstrap_confidence_interval")) { - + if ( + current_element@detail_level %in% c("ensemble", "model") && + current_element@estimation_type %in% c("bci", "bootstrap_confidence_interval") + ) { # Add a new element that estimates the point estimate. new_element <- current_element new_element@estimation_type <- "point" @@ -108,7 +112,7 @@ setMethod( # Add the element to the list of elements. data_element <- c(data_element, new_element) bootstrap <- c(bootstrap, FALSE) - bootstrap_seed <- c(bootstrap_seed, NA) + bootstrap_seed <- c(bootstrap_seed, NA_integer_) } } @@ -120,13 +124,14 @@ setMethod( bootstrap <- rep(FALSE, times = length(x)) # No seed is set - bootstrap_seed <- rep(NA, times = length(x)) + bootstrap_seed <- rep(NA_integer_, times = length(x)) } return(list( "data_element" = data_element, "bootstrap" = bootstrap, - "seed" = bootstrap_seed)) + "seed" = bootstrap_seed + )) } ) @@ -151,11 +156,13 @@ setMethod( function( x, identifier, - as_grouping_column = TRUE) { + as_grouping_column = TRUE + ) { - if (length(identifier) == 0) { + if (length(identifier) == 0L) { ..error_reached_unreachable_code( - ".identifier_as_data_attribute: Cannot pass an empty identifier.") + ".identifier_as_data_attribute: Cannot pass an empty identifier." + ) } # If an "all" value is passed (e.g. during export), all identifiers are @@ -165,7 +172,7 @@ setMethod( # Determine which of the identifiers is actually present. If none are # present, return x. identifier_present <- intersect(identifier, names(x@identifiers)) - if (length(identifier_present) == 0) return(x) + if (length(identifier_present) == 0L) return(x) if (as_grouping_column) { x@grouping_column <- unique(c(x@grouping_column, identifier_present)) @@ -192,17 +199,19 @@ setMethod( data.table::set( x = x@data, j = id_name, - value = identifier_values[[id_name]]) + value = identifier_values[[id_name]] + ) } } else if (is.list(x@data)) { # Determine the number of instances in x@data - n_instances <- length(x@data[[1]]) + n_instances <- length(x@data[[1L]]) new_data <- lapply( identifier_values, function(x, n) (rep(x, times = n)), - n = n_instances) + n = n_instances + ) names(new_data) <- names(identifier_values) # Add identifiers to the list. @@ -236,19 +245,21 @@ setMethod( x = x, ii = seq_along(x), MoreArgs = list(...), - SIMPLIFY = FALSE) + SIMPLIFY = FALSE + ) # Combine to table and add group ids and model ids. - id_table <- data.table::rbindlist(id_table, use.names = TRUE) + id_table <- data.table::rbindlist(id_table, use.names = TRUE, fill = TRUE) # Drop identifiers. if (!is.null(drop_identiers)) { # Check that if (!all(drop_identiers %in% colnames(id_table))) { - stop(paste0( + ..error(paste0( "One or more identifiers to be dropped were not found in the table with identifiers: ", - paste_s(setdiff(drop_identiers, colnames(id_table))))) + paste_s(setdiff(drop_identiers, colnames(id_table))) + )) } # Drop identifiers @@ -280,14 +291,17 @@ setMethod( ignore_estimation_type = FALSE, ignore_grouping_column = TRUE, ignore_list_identifier = TRUE, - ...) { + ... + ) { # Get the identifiers and the detail level and combine to a list. id_list <- c( x@identifiers, list( "detail_level" = x@detail_level, - "object_class" = class(x)[1])) + "object_class" = class(x)[1L] + ) + ) # Add the estimation type if it is not to be ignored. if (!ignore_estimation_type) { @@ -329,7 +343,8 @@ setMethod( signature(x = "list"), function( x, - ...) { + ... + ) { # Check that the list is not empty. if (is_empty(x)) return(NULL) @@ -355,8 +370,10 @@ setMethod( # Create a proto data element to avoid having to pass larger objects # than required. - proto_data_element <- x[which(element_classes == element_class)][[1]] - proto_data_element@data <- NULL + proto_data_element <- x[which(element_classes == element_class)][[1L]] + if (methods::.hasSlot(proto_data_element, "data")) { + proto_data_element@data <- NULL + } # Run familiarDataElement-specific analysis. This means that we pass # the prototype data element as x with the list of elements. @@ -365,7 +382,9 @@ setMethod( merge_data_elements( x = proto_data_element, x_list = x[which(element_classes == element_class)], - ...)) + ... + ) + ) } # Assign a NULL to empty data @@ -387,7 +406,8 @@ setMethod( as_data = NULL, as_grouping_column = TRUE, force_data_table = FALSE, - ...) { + ... + ) { # Move identifiers from the identifiers attribute to the data attribute. The # primary reason for doing so is to group and merge similar elements, byt @@ -397,7 +417,8 @@ setMethod( x_list, .identifier_as_data_attribute, identifier = as_data, - as_grouping_column = as_grouping_column) + as_grouping_column = as_grouping_column + ) } # Identify items that can be joined. @@ -406,39 +427,46 @@ setMethod( # Identify the element identifiers that should be grouped. grouped_data_element_ids <- lapply( split(id_table[, c("element_id", "group_id")], by = "group_id"), - function(id_table) (id_table$element_id)) + function(id_table) (id_table$element_id) + ) # List of data elements. data_elements <- list() for (current_group_data_element_ids in grouped_data_element_ids) { # Copy the first data element in the group and use it as a prototype. - prototype_data_element <- x_list[[current_group_data_element_ids[1]]] + prototype_data_element <- x_list[[current_group_data_element_ids[1L]]] # Check contents of the data elements. any_is_data_table <- any(sapply( x_list[current_group_data_element_ids], - function(x) (data.table::is.data.table(x@data)))) + function(x) (data.table::is.data.table(x@data)) + )) any_is_list <- any(sapply( x_list[current_group_data_element_ids], - function(x) (rlang::is_bare_list(x@data)))) + function(x) (rlang::is_bare_list(x@data)) + )) all_is_empty <- all(sapply( x_list[current_group_data_element_ids], - function(x) (is_empty(x@data)))) + function(x) (is_empty(x@data)) + )) if (any_is_data_table) { # Data attribute contains data.table. data_attribute <- lapply( x_list[current_group_data_element_ids], - function(x) (x@data)) + function(x) (x@data) + ) # Combine data attributes. data_attribute <- suppressWarnings( data.table::rbindlist( data_attribute, use.names = TRUE, - fill = TRUE)) + fill = TRUE + ) + ) # Set data attribute. prototype_data_element@data <- data_attribute @@ -448,7 +476,8 @@ setMethod( # Data attribute contains data.table. element_names <- unique(unlist(lapply( x_list[current_group_data_element_ids], - function(x) (names(x@data))))) + function(x) (names(x@data)) + ))) # Iterate over different names in the list. data_attribute <- lapply( @@ -458,11 +487,13 @@ setMethod( element_values <- unlist(lapply( x, function(x, ii) (x@data[[ii]]), - ii = ii)) + ii = ii + )) return(element_values) }, - x = x_list[current_group_data_element_ids]) + x = x_list[current_group_data_element_ids] + ) # Set names. names(data_attribute) <- element_names @@ -482,7 +513,8 @@ setMethod( # Unknown data type. ..error_reached_unreachable_code(paste0( "merge_data_elements,familiarDataElement: data attribute is neither ", - "data.table, list, or empty.")) + "data.table, list, or empty." + )) } # Add merged data element to the list. @@ -515,15 +547,17 @@ setMethod( function( x, data_slot, - identifiers = c("data_set", "fs_method", "learner"), - ...) { + identifiers = c("data_set", "vimp_method", "learner"), + ... + ) { # Collect from all collected_data_elements <- lapply( x, collect, data_slot = data_slot, - identifiers = identifiers) + identifiers = identifiers + ) # Flatten (nested) lists. collected_data_elements <- unlist(collected_data_elements) @@ -540,7 +574,8 @@ setMethod( # Identify the first element id in each group. unique_elements <- sapply( split(id_table, by = "group_id"), - function(x) (head(x$element_id, n = 1L))) + function(x) (head(x$element_id, n = 1L)) + ) # Keep unique elements. collected_data_elements <- collected_data_elements[unique_elements] @@ -566,19 +601,22 @@ setMethod( if ("data_set" %in% identifiers) { collected_data_elements <- add_data_element_identifier( x = collected_data_elements, - data_set = x@name) + data_set = x@name + ) } - if ("fs_method" %in% identifiers) { + if ("vimp_method" %in% identifiers) { collected_data_elements <- add_data_element_identifier( x = collected_data_elements, - fs_method = x@fs_method) + vimp_method = x@vimp_method + ) } if ("learner" %in% identifiers) { collected_data_elements <- add_data_element_identifier( x = collected_data_elements, - learner = x@learner) + learner = x@learner + ) } return(collected_data_elements) @@ -602,7 +640,8 @@ setMethod( subtype = NULL, object_class = NULL, export_collection = FALSE, - ...) { + ... + ) { # Obtain the data elements from the attribute slot indicated by data_slot. if (!is.null(data_slot)) data_elements <- slot(x, name = data_slot) @@ -628,26 +667,28 @@ setMethod( if (!is.null(object_class)) { # Keep data elements that correspond data_elements <- data_elements[element_classes == object_class] - if (is_empty(data_elements)) return(NULL) - } else if (data.table::uniqueN(element_classes) > 2) { + } else if (data.table::uniqueN(element_classes) > 2L) { ..error_reached_unreachable_code(paste0( ".export,familiarCollection: multiple data elements with different ", - "classes found, whereas only one is expected.")) + "classes found, whereas only one is expected." + )) } # Merge and aggregate data. Note that the method is dispatched based on the # first object. data_element <- .export( - x = data_elements[[1]], + x = data_elements[[1L]], x_list = data_elements, - ...) + ... + ) # Apply labels. data_element <- .apply_labels( data = data_element, - object = x) + object = x + ) # Check that the data variable is not empty if (is_empty(data_element)) return(NULL) @@ -657,7 +698,8 @@ setMethod( if (export_collection) { return(list( "collection" = x, - "data" = data_element)) + "data" = data_element + )) } else { return(data_element) @@ -670,7 +712,8 @@ setMethod( object = x, dir_path = dir_path, type = type, - subtype = subtype) + subtype = subtype + ) if (export_collection) { return(list("collection" = x)) @@ -699,15 +742,63 @@ setMethod( x = x_list, as_data = "all", as_grouping_column = TRUE, - force_data_table = TRUE) + force_data_table = TRUE + ) return(x) } ) +# .copy (familiarDataElement) -------------------------------------------------- +setMethod( + ".copy", + signature(object = "familiarDataElement"), + function(object) { + slots_present <- methods::slotNames(object) + + for (current_slot in slots_present) { + # Make deepcopy of data.tables present in the dataset. + if (data.table::is.data.table(methods::slot(object, current_slot))) { + methods::slot(object, current_slot) <- data.table::copy(methods::slot(object, current_slot)) + } + } + + return(object) + } +) + + +# .copy (dataObject) ----------------------------------------------------------- +setMethod( + ".copy", + signature(object = "dataObject"), + function(object) { + slots_present <- methods::slotNames(object) + + for (current_slot in slots_present) { + # Make deepcopy of data.tables present in the dataset. + if (data.table::is.data.table(methods::slot(object, current_slot))) { + methods::slot(object, current_slot) <- data.table::copy(methods::slot(object, current_slot)) + } + } + + return(object) + } +) + + +# .copy (null) ----------------------------------------------------------------- +setMethod( + ".copy", + signature(object = "NULL"), + function(object) { + return(object) + } +) + -# extract_dispatcher ----------------------------------------------------------- +# extract_dispatcher (familiarEnsemble) ---------------------------------------- #'@title Internal function to dispatch extraction functions. #' @@ -725,7 +816,7 @@ setMethod( #'@param has_internal_bootstrap A logical flag that indicates whether `FUN` has #' internal bootstrapping capabilities. #' -#'@inheritParams extract_data +#'@inheritParams .extract_data #' #'@details This function first determines how many data points need to be #' evaluated to complete the desired estimation, i.e. 1 for point estimates, 20 @@ -744,7 +835,8 @@ setMethod( "extract_dispatcher", signature( object = "familiarEnsemble", - proto_data_element = "familiarDataElement"), + proto_data_element = "familiarDataElement" + ), function( cl = NULL, FUN, @@ -754,7 +846,8 @@ setMethod( has_internal_bootstrap, ..., message_indent = 0L, - verbose = TRUE) { + verbose = TRUE + ) { # Check that any models were trained. if (!model_is_trained(object)) return(NULL) @@ -767,7 +860,7 @@ setMethod( n_instances <- 20L } else if (proto_data_element@estimation_type %in% c("bootstrap_confidence_interval", "bci")) { - n_instances <- ceiling(signif(20 / (1.00 - proto_data_element@confidence_level))) + n_instances <- as.integer(ceiling(signif(20.0 / (1.00 - proto_data_element@confidence_level)))) } # Determine the number of models we need to evaluate. @@ -779,17 +872,19 @@ setMethod( } # Check if the proposed analysis can be executed. - if (!has_internal_bootstrap && - n_instances > 1L && - !(proto_data_element@detail_level == "hybrid" && - n_models >= n_instances)) { + if ( + !has_internal_bootstrap && + n_instances > 1L && + !(proto_data_element@detail_level == "hybrid" && n_models >= n_instances) + ) { # The required number of instances cannot be created from models alone. # Add a message if (verbose) { message(paste0( "extract_dispatcher,familiarEnsemble,familiarDataElement: ", - "too few models to compute confidence intervals.")) + "too few models to compute confidence intervals." + )) } # Set the detail level to ensemble. @@ -827,13 +922,13 @@ setMethod( # Determine whether we should perform parallel processing across # models or internally. - if (n_nodes > 1) { - if (n_models == 1) { + if (n_nodes > 1L) { + if (n_models == 1L) { # No need to perform parallelisation across models, when there is only 1 # model. parallel_external <- FALSE - } else if (n_bootstraps == 0) { + } else if (n_bootstraps == 0L) { # No need to perform internal parallelisation in case this is not # necessary. This check is hit when has_internal_bootstrap is false. parallel_external <- TRUE @@ -872,7 +967,8 @@ setMethod( n_nodes = n_nodes, parallel_external = parallel_external, message_indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Dispatch for ensemble models. if (proto_data_element@detail_level == "ensemble") { @@ -889,7 +985,8 @@ setMethod( parallel_external = parallel_external, message_indent = message_indent, verbose = verbose, - ...) + ... + ) } else if (proto_data_element@detail_level == "hybrid") { # Dispatch for results aggregated with hybrid details. @@ -905,7 +1002,8 @@ setMethod( parallel_external = parallel_external, message_indent = message_indent, verbose = verbose, - ...) + ... + ) } else if (proto_data_element@detail_level == "model") { # Dispatch for results aggregated at the model level. @@ -921,12 +1019,14 @@ setMethod( parallel_external = parallel_external, message_indent = message_indent, verbose = verbose, - ...) + ... + ) } else { ..error_reached_unreachable_code(paste0( "extract_dispatcher: encountered an unknown detail_level attribute: ", - proto_data_element@detail_level)) + proto_data_element@detail_level + )) } return(x) @@ -934,6 +1034,250 @@ setMethod( ) +# extract_dispatcher (familiarDataElementPredictionTable) ---------------------- +setMethod( + "extract_dispatcher", + signature( + object = "familiarDataElementPredictionTable", + proto_data_element = "familiarDataElement" + ), + function( + cl = NULL, + FUN, + object, + proto_data_element, + aggregate_results, + has_internal_bootstrap, + ..., + message_indent = 0L, + verbose = TRUE + ) { + + # Determine the number of instances we need to find the estimates. + if (proto_data_element@estimation_type == "point") { + n_instances <- 1L + + } else if (proto_data_element@estimation_type %in% c("bias_correction", "bc")) { + n_instances <- 20L + + } else if (proto_data_element@estimation_type %in% c("bootstrap_confidence_interval", "bci")) { + n_instances <- as.integer(ceiling(signif(20.0 / (1.00 - proto_data_element@confidence_level)))) + } + + # Determine the number of models we need to evaluate. For prediction tables, + # this is always 1. + n_models <- 1L + + # Check if the proposed analysis can be executed. + if ( + !has_internal_bootstrap && n_instances > 1L && + !(proto_data_element@detail_level == "hybrid" && n_models >= n_instances) + ) { + # The required number of instances cannot be created from models alone. + + # Add a message + if (verbose) { + message(paste0( + "extract_dispatcher,familiarDataElementPredictionTable,familiarDataElement: ", + "too few models to compute confidence intervals." + )) + } + + # Set the detail level to ensemble. + if (proto_data_element@detail_level == "hybrid") { + # Only one ensemble model is formed. + proto_data_element@detail_level <- "ensemble" + n_models <- 1L + } + + # Set the estimation type to point estimates. + proto_data_element@estimation_type <- "point" + n_instances <- 1L + } + + # Determine the number of bootstraps that should be computed internally. + if (has_internal_bootstrap) { + if (proto_data_element@detail_level == "hybrid") { + n_bootstraps <- ceiling(n_instances / n_models) + n_instances <- n_models * n_bootstraps + + } else { + n_bootstraps <- n_instances + } + + } else { + n_bootstraps <- 0L + } + + # If one bootstrap is required, that means no bootstraps are required. + if (n_bootstraps <= 1L) n_bootstraps <- 0L + + + # Determine the number of parallel cluster nodes. + n_nodes <- length(cl) + + # Determine whether we should perform parallel processing across + # models or internally. + if (n_nodes > 1L) { + if (n_models == 1L) { + # No need to perform parallelisation across models, when there is only 1 + # model. + parallel_external <- FALSE + + } else if (n_bootstraps == 0L) { + # No need to perform internal parallelisation in case this is not + # necessary. This check is hit when has_internal_bootstrap is false. + parallel_external <- TRUE + + } else if (n_models >= 0.80 * n_nodes) { + # Perform external parallelisation if the number of models would occupy + # at least 80% of the nodes. This is because the parallel overhead in + # any internal bootstrapping takes up more time. + parallel_external <- TRUE + + } else if (n_models > n_bootstraps) { + # Perform external parallelisation if the number of bootstraps would + # underutilize the nodes compared to the number of nodes. + parallel_external <- TRUE + + } else { + parallel_external <- FALSE + } + + } else { + # Back-up when the number of nodes is 1 or none. + parallel_external <- FALSE + } + + # Dispatch for ensemble models. + if (proto_data_element@detail_level == "ensemble") { + # Dispatch for results aggregated at the ensemble level. + x <- .extract_dispatcher_ensemble( + cl = cl, + FUN = FUN, + object = object, + proto_data_element = proto_data_element, + aggregate_results = aggregate_results, + n_instances = n_instances, + n_bootstraps = n_bootstraps, + n_models = n_models, + parallel_external = parallel_external, + message_indent = message_indent, + verbose = verbose, + ... + ) + + } else if (proto_data_element@detail_level == "hybrid") { + # Dispatch for results aggregated with hybrid details. + x <- .extract_dispatcher_hybrid( + cl = cl, + FUN = FUN, + object = object, + proto_data_element = proto_data_element, + aggregate_results = aggregate_results, + n_instances = n_instances, + n_bootstraps = n_bootstraps, + n_models = n_models, + parallel_external = parallel_external, + message_indent = message_indent, + verbose = verbose, + ... + ) + + } else if (proto_data_element@detail_level == "model") { + # Dispatch for results aggregated at the model level. + x <- .extract_dispatcher_model( + cl = cl, + FUN = FUN, + object = object, + proto_data_element = proto_data_element, + aggregate_results = aggregate_results, + n_instances = n_instances, + n_bootstraps = n_bootstraps, + n_models = n_models, + parallel_external = parallel_external, + message_indent = message_indent, + verbose = verbose, + ... + ) + + } else { + ..error_reached_unreachable_code(paste0( + "extract_dispatcher: encountered an unknown detail_level attribute: ", + proto_data_element@detail_level + )) + } + + return(x) + } +) + + +# extract_dispatcher (dataObject) ---------------------------------------------- +setMethod( + "extract_dispatcher", + signature( + object = "dataObject", + proto_data_element = "familiarDataElement" + ), + function( + cl = NULL, + FUN, + object, + proto_data_element, + aggregate_results, + has_internal_bootstrap, + ..., + message_indent = 0L, + verbose = TRUE + ) { + + # Determine the number of instances we need to find the estimates. + if (proto_data_element@estimation_type == "point") { + n_instances <- 1L + + } else if (proto_data_element@estimation_type %in% c("bias_correction", "bc")) { + n_instances <- 20L + + } else if (proto_data_element@estimation_type %in% c("bootstrap_confidence_interval", "bci")) { + n_instances <- as.integer(ceiling(signif(20.0 / (1.00 - proto_data_element@confidence_level)))) + } + + if (proto_data_element@detail_level != "ensemble") { + ..error_reached_unreachable_code("Only ensemble-level detail levels are possible for extract_dispatcher with dataObject.") + } + + # Determine the number of bootstraps that should be computed internally. + n_bootstraps <- 0L + if (has_internal_bootstrap) n_bootstraps <- n_instances + + # If one bootstrap is required, that means no bootstraps are required. + if (n_bootstraps <= 1L) n_bootstraps <- 0L + + # Determine the number of parallel cluster nodes. + parallel_external <- FALSE + + # Dispatch for results aggregated at the ensemble level. + x <- .extract_dispatcher_ensemble( + cl = cl, + FUN = FUN, + object = object, + proto_data_element = proto_data_element, + aggregate_results = aggregate_results, + n_instances = n_instances, + n_bootstraps = n_bootstraps, + n_models = 1L, + parallel_external = FALSE, + message_indent = message_indent, + verbose = verbose, + ... + ) + + return(x) + } +) + + .extract_dispatcher_ensemble <- function( cl = NULL, @@ -946,32 +1290,35 @@ setMethod( n_models, parallel_external, ..., - verbose = FALSE) { + verbose = FALSE +) { # Add ensemble model name. proto_data_element <- add_model_name( proto_data_element, - object = object) + object = object + ) # Set flag for interval aggregation. aggregate_internal <- aggregate_results && n_instances == n_bootstraps && - n_bootstraps > 0 + n_bootstraps > 0L # Never perform outer-loop parallelisation when dispatching for ensemble-level # details. x <- FUN( cl = cl, object = object, - bootstrap_seed_offset = 0, + bootstrap_seed_offset = 0L, proto_data_element = proto_data_element, aggregate_results = aggregate_internal, n_instances = n_instances, n_bootstraps = n_bootstraps, n_models = n_models, verbose = verbose, - progress_bar = verbose && n_bootstraps > 1, - ...) + progress_bar = verbose && n_bootstraps > 1L, + ... + ) # Pack to list. if (!is.list(x)) x <- list(x) @@ -1000,7 +1347,8 @@ setMethod( n_models, parallel_external, ..., - verbose = FALSE) { + verbose = FALSE +) { # Add ensemble model name. proto_data_element <- add_model_name(proto_data_element, object = object) @@ -1011,9 +1359,10 @@ setMethod( FUN = FUN, object = object@model_list, bootstrap_seed_offset = seq( - from = 0, + from = 0L, by = n_bootstraps, - length.out = n_models), + length.out = n_models + ), MoreArgs = c( list( "cl" = NULL, @@ -1023,10 +1372,13 @@ setMethod( "n_bootstraps" = n_bootstraps, "n_models" = n_models, "verbose" = verbose, - "progress_bar" = verbose && length(object@model_list) == 1 && n_bootstraps > 1), - list(...)), - progress_bar = verbose && length(object@model_list) > 1, - chopchop = TRUE) + "progress_bar" = verbose && length(object@model_list) == 1L && n_bootstraps > 1L + ), + list(...) + ), + progress_bar = verbose && length(object@model_list) > 1L, + chopchop = TRUE + ) } else { x <- fam_mapply( @@ -1034,9 +1386,10 @@ setMethod( FUN = FUN, object = object@model_list, bootstrap_seed_offset = seq( - from = 0, + from = 0L, by = n_bootstraps, - length.out = n_models), + length.out = n_models + ), MoreArgs = c( list( "cl" = cl, @@ -1046,9 +1399,12 @@ setMethod( "n_bootstraps" = n_bootstraps, "n_models" = n_models, "verbose" = verbose, - "progress_bar" = verbose && n_models == 1 && n_bootstraps > 1), - list(...)), - progress_bar = verbose && n_models > 1) + "progress_bar" = verbose && n_models == 1L && n_bootstraps > 1L + ), + list(...) + ), + progress_bar = verbose && n_models > 1L + ) } # Merge data elements together. The model_name identifier gets added as data @@ -1056,7 +1412,8 @@ setMethod( x <- merge_data_elements( x, as_data = "model_name", - as_grouping_column = FALSE) + as_grouping_column = FALSE + ) # Create point estimate from the data. if (proto_data_element@estimation_type %in% c("bootstrap_confidence_interval", "bci")) { @@ -1084,21 +1441,24 @@ setMethod( n_models, parallel_external, ..., - verbose = FALSE) { + verbose = FALSE +) { # Create a list of data-elements. proto_data_element <- rep.int( list(proto_data_element), - times = length(object@model_list)) + times = length(object@model_list) + ) # Add model (not ensemble) names to the prototype data elements. proto_data_element <- mapply( add_model_name, data = proto_data_element, - object = object@model_list) + object = object@model_list + ) # Set flag for interval aggregation. - aggregate_internal <- aggregate_results && n_instances == n_bootstraps && n_bootstraps > 0 + aggregate_internal <- aggregate_results && n_instances == n_bootstraps && n_bootstraps > 0L if (parallel_external) { x <- fam_mapply( @@ -1106,9 +1466,10 @@ setMethod( FUN = FUN, object = object@model_list, bootstrap_seed_offset = seq( - from = 0, + from = 0L, by = n_bootstraps, - length.out = n_models), + length.out = n_models + ), proto_data_element = proto_data_element, MoreArgs = c( list( @@ -1118,10 +1479,13 @@ setMethod( "n_bootstraps" = n_bootstraps, "n_models" = n_models, "verbose" = verbose, - "progress_bar" = verbose && n_models == 1 && n_bootstraps > 1), - list(...)), - progress_bar = verbose & length(object@model_list) > 1, - chopchop = TRUE) + "progress_bar" = verbose && n_models == 1L && n_bootstraps > 1L + ), + list(...) + ), + progress_bar = verbose & length(object@model_list) > 1L, + chopchop = TRUE + ) } else { x <- fam_mapply( @@ -1129,9 +1493,10 @@ setMethod( FUN = FUN, object = object@model_list, bootstrap_seed_offset = seq( - from = 0, + from = 0L, by = n_bootstraps, - length.out = n_models), + length.out = n_models + ), proto_data_element = proto_data_element, MoreArgs = c( list( @@ -1141,9 +1506,12 @@ setMethod( "n_bootstraps" = n_bootstraps, "n_models" = n_models, "verbose" = verbose, - "progress_bar" = verbose && n_models == 1 && n_bootstraps > 1), - list(...)), - progress_bar = verbose && length(object@model_list) > 1) + "progress_bar" = verbose && n_models == 1L && n_bootstraps > 1L + ), + list(...) + ), + progress_bar = verbose && length(object@model_list) > 1L + ) } # Merge data elements together. @@ -1177,7 +1545,7 @@ setMethod( # Create a proto data element to avoid having to pass larger objects # than required. - proto_data_element <- x[which(element_classes == element_class)][[1]] + proto_data_element <- x[which(element_classes == element_class)][[1L]] proto_data_element@data <- NULL # Run familiarDataElement-specific analysis. This means that we pass @@ -1187,7 +1555,9 @@ setMethod( .add_point_estimate_from_elements( x = proto_data_element, x_list = x[which(element_classes == element_class)], - ...)) + ... + ) + ) } # Check that any data elements were added. @@ -1218,7 +1588,8 @@ setMethod( # Identify the element identifiers that should be grouped. grouped_data_element_ids <- lapply( split(id_table[, c("element_id", "group_id")], by = "group_id"), - function(id_table) (id_table$element_id)) + function(id_table) (id_table$element_id) + ) # List of data elements. data_elements <- list() @@ -1228,14 +1599,16 @@ setMethod( # Check that there is no point estimate present in the current table. any_point_estimate <- any(sapply( x[current_group_data_element_ids], - function(x) (x@estimation_type == "point"))) + function(x) (x@estimation_type == "point") + )) + if (any_point_estimate) next # Set conversion back to list, in case this is required. data_as_list <- FALSE # Copy the first data element in the group and use it as a prototype. - prototype_data_element <- x[[current_group_data_element_ids[1]]] + prototype_data_element <- x[[current_group_data_element_ids[1L]]] # Set point estimate. prototype_data_element@estimation_type <- "point" @@ -1243,34 +1616,38 @@ setMethod( # Check if all data are empty. all_data_empty <- all(sapply( x[current_group_data_element_ids], - function(x) (is_empty(x@data)))) + function(x) (is_empty(x@data)) + )) if (all_data_empty) { # Add empty element to data_elements and skip to the next data_elements <- c(data_elements, list(prototype_data_element)) - next } # Extract the data. any_is_data_table <- any(sapply( x[current_group_data_element_ids], - function(x) (data.table::is.data.table(x@data)))) + function(x) (data.table::is.data.table(x@data)) + )) any_is_list <- any(sapply( x[current_group_data_element_ids], - function(x) (rlang::is_bare_list(x@data)))) + function(x) (rlang::is_bare_list(x@data)) + )) if (any_is_data_table) { # Data attribute contains data.table. data <- lapply( x[current_group_data_element_ids], - function(x) (x@data)) + function(x) (x@data) + ) } else if (any_is_list) { # Convert all lists to data tables. data <- lapply( x[current_group_data_element_ids], - function(x) (data.table::as.data.table(x@data))) + function(x) (data.table::as.data.table(x@data)) + ) # Convert back to list in the end. data_as_list <- TRUE @@ -1280,17 +1657,24 @@ setMethod( data <- data.table::rbindlist( data, use.names = TRUE, - fill = TRUE) + fill = TRUE + ) - if (length(prototype_data_element@grouping_column) > 0) { + if (length(prototype_data_element@grouping_column) > 0L) { # Compute the mean value as point estimate. - data <- data[, lapply(.SD, get_estimate, na.rm = TRUE), - by = c(prototype_data_element@grouping_column), - .SDcols = c(prototype_data_element@value_column)] + data <- data[ + , + lapply(.SD, get_estimate, na.rm = TRUE), + by = c(prototype_data_element@grouping_column), + .SDcols = c(prototype_data_element@value_column) + ] } else { - data <- data[, lapply(.SD, get_estimate, na.rm = TRUE), - .SDcols = c(prototype_data_element@value_column)] + data <- data[ + , + lapply(.SD, get_estimate, na.rm = TRUE), + .SDcols = c(prototype_data_element@value_column) + ] } # Convert to list again, if necessary. @@ -1337,8 +1721,14 @@ setMethod( for (element_class in unique(element_classes)) { # Create a proto data element to avoid having to pass larger objects than - # required. - proto_data_element <- x[which(element_classes == element_class)][[1]] + # required. First we copy the first instance of the particular class. + proto_data_element <- x[which(element_classes == element_class)][[1L]] + + # Check that the proto_data_element is not NULL, because NULL objects + # cannot be parsed. + if (is.null(proto_data_element)) next + + # Remove data from the proto data element. proto_data_element@data <- NULL # Run familiarDataElement-specific analysis. This means that we pass the @@ -1348,7 +1738,9 @@ setMethod( .compute_data_element_estimates( x = proto_data_element, x_list = x[which(element_classes == element_class)], - ...)) + ... + ) + ) } if (is_empty(data_element)) return(NULL) @@ -1375,7 +1767,8 @@ setMethod( # Find any data elements that were already aggregated and keep these apart. is_aggregated <- sapply( data_elements, - function(x) (x@is_aggregated)) + function(x) (x@is_aggregated) + ) if (all(is_aggregated)) return(data_elements) @@ -1386,12 +1779,14 @@ setMethod( # Find any unique elements that have not been aggregated. id_table <- identify_element_sets( unaggregated_data_elements, - ignore_estimation_type = TRUE) + ignore_estimation_type = TRUE + ) # Identify the element identifiers that should be grouped. grouped_data_element_ids <- lapply( split(id_table[, c("element_id", "group_id")], by = "group_id"), - function(id_table) (id_table$element_id)) + function(id_table) (id_table$element_id) + ) # Aggregate unaggregated data. for (current_group_data_element_ids in grouped_data_element_ids) { @@ -1401,7 +1796,9 @@ setMethod( # Compute estimates. aggregated_data_element <- ..compute_data_element_estimates( - x = current_data_elements, ...) + x = current_data_elements, + ... + ) if (is.null(aggregated_data_element)) next @@ -1440,13 +1837,14 @@ setMethod( # Create a proto data element to avoid having to pass larger objects than # required. - proto_data_element <- x[[1]] + proto_data_element <- x[[1L]] proto_data_element@data <- NULL return(..compute_data_element_estimates( x = proto_data_element, x_list = x, - ...)) + ... + )) } ) @@ -1469,7 +1867,7 @@ setMethod( if (any(sapply(x, is_empty))) { # Don't aggregate empty elements. - y <- x[[1]] + y <- x[[1L]] } else if (any(estimation_type %in% c("bci", "bootstrap_confidence_interval"))) { @@ -1477,66 +1875,68 @@ setMethod( if (length(estimation_type) != 2L) { ..error_reached_unreachable_code(paste0( ".compute_data_element_estimates: exactly two data elements are ", - "required for bootstrap confidence intervals.")) + "required for bootstrap confidence intervals." + )) } if (!any(estimation_type %in% c("point"))) { ..error_reached_unreachable_code(paste0( ".compute_data_element_estimates: a point estimate is required for ", - "bootstrap confidence intervals.")) + "bootstrap confidence intervals." + )) } # Select point estimate. point_values <- data.table::as.data.table( - x[estimation_type == "point"][[1]]@data) + x[estimation_type == "point"][[1L]]@data + ) point_values[, "estimation_type" := "point"] # Select bootstrap values bootstrap_values <- data.table::as.data.table( - x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1]]@data) + x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1L]]@data + ) bootstrap_values[, "estimation_type" := "bootstrap_confidence_interval"] # Combine to single table. data <- data.table::rbindlist( list(point_values, bootstrap_values), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) - if (length(x[[1]]@grouping_column > 0)) { + if (length(x[[1L]]@grouping_column) > 0L) { # Split table by grouping column and compute estimate and confidence # intervals. data <- lapply( - split(data, by = x[[1]]@grouping_column, drop = TRUE), + split(data, by = x[[1L]]@grouping_column, drop = TRUE), ..compute_bootstrap_confidence_estimate, - confidence_level = x[[1]]@confidence_level, - bootstrap_ci_method = x[[1]]@bootstrap_ci_method, - value_column = x[[1]]@value_column, - grouping_column = x[[1]]@grouping_column) + confidence_level = x[[1L]]@confidence_level, + bootstrap_ci_method = x[[1L]]@bootstrap_ci_method, + value_column = x[[1L]]@value_column, + grouping_column = x[[1L]]@grouping_column + ) # Combine to single table - data <- data.table::rbindlist( - data, - use.names = TRUE, - fill = TRUE) + data <- data.table::rbindlist(data, use.names = TRUE, fill = TRUE) } else { # Compute in absence of grouping columns. data <- ..compute_bootstrap_confidence_estimate( x = data, - confidence_level = x[[1]]@confidence_level, - bootstrap_ci_method = x[[1]]@bootstrap_ci_method, - value_column = x[[1]]@value_column) + confidence_level = x[[1L]]@confidence_level, + bootstrap_ci_method = x[[1L]]@bootstrap_ci_method, + value_column = x[[1L]]@value_column + ) } # Update the data attribute. - y <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1]] + y <- x[estimation_type %in% c("bci", "bootstrap_confidence_interval")][[1L]] y@data <- data # Update value column - y@value_column <- setdiff( - names(y@data), - y@grouping_column) + y@value_column <- setdiff(names(y@data), y@grouping_column) } else if (any(estimation_type %in% c("bc", "bias_correction"))) { @@ -1544,42 +1944,45 @@ setMethod( if (length(estimation_type) != 1L) { ..error_reached_unreachable_code(paste0( ".compute_data_element_estimates: exactly one data element is required ", - "for bias corrected estimates.")) + "for bias corrected estimates." + )) } # Select values. bootstrap_values <- data.table::as.data.table( - x[estimation_type %in% c("bc", "bias_correction")][[1]]@data) + x[estimation_type %in% c("bc", "bias_correction")][[1L]]@data + ) - if (length(x[[1]]@grouping_column > 0)) { + if (length(x[[1L]]@grouping_column) > 0L) { # Split table by grouping column and compute bias corrected estimate. data <- lapply( - split(bootstrap_values, by = x[[1]]@grouping_column, drop = TRUE), + split(bootstrap_values, by = x[[1L]]@grouping_column, drop = TRUE), ..compute_bias_corrected_estimate, - value_column = x[[1]]@value_column, - grouping_column = x[[1]]@grouping_column) + value_column = x[[1L]]@value_column, + grouping_column = x[[1L]]@grouping_column + ) # Combine to single table data <- data.table::rbindlist( data, use.names = TRUE, - fill = TRUE) + fill = TRUE + ) } else { # Compute in absence of grouping columns. data <- ..compute_bias_corrected_estimate( x = bootstrap_values, - value_column = x[[1]]@value_column) + value_column = x[[1L]]@value_column + ) } # Update the data attribute. - y <- x[[1]] + y <- x[[1L]] y@data <- data # Update value column - y@value_column <- setdiff( - names(y@data), - y@grouping_column) + y@value_column <- setdiff(names(y@data), y@grouping_column) } else if (any(estimation_type %in% c("point"))) { # This follows the same procedure as for bias-corrected estimates. For @@ -1591,19 +1994,21 @@ setMethod( if (length(estimation_type) != 1L) { ..error_reached_unreachable_code(paste0( ".compute_data_element_estimates: exactly one data element is ", - "required for point estimates.")) + "required for point estimates." + )) } # Find grouping columns. - grouping_columns <- x[[1]]@grouping_column - if (length(grouping_columns) == 0) grouping_columns <- NULL + grouping_columns <- x[[1L]]@grouping_column + if (length(grouping_columns) == 0L) grouping_columns <- NULL # Find value columns. - value_columns <- x[[1]]@value_column + value_columns <- x[[1L]]@value_column # Select values. bootstrap_values <- data.table::as.data.table( - x[estimation_type %in% c("point")][[1]]@data)[, mget(c(grouping_columns, value_columns))] + x[estimation_type %in% c("point")][[1L]]@data + )[, mget(c(grouping_columns, value_columns))] # Refine a bit so that only those entries with multiple values for the # same grouping columns are aggregated. This can save a lot of time, @@ -1613,53 +2018,56 @@ setMethod( # Select data based on single/multiple entries. Keep only relevant # columns, namely grouping and value columns, to ensure that both # unique_values and bootstrap_values will be processed the same way. - unique_values <- bootstrap_values[n_group == 1, mget(c(grouping_columns, value_columns))] - bootstrap_values <- bootstrap_values[n_group > 1, mget(c(grouping_columns, value_columns))] + unique_values <- bootstrap_values[n_group == 1L, mget(c(grouping_columns, value_columns))] + bootstrap_values <- bootstrap_values[n_group > 1L, mget(c(grouping_columns, value_columns))] if (is_empty(bootstrap_values)) { # Data are unique values. data <- unique_values - } else if (length(grouping_columns) > 0) { + } else if (length(grouping_columns) > 0L) { # Split table by grouping column and compute bias corrected estimate. data <- lapply( split(bootstrap_values, by = grouping_columns, drop = TRUE), ..compute_bias_corrected_estimate, value_column = value_columns, - grouping_column = grouping_columns) + grouping_column = grouping_columns + ) # Combine to single table data <- data.table::rbindlist( c(list(unique_values), data), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) } else { # Compute in absence of grouping columns. data <- ..compute_bias_corrected_estimate( x = bootstrap_values, - value_column = value_columns) + value_column = value_columns + ) # Combine to single table data <- data.table::rbindlist( c(list(unique_values), list(data)), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) } # Update the data attribute. - y <- x[[1]] + y <- x[[1L]] y@data <- data # Update value column - y@value_column <- setdiff( - names(y@data), - y@grouping_column) + y@value_column <- setdiff(names(y@data), y@grouping_column) } else { ..error_reached_unreachable_code(paste0( ".compute_data_element_estimates: unknown estimation type: ", - paste_s(estimation_type))) + paste_s(estimation_type) + )) } return(y) @@ -1683,7 +2091,8 @@ setMethod( value_column, confidence_level, bootstrap_ci_method, - grouping_column = NULL) { + grouping_column = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table estimation_type <- NULL @@ -1700,28 +2109,32 @@ setMethod( x = x[estimation_type == "bootstrap_confidence_interval"][[value_column[ii]]], x_0 = x[estimation_type == "point"][[value_column[ii]]], confidence_level = confidence_level, - bootstrap_ci_method = bootstrap_ci_method) + bootstrap_ci_method = bootstrap_ci_method + ) # Determine column names that should be assigned. - if (length(temp_estimate) == 3) { + if (length(temp_estimate) == 3L) { - if (length(value_column) == 1) { + if (length(value_column) == 1L) { value_column_names <- c( value_column_names, - value_column[ii], "ci_low", "ci_up") + value_column[ii], "ci_low", "ci_up" + ) } else { value_column_names <- c( value_column_names, value_column[ii], paste0(value_column[ii], "_ci_low"), - paste0(value_column[ii], "_ci_up")) + paste0(value_column[ii], "_ci_up") + ) } } else { value_column_names <- c( value_column_names, - value_column[ii]) + value_column[ii] + ) } # Set to value list @@ -1736,10 +2149,11 @@ setMethod( ci_estimate[, c(value_column_names) := value_list] # Add in grouping columns, if any. - if (length(grouping_column) > 0) { + if (length(grouping_column) > 0L) { ci_estimate <- cbind( head(x[, mget(grouping_column)], n = 1L), - ci_estimate) + ci_estimate + ) } return(ci_estimate) @@ -1750,7 +2164,8 @@ setMethod( ..compute_bias_corrected_estimate <- function( x, value_column, - grouping_column = NULL) { + grouping_column = NULL +) { # Construct NULL table. bc_estimate <- data.table::data.table() @@ -1765,10 +2180,11 @@ setMethod( bc_estimate[, c(value_column) := value_list] # Add in grouping columns, if any. - if (length(grouping_column) > 0) { + if (length(grouping_column) > 0L) { bc_estimate <- cbind( head(x[, mget(grouping_column)], n = 1L), - bc_estimate) + bc_estimate + ) } return(bc_estimate) @@ -1785,7 +2201,8 @@ setMethod( n_nodes, parallel_external, message_indent, - verbose) { + verbose +) { # Skip if the dispatcher is not verbose. if (!verbose) return(NULL) @@ -1797,7 +2214,8 @@ setMethod( "bc" = "bias-corrected estimate", "bias_correction" = "bias-corrected estimate", "bci" = "bias-corrected estimate with confidence interval", - "bootstrap_confidence_interval" = "bias-corrected estimate with confidence interval") + "bootstrap_confidence_interval" = "bias-corrected estimate with confidence interval" + ) # Set the detail level string. detail_level_str <- switch( @@ -1806,15 +2224,20 @@ setMethod( "hybrid" = paste0( "the ensemble model from the ", ifelse( - n_models > 1, + n_models > 1L, paste0(n_models, " underlying models. "), - paste0("single underlying model. "))), + paste0("single underlying model. ") + ) + ), "model" = paste0( ifelse( - n_models > 1, + n_models > 1L, paste0("each of the ", n_models, " models"), - paste0("the single model")), - " in the ensemble. ")) + paste0("the single model") + ), + " in the ensemble. " + ) + ) # Bootstraps. if (n_bootstraps > 0L) { @@ -1823,7 +2246,9 @@ setMethod( ifelse( n_models > 1L, paste0("for each model (total: ", n_instances, "). "), - "in total. ")) + "in total. " + ) + ) } else { bootstrap_str <- "" @@ -1849,9 +2274,76 @@ setMethod( " of the value(s) of interest for ", detail_level_str, bootstrap_str, - parallel_str), + parallel_str + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) return(invisible(NULL)) } + + +# .convert_value_to_grouping_column (familiarDataElement) ---------------------- +setMethod( + ".convert_value_to_grouping_column", + signature(x = "familiarDataElement"), + function( + x, + new_grouping_column, + new_grouping_column_name, + new_value_column_name, + ... + ) { + + if (is_empty(x)) return(x) + if (!data.table::is.data.table(x@data)) return(x) + if (!any(new_grouping_column %in% x@value_column)) { + rlang::warn("None of the intended grouping columns currently appear as value column.") + return(x) + } + + new_grouping_column <- intersect(new_grouping_column, x@value_column) + remaining_value_column <- setdiff(x@value_column, new_grouping_column) + + original_grouping_column <- x@grouping_column + if (length(original_grouping_column) == 0L) { + old_data <- data.table::copy(data@data) + old_data[, "_index_id" := .I] + original_grouping_column <- "_index_id" + + } else { + old_data <- x@data + } + + data <- data.table::melt( + data = old_data, + id.vars = original_grouping_column, + measure_vars = new_grouping_column, + variable.name = new_grouping_column_name, + value.name = new_value_column_name + ) + + # If any other value columns remain, merge these into data. + if (length(remaining_value_column) > 0L) { + data <- merge( + x = data, + y = old_data[, mget(c(original_grouping_column, remaining_value_column))], + by = original_grouping_column, + all = TRUE + ) + } + + # Drop placeholder grouping column + if (any(original_grouping_column == "_index_id")) { + data[, "_index_id" := NULL] + } + + # Update data, value column and grouping column. + x@data <- data + x@value_column <- c(new_value_column_name, remaining_value_column) + x@grouping_column <- c(x@grouping_column, new_grouping_column_name) + + return(x) + } +) diff --git a/R/FamiliarEnsemble.R b/R/FamiliarEnsemble.R index b937cf51..5bd3f522 100644 --- a/R/FamiliarEnsemble.R +++ b/R/FamiliarEnsemble.R @@ -8,14 +8,18 @@ setMethod( signature(object = "familiarEnsemble"), function( object, - dir_path = NULL) { + dir_path = NULL, + message_indent = 0L, + verbose = FALSE + ) { # Fills out missing data from a familiarEnsemble based on attached models # and internal logic. # Load models object <- ..update_model_list( object = object, - dir_path = dir_path) + dir_path = dir_path + ) model_list <- ..get_model(object = object) # Determine which models were trained. @@ -25,31 +29,70 @@ setMethod( # models that were trained. if (any(trained_mask)) model_list <- model_list[trained_mask] - # Add outcome_type and outcome_info to object. These slots are required in - # some of the other aggregators. - object@outcome_type <- model_list[[1]]@outcome_type - object@outcome_info <- .aggregate_outcome_info( - x = lapply( - model_list, - function(list_elem) (list_elem@outcome_info))) - + if (is(model_list[[1L]], "familiarModel")) { + # Add outcome_type and outcome_info to object. These slots are required in + # some of the other aggregators. + object@outcome_type <- model_list[[1L]]@outcome_type + object@outcome_info <- .aggregate_outcome_info( + x = lapply( + model_list, + function(list_elem) (list_elem@outcome_info) + ) + ) + + # Find all important features for novelty detection. + novelty_features <- unique(unlist(lapply( + model_list, + function(fam_model) (fam_model@novelty_features) + ))) + + # Aggregate calibration info + calibration_info <- extract_calibration_info( + object = object, + detail_level = "hybrid", + message_indent = message_indent, + verbose = verbose + ) + calibration_info <- .compute_data_element_estimates(calibration_info) + + if (is_empty(calibration_info)) { + calibration_info <- NULL + } else { + calibration_info <- calibration_info[[1L]]@data + } + + # Get settings + settings <- model_list[[1L]]@settings + + } else if (is(model_list[[1L]], "familiarNoveltyDetector")) { + # Add outcome_type and outcome_info to object. + object@outcome_type <- "unsupervised" + object@outcome_info <- NULL + + # Find all important features for novelty detection. + novelty_features <- unique(unlist(lapply( + model_list, + function(fam_model) (fam_model@model_features) + ))) + + calibration_info <- NULL + settings <- NULL + } + # Find all required features required_features <- unique(unlist(lapply( model_list, - function(fam_model) (fam_model@required_features)))) + function(fam_model) (fam_model@required_features) + ))) # Find all important features for the model. model_features <- unique(unlist(lapply( model_list, - function(fam_model) (fam_model@model_features)))) - - # Find all important features for novelty detection. - novelty_features <- unique(unlist(lapply( - model_list, - function(fam_model) (fam_model@novelty_features)))) + function(fam_model) (fam_model@model_features) + ))) # Aggregate feature information - if (length(required_features) > 0) { + if (length(required_features) > 0L) { feature_info_list <- lapply(required_features, .collect_and_aggregate_feature_info, object = object, @@ -64,36 +107,26 @@ setMethod( feature_info_list <- NULL } - # Aggregate calibration info - calibration_info <- extract_calibration_info( - object = object, - detail_level = "hybrid") - calibration_info <- .compute_data_element_estimates(calibration_info) - - if (is_empty(calibration_info)) { - calibration_info <- NULL - } else { - calibration_info <- calibration_info[[1]]@data - } - # Generate a new version of the ensemble to avoid unnecessary copying. fam_ensemble <- methods::new("familiarEnsemble", model_list = object@model_list, outcome_type = object@outcome_type, outcome_info = object@outcome_info, - data_column_info = model_list[[1]]@data_column_info, + data_column_info = model_list[[1L]]@data_column_info, learner = object@learner, - fs_method = object@fs_method, + vimp_method = object@vimp_method, required_features = required_features, model_features = model_features, novelty_features = novelty_features, feature_info = feature_info_list, + data_id = object@data_id, + run_id = object@run_id, run_table = object@run_table, calibration_info = calibration_info, model_dir_path = object@model_dir_path, auto_detach = object@auto_detach, - settings = model_list[[1]]@settings, - project_id = model_list[[1]]@project_id + settings = settings, + project_id = model_list[[1L]]@project_id ) # Add package version to the ensemble @@ -120,7 +153,7 @@ setMethod( cat(paste0( "An ensemble of ", length(object@model_list), " ", object@learner, " ", - ifelse(length(object@model_list) == 1, "model", "models"), + ifelse(length(object@model_list) == 1L, "model", "models"), " (", .familiar_version_string(object), ").\n" )) @@ -128,15 +161,15 @@ setMethod( cat(paste0( "An ensemble of ", length(object@model_list), " ", object@learner, " ", - ifelse(length(object@model_list) == 1, "model", "models"), + ifelse(length(object@model_list) == 1L, "model", "models"), " (", .familiar_version_string(object), ").\n" )) # Determine how many models are trained. model_trained <- sapply(object@model_list, model_is_trained) - if (length(model_trained) == 1) { - show(object@model_list[[1]]) + if (length(model_trained) == 1L) { + show(object@model_list[[1L]]) # Update the flag to prevent showing redundant information. show_additional_information <- FALSE @@ -154,7 +187,8 @@ setMethod( # Details concerning variable importance. cat(paste0( "\nVariable importance was determined using the ", - object@fs_method, " variable importance method.\n")) + object@vimp_method, " variable importance method.\n" + )) # Details concerning model features: cat("\nThe following features were used in the ensemble:\n") @@ -163,9 +197,11 @@ setMethod( function(x, object) { cat(.show_simple_feature_info( object@feature_info[[x]], - line_end = ".\n")) + line_end = ".\n" + )) }, - object = object) + object = object + ) } } ) @@ -183,8 +219,10 @@ setMethod( return(do.call( get_prediction_type, args = c( - list("object" = object@model_list[[1]]), - list(...)))) + list("object" = object@model_list[[1L]]), + list(...) + ) + )) } ) @@ -201,7 +239,9 @@ setMethod( get_prediction_type, args = c( list("object" = object), - list(...)))) + list(...) + ) + )) } ) @@ -212,28 +252,31 @@ setMethod( "..get_model", signature( ii = "numeric", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(ii, object) { if (ii > length(object@model_list)) { ..error_reached_unreachable_code(paste0( "..get_model,familiarEnsemble: the requested index (", ii, ") exceeds the total number of models in the ensemble (", - length(object@model_list))) + length(object@model_list) + )) } # If the model is already attached, dispatch to calling function. if (is(object@model_list[[ii]], "familiarModel")) { return(object@model_list[[ii]]) } + if (is(object@model_list[[ii]], "familiarNoveltyDetector")) { + return(object@model_list[[ii]]) + } # If the model has been detached, load, and then dispatch. # First check if the file exists. if (!file.exists(object@model_list[[ii]])) { # Obtain the file name of the model. - model_file_name <- ..get_model_file_path( - ii = ii, - object = object) + model_file_name <- ..get_model_file_path(ii = ii, object = object) # Load the model if the file exists. if (!is.null(model_file_name)) { @@ -241,9 +284,10 @@ setMethod( } # If no model could be found, throw an error. - stop(paste0( + ..error(paste0( "..get_model,familiarEnsemble: cannot find the indicated familiarModel", - object@model_list[[ii]])) + object@model_list[[ii]] + )) } return(load_familiar_object(object@model_list[[ii]])) @@ -257,16 +301,18 @@ setMethod( "..get_model", signature( ii = "missing", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(ii, object, ...) { - if (length(object@model_list) > 0) { + if (length(object@model_list) > 0L) { # Dispatch get_model. return(lapply( seq_along(object@model_list), ..get_model, object = object, - ...)) + ... + )) } else { return(NULL) @@ -281,14 +327,16 @@ setMethod( "..get_model_file_path", signature( ii = "numeric", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(ii, object, dir_path = NULL) { if (ii > length(object@model_list)) { ..error_reached_unreachable_code(paste0( "..get_model_file_path,familiarEnsemble: the requested index (", ii, ") exceeds the total number of models in the ensemble (", - length(object@model_list))) + length(object@model_list) + )) } # There are three directories a file can be located, namely: @@ -329,9 +377,13 @@ setMethod( # Generate the file name from the model. model_file_name <- get_object_name( object = object@model_list[[ii]], - abbreviated = FALSE) + abbreviated = FALSE + ) model_file_name <- paste0(model_file_name, ".RDS") + } else if (is(object@model_list[[ii]], "familiarNoveltyDetector")) { + return(NULL) + } else { # Generate the file name from the stored string. model_file_name <- basename(object@model_list[[ii]]) @@ -350,8 +402,10 @@ setMethod( dir_path = dir_path, object_type = "familiarModel", learner = object@learner, - fs_method = object@fs_method), - model_file_name) + vimp_method = object@vimp_method + ), + model_file_name + ) if (file.exists(file_path_2)) return(file_path_2) } @@ -369,8 +423,10 @@ setMethod( dir_path = mb_dir_path, object_type = "familiarModel", learner = object@learner, - fs_method = object@fs_method), - model_file_name) + vimp_method = object@vimp_method + ), + model_file_name + ) if (file.exists(file_path_4)) return(file_path_4) } @@ -389,8 +445,10 @@ setMethod( dir_path = model_dir_path, object_type = "familiarModel", learner = object@learner, - fs_method = object@fs_method), - model_file_name) + vimp_method = object@vimp_method + ), + model_file_name + ) if (file.exists(file_path_6)) return(file_path_6) } @@ -407,14 +465,16 @@ setMethod( "..get_model_file_path", signature( ii = "missing", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(ii, object, ...) { # Dispatch to ..get_model_file_path. return(lapply( seq_along(object@model_list), ..get_model_file_path, object = object, - ...)) + ... + )) } ) @@ -427,7 +487,8 @@ setMethod( function( object, dir_path = NULL, - auto_detach = FALSE) { + auto_detach = FALSE + ) { # Determine if models can detach. Models cannot detach if detaching them # would lead them to be lost, i.e. there are no files on a known drive # location drive. @@ -442,23 +503,30 @@ setMethod( for (ii in seq_along(object@model_list)) { # Skip if the current entry is an attached familiarModel object. if (is(object@model_list[[ii]], "familiarModel")) next + if (is(object@model_list[[ii]], "familiarNoveltyDetector")) next # Stop if the current entry is not a character. if (!is.character(object@model_list[[ii]])) { - stop(paste0( + rlang::abort(paste0( "The current entry in the model list is not a character string ", - "or a familiarModel object.")) + "or a familiarModel object." + )) } # Skip if the entry points to a file and not a directory. - if (file.exists(object@model_list[[ii]]) && - !dir.exists(object@model_list[[ii]])) next + if ( + file.exists(object@model_list[[ii]]) && + !dir.exists(object@model_list[[ii]]) + ) { + next + } # Identify the file path, if any. model_file_path <- ..get_model_file_path( ii = ii, object = object, - dir_path = dir_path) + dir_path = dir_path + ) # If there is a file path, add this to the model list, and update # the model_dir_path attribute. @@ -470,55 +538,61 @@ setMethod( # Check if the models are either attached or are located on a known # drive location. - if (length(object@model_list) > 0) { + if (length(object@model_list) > 0L) { model_exists <- sapply( object@model_list, function(list_entry) { if (is(list_entry, "familiarModel")) { return(TRUE) + } else if (is(list_entry, "familiarNoveltyDetector")) { + return(TRUE) } else if (file.exists(list_entry)) { return(TRUE) } return(FALSE) - }) + } + ) - # Throw an error if any model does not exist. - if (all(!model_exists)) { - stop(paste0( + # Throw an error if not all models exist. + if (!any(model_exists)) { + ..error(paste0( "None of the models could be found: ", paste_s(unlist(object@model_list)), ". \n\nThis is likely because the models are no longer found in the ", "same location as they were created. ", "Use the update_model_dir_path method to update the path for the ", - "directory containing the models.")) + "directory containing the models." + )) } - if (any(!model_exists)) { - stop(paste0( + if (!all(model_exists)) { + ..error(paste0( "The following models in the ensemble could not be found: ", - paste_s(unlist(object@model_list[!model_exists])), ".")) + paste_s(unlist(object@model_list[!model_exists])), "." + )) } } # Check the model_dir_path slot if auto_detach is on. In that case # model_dir_path is required to find the models. - if ((auto_detach || object@auto_detach) && length(object@model_list) > 0) { + if ((auto_detach || object@auto_detach) && length(object@model_list) > 0L) { # Check if all models are attached, because in that case we may still need # to determine the drive location. if (is_model_loaded(object)) { # Identify the file path, if any. model_file_path <- ..get_model_file_path( - ii = 1, + ii = 1L, object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Set the model_file_path explicitly. if (!is.null(model_file_path)) object@model_dir_path <- dirname(model_file_path) } # Check that a model directory path has been set and exists. - if (is.na(object@model_dir_path)) stop("The model directory could not be found.") - if (!dir.exists(object@model_dir_path)) stop("The model directory could not be found.") + if (is.na(object@model_dir_path)) rlang::abort("The model directory could not be found.") + if (!dir.exists(object@model_dir_path)) rlang::abort("The model directory could not be found.") } return(object) @@ -532,7 +606,8 @@ setMethod( "..can_detach_models", signature( ii = "numeric", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(ii, object, dir_path = NULL) { # Check whether a model can be detached without losing it. We do this by # checking whether a valid file path can be generated. If not, @@ -540,7 +615,8 @@ setMethod( model_file_path <- ..get_model_file_path( ii = ii, object = object, - dir_path = dir_path) + dir_path = dir_path + ) return(!is.null(model_file_path)) } @@ -553,16 +629,18 @@ setMethod( "..can_detach_models", signature( ii = "missing", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(ii, object, dir_path = NULL) { # Check if there are any models in the ensemble. - if (length(object@model_list) > 0) { + if (length(object@model_list) > 0L) { # Check whether a model can be detached without losing it. can_detach <- sapply( seq_along(object@model_list), ..can_detach_models, object = object, - dir_path = dir_path) + dir_path = dir_path + ) # Return TRUE when all models can be detached. return(all(can_detach)) @@ -622,9 +700,10 @@ setMethod( dir_path <- dirname(dir_path) } else { - stop(paste0( + ..error(paste0( "The new model directory does not exist, or cannot be accessed. ", - "Found: ", dir_path)) + "Found: ", dir_path + )) } } @@ -649,7 +728,8 @@ setMethod( # Update path to model directory return(update_model_dir_path( object = object, - dir_path = dir_path)) + dir_path = dir_path + )) } ) @@ -662,15 +742,14 @@ setMethod( object, dir_path = NULL, suppress_auto_detach = FALSE, - drop_untrained = FALSE) { + drop_untrained = FALSE + ) { # Skip if there no models on the list. - if (length(object@model_list) == 0) return(object) + if (length(object@model_list) == 0L) return(object) # Update model list as a precaution. This also checks that models # can actually be attached. - object <- ..update_model_list( - object = object, - dir_path = dir_path) + object <- ..update_model_list(object = object, dir_path = dir_path) # Do not attach models if auto_detach is set to TRUE. if (!object@auto_detach || suppress_auto_detach) { @@ -697,11 +776,11 @@ setMethod( "is_model_loaded", signature(object = "familiarEnsemble"), function(object) { - if (length(object@model_list) > 0 && !object@auto_detach) { + if (length(object@model_list) > 0L && !object@auto_detach) { # Check that all models are present. return(all(sapply(object@model_list, is, class2 = "familiarModel"))) - } else if (length(object@model_list) > 0 & object@auto_detach) { + } else if (length(object@model_list) > 0L & object@auto_detach) { # Return TRUE if all models are dynamically loaded. return(TRUE) @@ -730,7 +809,8 @@ setMethod( # Get the model file name. model_file_name <- ..get_model_file_path( ii = ii, - object = object) + object = object + ) # Update the entry model_list[[ii]] <- model_file_name @@ -752,13 +832,15 @@ setMethod( "add_model_name", signature( data = "ANY", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(data, object) { - + if (is_empty(data)) return(NULL) ..error_reached_unreachable_code( - "add_model_name,any,familiarEnsemble: no method for non-empty data.") + "add_model_name,any,familiarEnsemble: no method for non-empty data." + ) } ) @@ -768,10 +850,11 @@ setMethod( "add_model_name", signature( data = "familiarDataElement", - object = "familiarEnsemble"), + object = "familiarEnsemble" + ), function(data, object) { # Determine the model name - if (length(object@name) == 0) { + if (length(object@name) == 0L) { model_name <- get_object_name(object = object, abbreviated = TRUE) } else { model_name <- object@name @@ -804,7 +887,7 @@ setMethod( signature(x = "familiarEnsemble"), function(x, new = NULL) { - if (x@project_id == 0 && is.null(new)) { + 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 @@ -832,25 +915,22 @@ setMethod( "get_object_name", signature(object = "familiarEnsemble"), function(object, abbreviated = FALSE) { - # Extract data and run id - ensemble_data_id <- object@run_table$ensemble_data_id - ensemble_run_id <- object@run_table$ensemble_run_id if (abbreviated) { # Create an abbreviated name model_name <- paste0( - "ensemble", ".", ensemble_data_id, ".", ensemble_run_id) + "ensemble", ".", object@data_id, ".", object@run_id + ) } else { # Create the full name of the model model_name <- get_object_file_name( learner = object@learner, - fs_method = object@fs_method, + vimp_method = object@vimp_method, project_id = object@project_id, - data_id = ensemble_data_id, - run_id = ensemble_run_id, + data_id = object@data_id, + run_id = object@run_id, object_type = "familiarEnsemble", - is_ensemble = TRUE, with_extension = FALSE ) } @@ -859,6 +939,8 @@ setMethod( } ) + + # model_is_trained (ensemble) -------------------------------------------------- setMethod( "model_is_trained", @@ -869,7 +951,7 @@ setMethod( # Check if a model is present return(FALSE) - } else if (length(object@model_list) == 0) { + } else if (length(object@model_list) == 0L) { # No models were attached return(FALSE) @@ -915,43 +997,55 @@ setMethod( message_str <- paste0( "The ensemble contains ", n_models, - ifelse(n_models == 1, " model", " models")) + ifelse(n_models == 1L, " model", " models") + ) - if (n_models == 1) { + if (n_models == 1L) { # Ensemble contains a single model. - if (n_models_naive == 0 && n_models_trained == 1) { + if (n_models_naive == 0L && n_models_trained == 1L) { message_str <- c( message_str, - paste0(" which was successfully trained.")) + paste0(" which was successfully trained.") + ) - } else if (n_models_naive == 1) { + } else if (n_models_naive == 1L) { message_str <- c( message_str, - paste0(" which was successfully trained as a naive model.")) + paste0(" which was successfully trained as a naive model.") + ) } else { message_str <- c( message_str, - paste0(" which failed to successfully train.")) + paste0(" which failed to successfully train.") + ) } - } else if (n_models_trained > 0) { + } else if (n_models_trained > 0L) { # Ensemble contains multiple trained models. - message_str <- c(message_str, paste0( - ". Of these models, ", n_models_trained, - ifelse(n_models_trained == 1, " model was", " models were"), - " successfully trained, of which ", n_models_naive, - ifelse(n_models_naive == 1, " model was", " models were"), - " trained as a naive model.")) + message_str <- c( + message_str, + paste0( + ". Of these models, ", n_models_trained, + ifelse(n_models_trained == 1L, " model was", " models were"), + " successfully trained, of which ", n_models_naive, + ifelse(n_models_naive == 1L, " model was", " models were"), + " trained as a naive model." + ) + ) if (n_models > n_models_trained) { n_models_untrained <- n_models - n_models_trained - message_str <- c(message_str, paste0( - " The remaining ", n_models_untrained, - ifelse(n_models_untrained == 1, " model", " models"), - " failed to successfully train.")) + message_str <- c( + message_str, + paste0( + " The remaining ", n_models_untrained, + ifelse(n_models_untrained == 1L, " model", " models"), + " failed to successfully train." + ) + ) } } else { diff --git a/R/FamiliarHyperparameterLearner.R b/R/FamiliarHyperparameterLearner.R index d7494887..f2e4778b 100644 --- a/R/FamiliarHyperparameterLearner.R +++ b/R/FamiliarHyperparameterLearner.R @@ -29,7 +29,8 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "promote_learner,familiarHyperparameterLearner: encountered ", - "unknown hyperparameter learner: ", learner)) + "unknown hyperparameter learner: ", learner + )) } # Add package version. @@ -47,12 +48,14 @@ setMethod( ".train", signature( object = "familiarHyperparameterLearner", - data = "data.table"), + data = "data.table" + ), function( object, data, parameter_data = NULL, - ...) { + ... + ) { # Train method for training hyperparameter models # Suppress NOTES due to non-standard evaluation in data.table @@ -60,7 +63,7 @@ setMethod( # Check if the class of object is a subclass of # familiarHyperparameterLearner. - if (!is_subclass(class(object)[1], "familiarHyperparameterLearner")) { + if (!is_subclass(class(object)[1L], "familiarHyperparameterLearner")) { object <- promote_learner(object) } @@ -68,7 +71,8 @@ setMethod( if (!"optimisation_score" %in% colnames(data)) { data <- .compute_hyperparameter_optimisation_score( score_table = data, - optimisation_function = object@optimisation_function) + optimisation_function = object@optimisation_function + ) } # Merge data and parameter_data on param_id. @@ -78,7 +82,8 @@ setMethod( y = parameter_data, all.x = TRUE, all.y = FALSE, - by = "param_id") + by = "param_id" + ) } # Replace NA entries with the minimum optimisation score. @@ -89,16 +94,22 @@ setMethod( data = NULL, learner = object@target_learner, outcome_type = object@target_outcome_type, - names_only = TRUE) + names_only = TRUE + ) # Set hyperparameters in data. target_hyperparameters <- intersect(colnames(data), default_hyperparameters) - if (length(target_hyperparameters) == 0) { - stop(paste0( - "The provided hyperparameter data does not contain any of the ", - "hyperparameters expected by the learner. The following hyperparameters ", - "are used: ", paste_s(default_hyperparameters))) + if (length(target_hyperparameters) == 0L) { + ..error( + paste0( + "The provided hyperparameter data does not contain any of the ", + "hyperparameters expected by the learner. The following hyperparameters ", + "are used: ", paste_s(default_hyperparameters) + ), + error_class = "input_argument_error" + ) } + object@target_hyperparameters <- target_hyperparameters if (has_bad_training_data(object = object, data = data)) { @@ -112,7 +123,8 @@ setMethod( object <- ..train( object = object, data = data, - ...) + ... + ) # Add familiar version. object <- add_package_version(object) @@ -127,13 +139,15 @@ setMethod( ".predict", signature( object = "familiarHyperparameterLearner", - data = "data.table"), + data = "data.table" + ), function( object, data, type = "default", percentile = NULL, - ...) { + ... + ) { # Predict method for hyperparameter models. The type argument can be default # (reports the model estimate), sd (reports the model estimate + standard # deviation), percentile, in which case the model estimate and the requested @@ -175,20 +189,22 @@ setMethod( if (!model_is_trained(object)) { # Describe the learner and the version of familiar. cat(paste0( - "A ", object@learner, " model (class: ", class(object)[1], + "A ", object@learner, " model (class: ", class(object)[1L], ") for inferring hyperparameters of the ", object@target_learner, ". ", "This hyperparameter model could not successfully be trained (", - .familiar_version_string(object), ").\n")) + .familiar_version_string(object), ").\n" + )) return(invisible(NULL)) } # Describe the learner and the version of familiar. message_str <- paste0( - "A ", object@learner, " model (class: ", class(object)[1], + "A ", object@learner, " model (class: ", class(object)[1L], "; ", .familiar_version_string(object), ") ", "for inferring hyperparameters of the ", object@target_learner, - " learner. ") + " learner. " + ) # Describe the package(s), if any. if (!is.null(object@package)) { @@ -198,8 +214,10 @@ setMethod( paste_s(mapply( ..message_package_version, x = object@package, - version = object@package_version)), - ifelse(length(object@package) > 1, " packages", " package")) + version = object@package_version + )), + ifelse(length(object@package) > 1L, " packages", " package") + ) } # Complete message and write. @@ -217,15 +235,17 @@ setMethod( cat(paste0( "\nThe model was trained to infer the optimisation ", "score of the following hyperparameter set:\n", - paste_s(object@target_hyperparameters), "\n")) + paste_s(object@target_hyperparameters), "\n" + )) cat(paste0( "\nOptimisation scores were determined using the ", object@optimisation_function, " method, ", "based on assessment of model performance using the ", paste_s(object@optimisation_metric), - ifelse(length(object@optimisation_metric) > 1, " metrics", " metric"), - ".\n")) + ifelse(length(object@optimisation_metric) > 1L, " metrics", " metric"), + ".\n" + )) # Check package version. check_package_version(object) @@ -242,7 +262,8 @@ setMethod( x, purpose = NULL, message_type = "error", - ...) { + ... + ) { # Skip if no package is required. if (is_empty(x@package)) return(invisible(TRUE)) @@ -260,7 +281,8 @@ setMethod( return(invisible(.require_package( x = x@package, purpose = purpose, - message_type = message_type))) + message_type = message_type + ))) } ) @@ -277,7 +299,8 @@ setMethod( # Obtain package versions. object@package_version <- sapply( object@package, - function(x) (as.character(utils::packageVersion(x)))) + function(x) (as.character(utils::packageVersion(x))) + ) return(object) } @@ -293,7 +316,8 @@ setMethod( .check_package_version( name = object@package, version = object@package_version, - when = "at model creation") + when = "at model creation" + ) } ) @@ -334,7 +358,8 @@ setMethod( "..train", signature( object = "familiarHyperparameterLearner", - data = "ANY"), + data = "ANY" + ), function(object, data, ...) { # This method is basically a capture-all for when model training does not # succeed. Normally ..train calls refer to child classes. This method is @@ -353,13 +378,15 @@ setMethod( "..predict", signature( object = "familiarHyperparameterLearner", - data = "data.table"), + data = "data.table" + ), function(object, data, type = "default", ...) { # Like ..train, this method is a capture-all for when predictions fail. - return(get_placeholder_prediction_table( + return(.get_placeholder_hyperparameter_prediction_table( object = object, data = data, - type = type)) + type = type + )) } ) @@ -369,20 +396,21 @@ setMethod( "has_bad_training_data", signature( object = "familiarHyperparameterLearner", - data = "data.table"), + data = "data.table" + ), function(object, data, ...) { # One cannot train without data or on a single sample. if (is_empty(data)) return(TRUE) # Get identifier columns in the data. id_columns <- intersect(c("param_id", "run_id"), colnames(data)) - if (length(id_columns) > 0) { + if (length(id_columns) > 0L) { # Check that at least two unique entries are present. - if (data.table::uniqueN(data, by = c(id_columns)) < 2) return(TRUE) + if (data.table::uniqueN(data, by = c(id_columns)) < 2L) return(TRUE) } else { # Check that at least two rows are present. - if (nrow(data) < 2) return(TRUE) + if (nrow(data) < 2L) return(TRUE) } # Check if all data are non-singular. @@ -398,28 +426,73 @@ setMethod( .check_hyperparameter_learner_available <- function( hyperparameter_learner, - as_flag = FALSE) { + as_flag = FALSE +) { # Create familiarHyperparameterLearner object. fam_hyperparameter_model <- methods::new( "familiarHyperparameterLearner", - learner = hyperparameter_learner) + learner = hyperparameter_learner + ) # Set up the specific novelty detector fam_hyperparameter_model <- promote_learner(fam_hyperparameter_model) # Check if the familiar model has been successfully promoted. - if (!is_subclass( - class(fam_hyperparameter_model)[1], - "familiarHyperparameterLearner")) { - - stop(paste0( - hyperparameter_learner, " is not a valid hyperparameter learner. ", - "Please check the vignette for available hyperparameter learners.")) + if (!is_subclass(class(fam_hyperparameter_model)[1L], "familiarHyperparameterLearner")) { + ..error( + paste0( + hyperparameter_learner, " is not a valid hyperparameter learner. ", + "Please check the vignette for available hyperparameter learners." + ), + error_class = "input_argument_error" + ) } # Check that the required package can be loaded. require_package( x = fam_hyperparameter_model, purpose = "train", - message_type = "backend_error") + message_type = "backend_error" + ) +} + + + +.get_placeholder_hyperparameter_prediction_table <- function(object, data, type = "default") { + # Find the id columns. + id_columns <- intersect(c("param_id", "run_id"), colnames(data)) + + if (length(id_columns) > 0L) { + # Create a placeholder by only keeping the identifier columns. + prediction_table <- data.table::copy(data[, mget(id_columns)]) + + } else { + # Add a placeholder parameter identifier as scaffolding. + prediction_table <- data.table::data.table(param_id = rep_len(NA_integer_, nrow(data))) + } + + # Add placeholder columns. + if (type == "default") { + prediction_table[, "mu" := NA_real_] + + } else if (type == "sd") { + prediction_table[, ":="( + "mu" = NA_real_, + "sigma" = NA_real_ + )] + + } else if (type == "percentile") { + prediction_table[, "percentile" := NA_real_] + + } else if (type == "raw") { + prediction_table[, "raw_1" := NA_real_] + + } else { + ..error_reached_unreachable_code(paste0( + ".get_placeholder_hyperparameter_prediction_table: ", + "Encountered an unknown prediction type: ", type + )) + } + + return(prediction_table) } diff --git a/R/FamiliarModel.R b/R/FamiliarModel.R index fd58f9ac..6359a95c 100644 --- a/R/FamiliarModel.R +++ b/R/FamiliarModel.R @@ -9,27 +9,30 @@ setMethod( ".train", signature( object = "familiarModel", - data = "dataObject"), + data = "dataObject" + ), function( object, data, get_additional_info = FALSE, is_pre_processed = FALSE, trim_model = TRUE, - timeout = 60000, + 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)[1], "familiarModel")) object <- promote_learner(object) - + 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") + stop_at = "clustering" + ) # Work only with data that has known outcomes when training. data <- filter_missing_outcome(data = data) @@ -43,7 +46,8 @@ setMethod( can_train <- can_train_naive <- FALSE object <- ..update_errors( object = object, - ..error_message_no_training_data_available()) + ..error_message_no_training_data_available() + ) } # Check the number of features in data; if it has no features, a standard @@ -53,7 +57,8 @@ setMethod( can_train <- FALSE object <- ..update_errors( object = object, - ..error_message_no_features_selected_for_training()) + ..error_message_no_features_selected_for_training() + ) } # Check if the hyperparameters are plausible. @@ -61,7 +66,8 @@ setMethod( can_train <- can_train_naive <- FALSE object <- ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()) + ..error_message_no_optimised_hyperparameters_available() + ) } # Check if a naive model should be trained. @@ -72,7 +78,8 @@ setMethod( # Add outcome distribution data. object@outcome_info <- .compute_outcome_distribution_data( object = object@outcome_info, - data = data) + data = data + ) # Train a new model based on data. If a normal model cannot be trained, # attempt to train a naive model. @@ -81,13 +88,15 @@ setMethod( object = object, data = data, approximate = approximate, - ...) + ... + ) } else if (can_train_naive) { object <- ..train_naive( object = object, data = data, - ...) + ... + ) } # Extract information required for assessing model performance, calibration @@ -102,7 +111,8 @@ setMethod( if (can_train) { object <- ..set_recalibration_model( object = object, - data = data) + data = data + ) } # Extract data required for assessing calibration. Not all outcome types @@ -112,7 +122,8 @@ setMethod( if (can_train || can_train_naive) { object <- ..set_calibration_info( object = object, - data = data) + data = data + ) } # Set stratification thresholds. This is currently only done for @@ -120,13 +131,15 @@ setMethod( if (can_train) { object <- ..set_risk_stratification_thresholds( object = object, - data = data) + data = data + ) } # Add column data object <- add_data_column_info( object = object, - data = data) + data = data + ) } if (trim_model) object <- trim_model(object = object, timeout = timeout) @@ -145,78 +158,22 @@ setMethod( # .train (familiarModel, NULL)-------------------------------------------------- setMethod( - ".train", signature( + ".train", + signature( object = "familiarModel", - data = "NULL"), + data = "NULL" + ), function( object, data, - ...) { + ... + ) { # The model cannot be trained, and is returned directly. return(object) } ) -# .train_novelty_detector ---------------------------------------------------- -setMethod( - ".train_novelty_detector", - signature( - object = "familiarModel", - data = "dataObject"), - function( - object, - data, - detector, - get_additional_info = FALSE, - is_pre_processed = FALSE, - trim_model = TRUE, - ...) { - # Train method for novelty detectors. - - # Check if the class of object is a subclass of familiarModel. - if (!is_subclass(class(object)[1], "familiarModel")) object <- promote_learner(object) - - # Create detector object. - fam_detector <- methods::new("familiarNoveltyDetector", - learner = detector, - feature_info = object@feature_info, - required_features = object@required_features, - model_features = object@novelty_features, - run_table = object@run_table, - project_id = object@project_id) - - # Promote to the correct type of detector. - fam_detector <- promote_detector(object = fam_detector) - - # Process data, if required. - data <- process_input_data( - object = fam_detector, - data = data, - is_pre_processed = is_pre_processed, - stop_at = "clustering", - force_check = TRUE) - - # Optimise hyperparameters if they were not previously set. - if (!has_optimised_hyperparameters(object = fam_detector)) { - fam_detector <- optimise_hyperparameters( - object = fam_detector, - data = data, - ...) - } - - # Train the novelty detector. - fam_detector <- .train( - object = fam_detector, - data = data) - - # Add the detector to the familiarModel object. - object@novelty_detector <- fam_detector - - return(object) - } -) - # show (model) ----------------------------------------------------------------- setMethod( @@ -228,28 +185,31 @@ setMethod( if (!model_is_trained(object)) { cat(paste0( - "A ", object@learner, " model (class: ", class(object)[1], + "A ", object@learner, " model (class: ", class(object)[1L], ") that was not successfully trained (", - .familiar_version_string(object), ").\n")) + .familiar_version_string(object), ").\n" + )) - if (length(object@messages$warning) > 0) { + if (length(object@messages$warning) > 0L) { condition_messages <- condition_summary(object@messages$warning) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "warning was", "warnings were"), + ifelse(length(condition_messages) == 1L, "warning was", "warnings were"), " generated while trying to train the model:\n", paste0(condition_messages, collapse = "\n"), - "\n")) + "\n" + )) } - if (length(object@messages$error) > 0) { + if (length(object@messages$error) > 0L) { condition_messages <- condition_summary(object@messages$error) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "error was", "errors were"), + ifelse(length(condition_messages) == 1L, "error was", "errors were"), " encountered while trying to train the model:\n", paste0(condition_messages, collapse = "\n"), - "\n")) + "\n" + )) } return(invisible(NULL)) @@ -257,8 +217,9 @@ setMethod( # Describe the learner and the version of familiar. message_str <- paste0( - "A ", object@learner, " model (class: ", class(object)[1], - "; ", .familiar_version_string(object), ")") + "A ", object@learner, " model (class: ", class(object)[1L], + "; ", .familiar_version_string(object), ")" + ) # Describe the package(s), if any if (!is.null(object@package)) { @@ -268,8 +229,11 @@ setMethod( paste_s(mapply( ..message_package_version, x = object@package, - version = object@package_version)), - ifelse(length(object@package) > 1, " packages", " package")) + version = object@package_version + )), + ifelse(length(object@package) > 1L, " packages", " package" + ) + ) } # Complete message and write. @@ -298,19 +262,32 @@ setMethod( function(x, object) { cat(paste0(" ", x, ": ", object@hyperparameters[[x]], "\n")) }, - object = object)) + object = object + )) # Details concerning variable importance. cat(paste0( "\nVariable importance was determined using the ", - object@fs_method, " variable importance method.\n")) + 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) + object = object + ) # Details concerning novelty features: if (!model_is_trained(object@novelty_detector)) { @@ -329,28 +306,31 @@ setMethod( lapply( novelty_features, function(x, object) show(object@feature_info[[x]]), - object = object) + object = object + ) } - if (length(object@messages$warning) > 0 || length(object@messages$error) > 0) { + if (length(object@messages$warning) > 0L || length(object@messages$error) > 0L) { cat(paste0("\n------------ Warnings and errors ------------\n")) - if (length(object@messages$warning) > 0) { + if (length(object@messages$warning) > 0L) { condition_messages <- condition_summary(object@messages$warning) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "warning was", "warnings were"), + ifelse(length(condition_messages) == 1L, "warning was", "warnings were"), " generated while training the model:\n", - paste0(condition_messages, collapse = "\n"))) + paste0(condition_messages, collapse = "\n") + )) } - if (length(object@messages$error) > 0) { + if (length(object@messages$error) > 0L) { condition_messages <- condition_summary(object@messages$error) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "error was", "errors were"), + ifelse(length(condition_messages) == 1L, "error was", "errors were"), " encountered while training the model:\n", - paste0(condition_messages, collapse = "\n"))) + paste0(condition_messages, collapse = "\n") + )) } } @@ -405,7 +385,8 @@ setMethod( # Attempt to capture the summary directly. h <- tryCatch( summary(object@model, ...), - error = identity) + error = identity + ) # If an error is generated, create a message and return an invisible NULL. if (inherits(h, "error")) { @@ -466,7 +447,8 @@ setMethod( # Attempt to capture the coefficients directly. feature_coefficients <- tryCatch( coef(object@model, ...), - error = identity) + error = identity + ) # If an error is generated by coef, return a NULL. if (inherits(feature_coefficients, "error")) return(NULL) @@ -516,7 +498,8 @@ setMethod( # Attempt to capture the variance-covariance matrix directly. variance_covariance_matrix <- tryCatch( vcov(object@model, ...), - error = identity) + error = identity + ) # If an error is generated by vcov, return a NULL. if (inherits(variance_covariance_matrix, "error")) return(NULL) @@ -543,14 +526,16 @@ setMethod( "vimp" = "to determine variable importance", "predict" = "to create model predictions", "show" = "to capture output", - "distribution" = "to set the model distribution") + "distribution" = "to set the model distribution" + ) } } return(invisible(.require_package( x = x@package, purpose = purpose, - message_type = message_type))) + message_type = message_type + ))) } ) @@ -567,7 +552,8 @@ setMethod( # Obtain package versions. object@package_version <- sapply( object@package, - function(x) (as.character(utils::packageVersion(x)))) + function(x) (as.character(utils::packageVersion(x))) + ) return(object) } @@ -583,7 +569,8 @@ setMethod( .check_package_version( name = object@package, version = object@package_version, - when = "at model creation") + when = "at model creation" + ) } ) @@ -594,7 +581,8 @@ setMethod( "save", signature( list = "familiarModel", - file = "character"), + file = "character" + ), function(list, file) { .save(object = list, dir_path = file) } @@ -607,12 +595,14 @@ setMethod( "add_model_name", signature( data = "ANY", - object = "familiarModel"), + 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,any,familiarModel: no method for non-empty data." + ) } ) @@ -623,10 +613,11 @@ setMethod( "add_model_name", signature( data = "familiarDataElement", - object = "familiarModel"), + object = "familiarModel" + ), function(data, object) { # Determine the model name - if (length(object@name) == 0) { + if (length(object@name) == 0L) { model_name <- get_object_name(object = object, abbreviated = TRUE) } else { model_name <- object@name @@ -649,14 +640,19 @@ setMethod( "add_model_name", signature( data = "familiarDataElement", - object = "character"), + object = "character" + ), function(data, object) { # Load object. object <- load_familiar_object(object) - return(do.call(add_model_name, args = c(list( - "data" = data, - "object" = object)))) + return(do.call( + add_model_name, + args = list( + "data" = data, + "object" = object + ) + )) } ) @@ -678,14 +674,15 @@ setMethod( signature(x = "familiarModel"), function(x, new = NULL) { - if (x@project_id == 0 && is.null(new)) { + 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)) + "_", rstring(n = 20L) + ) } else if (is.null(new)) { # Generate a sensible object name. @@ -706,24 +703,22 @@ setMethod( "get_object_name", signature(object = "familiarModel"), function(object, abbreviated = FALSE) { - # Extract data and run id - model_data_id <- tail(object@run_table, n = 1)$data_id - model_run_id <- tail(object@run_table, n = 1)$run_id - + if (abbreviated) { # Create an abbreviated name - model_name <- paste0("model.", model_data_id, ".", model_run_id) + 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, - fs_method = object@fs_method, + vimp_method = object@vimp_method, project_id = object@project_id, - data_id = model_data_id, - run_id = model_run_id, + data_id = object@data_id, + run_id = object@run_id, object_type = "familiarModel", - with_extension = FALSE) + with_extension = FALSE + ) } return(model_name) @@ -762,7 +757,8 @@ setMethod( return(do.call( model_is_trained, - args = c(list("object" = object)))) + args = c(list("object" = object)) + )) } ) @@ -800,7 +796,8 @@ setMethod( data = NULL, sample_id_column = NULL, batch_id_column = NULL, - series_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) @@ -835,7 +832,8 @@ setMethod( 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)) + "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. @@ -846,9 +844,10 @@ setMethod( outcome_info_table <- data.table::data.table( "type" = c("outcome_column", "outcome_column"), "internal" = internal_outcome_columns, - "external" = external_outcome_columns) + "external" = external_outcome_columns + ) - } else if (object@outcome_type %in% c("binomial", "multinomial", "continuous", "count")) { + } 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 @@ -857,7 +856,8 @@ setMethod( outcome_info_table <- data.table::data.table( "type" = "outcome_column", "internal" = internal_outcome_columns, - "external" = external_outcome_columns) + "external" = external_outcome_columns + ) } else { ..error_no_known_outcome_type(outcome_type = object@outcome_type) @@ -871,6 +871,7 @@ setMethod( ) + # is_available ----------------------------------------------------------------- setMethod( "is_available", @@ -898,7 +899,8 @@ setMethod( "..train", signature( object = "familiarModel", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Set a NULL model object@model <- NULL @@ -914,7 +916,8 @@ setMethod( "..train", signature( object = "familiarModel", - data = "NULL"), + data = "NULL" + ), function(object, data, ...) { # Set a NULL model object@model <- NULL @@ -930,7 +933,8 @@ setMethod( "..train_naive", signature( object = "familiarModel", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Set a NULL model object@model <- NULL @@ -946,7 +950,8 @@ setMethod( "..train_naive", signature( object = "familiarModel", - data = "NULL"), + data = "NULL" + ), function(object, data, ...) { # Set a NULL model. object@model <- NULL @@ -962,12 +967,24 @@ setMethod( "..predict", signature( object = "familiarModel", - data = "dataObject"), - function(object, data, ...) { - # This is a fall-back option. - return(get_placeholder_prediction_table( + 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, - data = data)) + type = type + ) + + return(as_prediction_table( + x = NULL, + type = prediction_table_type, + data = data, + time = time, + model_object = object + )) } ) @@ -978,7 +995,8 @@ setMethod( "..predict", signature( object = "character", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Load object. object <- load_familiar_object(object) @@ -987,50 +1005,50 @@ setMethod( ..predict, args = c(list( "object" = object, - "data" = data)))) + "data" = data + )) + )) } ) -# ..predict_survival_probability (familiarModel, dataObject) ------------------- +# ..get_prediction_table_type (familiarModel) ---------------------------------- setMethod( - "..predict_survival_probability", - signature( - object = "familiarModel", - data = "dataObject"), - function(object, data, time, ...) { - # This is a fall-back option. - return(get_placeholder_prediction_table( - object = object, - data = data, - type = "survival_probability")) + "..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) } ) -# ..predict_survival_probability (character, dataObject) ----------------------- -setMethod( - "..predict_survival_probability", - signature( - object = "character", - data = "dataObject"), - function(object, data, ...) { - # Load object. - object <- load_familiar_object(object) - - return(do.call( - ..predict_survival_probability, - args = c( - list( - "object" = object, - "data" = data), - list(...)))) - } -) - - # ..set_calibration_info ------------------------------------------------------- setMethod( @@ -1051,7 +1069,8 @@ setMethod( "..set_recalibration_model", signature( object = "familiarModel", - data = "dataObject"), + data = "dataObject" + ), function(object, data) { # This is a fall-back option. object@calibration_model <- NULL @@ -1067,15 +1086,19 @@ setMethod( "..set_risk_stratification_thresholds", signature( object = "familiarModel", - data = "dataObject"), + data = "dataObject" + ), function(object, data) { - if (object@outcome_type %in% c("survival", "competing_risk") && - model_is_trained(object)) { + if ( + object@outcome_type %in% c("survival", "competing_risk") && + model_is_trained(object) + ) { object@km_info <- .find_survival_grouping_thresholds( object = object, - data = data) + data = data + ) } else { object@km_info <- NULL @@ -1107,7 +1130,8 @@ setMethod( # This is a fall-back option. return(get_placeholder_vimp_table( vimp_method = object@learner, - run_table = object@run_table)) + run_table = object@run_table + )) } ) @@ -1117,7 +1141,7 @@ setMethod( setMethod( "trim_model", signature(object = "familiarModel"), - function(object, timeout = 60000, ...) { + function(object, timeout = 60000.0, ...) { # Do not trim the model if there is nothing to trim. if (!model_is_trained(object)) return(object) @@ -1131,7 +1155,8 @@ setMethod( trimmed_object <- .replace_broken_functions( object = object, trimmed_object = trimmed_object, - timeout = timeout) + timeout = timeout + ) return(trimmed_object) } @@ -1165,10 +1190,10 @@ setMethod( if (is.null(object@hyperparameters$sign_size)) return(FALSE) # Check if the no-features variable importance. - if (object@fs_method %in% .get_available_no_features_vimp_methods()) return(TRUE) + 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 == 0)) + return(all(object@hyperparameters$sign_size == 0L)) } ) @@ -1182,7 +1207,8 @@ setMethod( # Update warnings attached to the object. object@messages$warning <- c( object@messages$warning, - messages) + messages + ) return(object) } @@ -1215,35 +1241,34 @@ setMethod( ) -# set_signature (familiarModel)------------------------------------------------- + +# set_model_features (familiarModel)-------------------------------------------- setMethod( - "set_signature", + "set_model_features", signature(object = "familiarModel"), function( - object, - rank_table = NULL, - signature_features = NULL, - minimise_footprint = FALSE, - ...) { - if (is.null(signature_features)) { - # Get signature features using the table with ranked features. Those - # features may be clustered. - signature_features <- get_signature( - object = object, - rank_table = rank_table) - } + 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. + # 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. + 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) + feature_info_list = object@feature_info + ) if (minimise_footprint) { # Find only features that are required for running the model. @@ -1254,7 +1279,8 @@ setMethod( required_features <- get_required_features( x = union(model_features, novelty_features), is_clustered = FALSE, - feature_info_list = object@feature_info) + feature_info_list = object@feature_info + ) } # Select only necessary feature info objects. @@ -1272,127 +1298,150 @@ setMethod( -# get_signature (familiarModel)------------------------------------------------- +# get_signature_features (familiarModel)---------------------------------------- setMethod( - "get_signature", + "get_signature_features", signature(object = "familiarModel"), function( - object, - rank_table = NULL, - ...) { + 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)) + feature_info_list = object@feature_info + )) } # Get signature based on the stored feature information. - return(do.call( - get_signature, - args = list( - "object" = object@feature_info, - "vimp_method" = object@fs_method, - "parameter_list" = object@hyperparameters, - "rank_table" = rank_table))) + return(.get_signature_features(object)) } ) -# get_signature (list)---------------------------------------------------------- -setMethod( - "get_signature", - signature(object = "list"), - function( - object, - vimp_method, - parameter_list, - rank_table, - ...) { - # Suppress NOTES due to non-standard evaluation in data.table - name <- rank <- NULL - - # Get signature size - if (is_empty(parameter_list$sign_size)) { - signature_size <- 0 - } else { - signature_size <- parameter_list$sign_size +.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" + ) } - - # Find features that are pre-assigned to the signature. - signature_features <- names(object)[sapply(object, is_in_signature)] - - if (vimp_method %in% .get_available_signature_only_vimp_methods()) { - # Only select signature. - if (length(signature_features) == 0) stop("No signature was provided.") - - selected_features <- signature_features + + 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 + ) - } else if (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_list = object) - - # Order randomly so that there is no accidental dependency on order. - selected_features <- fam_sample( - x = selected_features, - size = length(selected_features), - replace = FALSE) + # Remove signature features, if any, to prevent duplicates. + features <- setdiff(features, signature_features) - } else if (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_list = object) - - # 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) + # 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) - } else if (vimp_method %in% .get_available_no_features_vimp_methods()) { - # No features are selected. - selected_features <- NULL + # Get aggregate variable importances + vimp_table <- aggregate_vimp_table( + vimp_table, + aggregation_method = object@vimp_aggregation_method, + rank_threshold = object@vimp_rank_threshold + ) - } 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 > 0 && !is_empty(rank_table)) { - # Get available features. - features <- features_after_clustering( - features = get_available_features(feature_info_list = object), - feature_info_list = object) - - # Remove signature features, if any, to prevent duplicates. - features <- setdiff(features, signature_features) - - # Keep only feature ranks of feature corresponding to available - # features, and order by rank. - rank_table <- rank_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) - } + 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) } -) + + return(selected_features) +} diff --git a/R/FamiliarNoveltyDetector.R b/R/FamiliarNoveltyDetector.R index cfc2d675..f2ca92e7 100644 --- a/R/FamiliarNoveltyDetector.R +++ b/R/FamiliarNoveltyDetector.R @@ -7,19 +7,21 @@ setMethod( ".train", signature( object = "familiarNoveltyDetector", - data = "dataObject"), + data = "dataObject" + ), function( object, data, get_additional_info = FALSE, is_pre_processed = FALSE, trim_model = TRUE, - timeout = 60000, - ...) { + timeout = 60000.0, + ... + ) { # Train method for novelty detectors. # Check if the class of object is a subclass of familiarNoveltyDetector.. - if (!is_subclass(class(object)[1], "familiarNoveltyDetector")) { + if (!is_subclass(class(object)[1L], "familiarNoveltyDetector")) { object <- promote_detector(object) } @@ -29,7 +31,8 @@ setMethod( data = data, is_pre_processed = is_pre_processed, stop_at = "clustering", - force_check = TRUE) + force_check = TRUE + ) # Set the training flag can_train <- TRUE @@ -44,7 +47,7 @@ setMethod( # Check if the hyperparameters are plausible. if (!has_optimised_hyperparameters(object = object)) can_train <- FALSE - + # Train a new model based on data. if (can_train) object <- ..train(object = object, data = data) @@ -53,9 +56,10 @@ setMethod( # Add column data object <- add_data_column_info( object = object, - data = data) + data = data + ) } - + if (trim_model) object <- trim_model(object = object, timeout = timeout) # Empty slots if a model can not be trained. @@ -80,17 +84,19 @@ setMethod( if (!model_is_trained(object)) { cat(paste0( - "A ", object@learner, " novelty detector (class: ", class(object)[1], + "A ", object@learner, " novelty detector (class: ", class(object)[1L], ") that was not successfully trained (", - .familiar_version_string(object), ").\n")) + .familiar_version_string(object), ").\n" + )) return(invisible(NULL)) } # Describe the learner and the version of familiar. message_str <- paste0( - "A ", object@learner, " novelty detector (class: ", class(object)[1], - "; ", .familiar_version_string(object), ")") + "A ", object@learner, " novelty detector (class: ", class(object)[1L], + "; ", .familiar_version_string(object), ")" + ) # Describe the package(s), if any if (!is.null(object@package)) { @@ -100,8 +106,10 @@ setMethod( paste_s(mapply( ..message_package_version, x = object@package, - version = object@package_version)), - ifelse(length(object@package) > 1, " packages", " package")) + version = object@package_version + )), + ifelse(length(object@package) > 1L, " packages", " package") + ) } # Complete message and write. @@ -126,14 +134,16 @@ setMethod( function(x, object) { cat(paste0(" ", x, ": ", object@hyperparameters[[x]], "\n")) }, - object = object)) + object = object + )) # Details concerning model features: cat("\nThe following features were used for the novelty detector:\n") lapply( object@model_features, function(x, object) show(object@feature_info[[x]]), - object = object) + object = object + ) # Check package version. check_package_version(object) @@ -150,24 +160,28 @@ setMethod( 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", "predict")) { - purpose <- switch(purpose, + purpose <- switch( + purpose, "train" = "to train a novelty detector", "predict" = "to assess novelty", - "show" = "to capture output") + "show" = "to capture output" + ) } } return(invisible(.require_package( x = x@package, purpose = purpose, - message_type = message_type))) + message_type = message_type + ))) } ) @@ -184,7 +198,8 @@ setMethod( # Obtain package versions. object@package_version <- sapply( object@package, - function(x) (as.character(utils::packageVersion(x)))) + function(x) (as.character(utils::packageVersion(x))) + ) return(object) } @@ -201,7 +216,8 @@ setMethod( .check_package_version( name = object@package, version = object@package_version, - when = "when creating the novelty detector") + when = "when creating the novelty detector" + ) } ) @@ -254,7 +270,8 @@ setMethod( "..train", signature( object = "familiarNoveltyDetector", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Set a NULL model object@model <- NULL @@ -270,7 +287,8 @@ setMethod( "..train", signature( object = "familiarNoveltyDetector", - data = "NULL"), + data = "NULL" + ), function(object, data, ...) { # Set a NULL model object@model <- NULL @@ -286,12 +304,10 @@ setMethod( "..predict", signature( object = "familiarNoveltyDetector", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { - return(get_placeholder_prediction_table( - object = object, - data = data, - type = "novelty")) + return(NULL) } ) @@ -301,7 +317,7 @@ setMethod( setMethod( "trim_model", signature(object = "familiarNoveltyDetector"), - function(object, timeout = 60000, ...) { + function(object, timeout = 60000.0, ...) { # Do not trim the model if there is nothing to trim. if (!model_is_trained(object)) return(object) @@ -315,7 +331,8 @@ setMethod( trimmed_object <- .replace_broken_functions( object = object, trimmed_object = trimmed_object, - timeout = timeout) + timeout = timeout + ) return(trimmed_object) } @@ -353,7 +370,8 @@ setMethod( data = NULL, sample_id_column = NULL, batch_id_column = NULL, - series_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) @@ -388,7 +406,8 @@ setMethod( 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)) + "external" = c(batch_id_column, sample_id_column, series_id_column, repetition_id_column) + ) # Combine into one table and add to object object@data_column_info <- data_info_table @@ -396,3 +415,151 @@ setMethod( return(object) } ) + + + +# set_model_features (familiarNoveltyDetector)---------------------------------- +setMethod( + "set_model_features", + signature(object = "familiarNoveltyDetector"), + function( + object, + signature_features = NULL, + minimise_footprint = FALSE, + ... + ) { + + if (is.null(signature_features)) { + # Get signature features. This is a list features after clustering. + signature_features <- get_signature_features(object = object) + } + + # Find novelty features. The resulting list of features are features prior + # to clustering. + novelty_features <- find_novelty_features( + model_features = features_before_clustering( + features = signature_features, + feature_info_list = object@feature_info, + representative_only = TRUE + ), + feature_info_list = object@feature_info + ) + + if (minimise_footprint) { + # Find only features that are required for running the model. + required_features <- novelty_features + + } else { + # Find features that are required for processing the data. + required_features <- get_required_features( + x = 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 <- novelty_features + + return(object) + } +) + + + +# get_signature_features (familiarNoveltyDetector)------------------------------ +setMethod( + "get_signature_features", + signature(object = "familiarNoveltyDetector"), + 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)) + } +) + + + +# set_object_name (familiarNoveltyDetector) ------------------------------------ + +#' @title Set the name of a `familiarNoveltyDetector` object. +#' +#' @description Set the `name` slot using the object name. +#' +#' @param x A `familiarNoveltyDetector` object. +#' +#' @return A `familiarNoveltyDetector` object with a generated or a provided name. +#' @md +#' @keywords internal +setMethod( + "set_object_name", + signature(x = "familiarNoveltyDetector"), + 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 = "familiarNoveltyDetector"), + 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 = "familiarNoveltyDetector", + with_extension = FALSE + ) + } + + return(model_name) + } +) diff --git a/R/FamiliarObjectConversion.R b/R/FamiliarObjectConversion.R index cb85c960..f030e419 100644 --- a/R/FamiliarObjectConversion.R +++ b/R/FamiliarObjectConversion.R @@ -20,7 +20,10 @@ NULL #' @exportMethod as_familiar_ensemble #' @md #' @rdname as_familiar_ensemble-methods -setGeneric("as_familiar_ensemble", function(object, ...) standardGeneric("as_familiar_ensemble")) +setGeneric( + "as_familiar_ensemble", + function(object, ...) standardGeneric("as_familiar_ensemble") +) @@ -47,11 +50,28 @@ setMethod( # A separate familiar model is encapsulated in a list, and then transformed. return(do.call( as_familiar_ensemble, - args = list("object" = list(object)))) + args = list("object" = list(object)) + )) } ) +## as_familiar_ensemble (novelty) ---------------------------------------------- + +#' @rdname as_familiar_ensemble-methods +setMethod( + "as_familiar_ensemble", + signature(object = "familiarNoveltyDetector"), + function(object, ...) { + # A separate familiar novelty detector is encapsulated in a list, and then + # transformed. + return(do.call( + as_familiar_ensemble, + args = list("object" = list(object)) + )) + } +) + ## as_familiar_ensemble (list) ------------------------------------------------- @@ -66,11 +86,17 @@ setMethod( object <- load_familiar_object(object = object) # Return the object if it contains a single familiarEnsemble. - if (length(object) == 1 && all(sapply(object, is, "familiarEnsemble"))) { - return(object[[1]]) + if (length(object) == 1L && all(sapply(object, is, "familiarEnsemble"))) { + return(object[[1L]]) - } else if (!all(sapply(object, is, "familiarModel"))) { - stop("familiarEnsemble objects can only be constructed from familiarModel objects.") + } else if ( + !all(sapply(object, is, "familiarModel")) && + !all(sapply(object, is, "familiarNoveltyDetector")) + ) { + ..error(paste0( + "familiarEnsemble objects can only be constructed from familiarModel ", + "or familiarNoveltyDetector objects." + )) } # Generate a placeholder pooling table @@ -79,23 +105,31 @@ setMethod( "run_id" = 0L, "can_pre_process" = TRUE, "perturbation" = "new_data", - "perturb_level" = 0L) - + "perturb_level" = 0L + ) + + vimp_method <- ifelse( + methods::.hasSlot(object[[1L]], "vimp_method"), + object[[1L]]@vimp_method, + "none" + ) + # Generate a skeleton familiarEnsemble - fam_ensemble <- methods::new("familiarEnsemble", + fam_ensemble <- methods::new( + "familiarEnsemble", model_list = object, - learner = object[[1]]@learner, - fs_method = object[[1]]@fs_method, - run_table = list( - "run_table" = run_table, - "ensemble_data_id" = 0L, - "ensemble_run_id" = 0L)) + learner = object[[1L]]@learner, + vimp_method = vimp_method, + run_table = run_table + ) # Add package version. fam_ensemble <- add_package_version(object = fam_ensemble) # Complete the ensemble using information provided by the model(s) - fam_ensemble <- complete_familiar_ensemble(object = fam_ensemble) + fam_ensemble <- complete_familiar_ensemble( + object = fam_ensemble + ) return(fam_ensemble) } @@ -114,7 +148,8 @@ setMethod( # list objects. return(do.call( as_familiar_ensemble, - args = list("object" = as.list(object)))) + args = list("object" = as.list(object)) + )) } ) @@ -130,7 +165,8 @@ setMethod( # functions. ..error_cannot_convert_to_familiar_object( object = object, - expected_class = "familiarEnsemble") + expected_class = "familiarEnsemble" + ) } ) @@ -149,7 +185,7 @@ setMethod( #' @param name Name of the `familiarData` object. If not set, a name is #' automatically generated. #' -#' @inheritDotParams extract_data +#' @inheritDotParams .extract_data #' #' @details The `data` argument is required if `familiarEnsemble` or #' `familiarModel` objects are provided. @@ -187,7 +223,9 @@ setMethod( extract_data, args = c( list("object" = object), - list(...))) + list(...) + ) + ) # Set a placeholder name or a user-provided name for the familiarData # object. @@ -199,6 +237,60 @@ setMethod( +## as_familiar_data (prediction table) ----------------------------------------- + +#' @rdname as_familiar_data-methods +setMethod( + "as_familiar_data", + signature(object = "familiarDataElementPredictionTable"), + function(object, name = NULL, ...) { + # Familiar data + fam_data <- do.call( + extract_data, + args = c( + list("object" = object), + list(...) + ) + ) + + # Set a placeholder name or a user-provided name for the familiarData + # object. + fam_data <- set_object_name(x = fam_data, new = name) + + return(fam_data) + } +) + + +## as_familiar_data (dataObject) ----------------------------------------------- + +#' @rdname as_familiar_data-methods +setMethod( + "as_familiar_data", + signature(object = "dataObject"), + function(object, name = NULL, ...) { + + # Familiar data + fam_data <- do.call( + extract_data, + args = c( + list("object" = object), + list(...) + ) + ) + + # Set name of the current batch as name. + if (is.null(name)) name <- as.character(object@data[[get_id_columns("batch")]][1L]) + + # Set a name derived from the batch identifier or a user-provided name for + # the familiarData object. + fam_data <- set_object_name(x = fam_data, new = name) + + return(fam_data) + } +) + + ## as_familiar_data (model) ---------------------------------------------------- #' @rdname as_familiar_data-methods @@ -212,7 +304,9 @@ setMethod( as_familiar_data, args = c( list("object" = list(object)), - list(...)))) + list(...) + ) + )) } ) @@ -230,31 +324,51 @@ setMethod( # uniqueness of classes. object <- load_familiar_object(object = object) - # Return the object if it contains a single familiarEnsemble. - if (length(object) == 1 && all(sapply(object, is, "familiarData"))) { - return(object[[1]]) + # Return the object if it contains a single familiarData object. + if (length(object) == 1L && all(sapply(object, is, "familiarData"))) { + return(object[[1L]]) } + # Parse prediction table. + if (all(sapply(object, is, "familiarDataElementPredictionTable"))) { + return(lapply(object, as_familiar_data, ...)) + } + + # Parse dataObject. + if (all(sapply(object, is, "dataObject"))) { + # Split by batch-id. + object <- lapply(object, .split_data_by_batch_id) + + # Flatten list. + object <- unlist(object, recursive = FALSE) + if (!rlang::is_bare_list(object)) object <- list(object) + + return(lapply(object, as_familiar_data, ...)) + } + # Convert familiarModel(s) to familiarEnsemble. if (all(sapply(object, is, "familiarModel"))) { object <- list(as_familiar_ensemble(object = object)) } - + # Check if a single familiarEnsemble has been supplied or generated. - if (!all(sapply(object, is, "familiarEnsemble")) || length(object) > 1) { - stop(paste0( + if (!all(sapply(object, is, "familiarEnsemble")) || length(object) > 1L) { + ..error(paste0( "A familiarData object can only be constructed from a ", - "single familiarEnsemble object.")) + "single familiarEnsemble object." + )) } else { - object <- object[[1]] + object <- object[[1L]] } return(do.call( as_familiar_data, args = c( list("object" = object), - list(...)))) + list(...) + ) + )) } ) @@ -272,7 +386,9 @@ setMethod( as_familiar_data, args = c( list("object" = as.list(object)), - list(...)))) + list(...) + ) + )) } ) @@ -289,7 +405,8 @@ setMethod( # functions. ..error_cannot_convert_to_familiar_object( object = object, - expected_class = "familiarData") + expected_class = "familiarData" + ) } ) @@ -307,11 +424,16 @@ setMethod( #' object. It is also possible to provide a `familiarEnsemble` or one or more #' `familiarModel` objects together with the data from which data is computed #' prior to export. Paths to such files can also be provided. +#' +#' Additionally, some `familiarData` objects can be created from prediction +#' tables (`familiarDataElementPredictionTable`). Other `familiarData` objects +#' can be created from data (`dataObject`, or `data.table`). Please +#' check *details* for more information. #' @param familiar_data_names Names of the dataset(s). Only used if the `object` #' parameter is one or more `familiarData` objects. #' @param collection_name Name of the collection. #' -#' @inheritDotParams extract_data +#' @inheritDotParams .extract_data #' #' @details A `data` argument is expected if the `object` argument is a #' `familiarEnsemble` object or one or more `familiarModel` objects. @@ -326,7 +448,8 @@ setGeneric( object, familiar_data_names = NULL, collection_name = NULL, - ...) { + ... + ) { standardGeneric("as_familiar_collection") } ) @@ -356,7 +479,8 @@ setMethod( object, familiar_data_names = NULL, collection_name = NULL, - ...) { + ... + ) { # Pass to as_familiar_collection for lists to load and process objects # there. return(do.call( @@ -365,8 +489,11 @@ setMethod( list( "object" = list(object), "familiar_data_names" = familiar_data_names, - "collection_name" = collection_name), - list(...)))) + "collection_name" = collection_name + ), + list(...) + ) + )) } ) @@ -382,7 +509,8 @@ setMethod( object, familiar_data_names = NULL, collection_name = NULL, - ...) { + ... + ) { # Pass to as_familiar_collection for lists to load and process objects # there. return(do.call( @@ -391,8 +519,11 @@ setMethod( list( "object" = list(object), "familiar_data_names" = familiar_data_names, - "collection_name" = collection_name), - list(...)))) + "collection_name" = collection_name + ), + list(...) + ) + )) } ) @@ -408,7 +539,8 @@ setMethod( object, familiar_data_names = NULL, collection_name = NULL, - ...) { + ... + ) { # Pass to as_familiar_collection for lists to load and process objects # there. return(do.call( @@ -417,12 +549,132 @@ setMethod( list( "object" = list(object), "familiar_data_names" = familiar_data_names, - "collection_name" = collection_name), - list(...)))) + "collection_name" = collection_name + ), + list(...) + ) + )) + } +) + + +## as_familiar_collection (prediction table) ----------------------------------- + +#' @rdname as_familiar_collection-methods +setMethod( + "as_familiar_collection", + signature(object = "familiarDataElementPredictionTable"), + function( + object, + familiar_data_names = NULL, + collection_name = NULL, + ... + ) { + # Pass to as_familiar_collection for lists to load and process objects + # there. + return(do.call( + as_familiar_collection, + args = c( + list( + "object" = list(object), + "familiar_data_names" = familiar_data_names, + "collection_name" = collection_name + ), + list(...) + ) + )) + } +) + + + +## as_familiar_collection (dataObject) ----------------------------------------- + +#' @rdname as_familiar_collection-methods +setMethod( + "as_familiar_collection", + signature(object = "dataObject"), + function( + object, + familiar_data_names = NULL, + collection_name = NULL, + ... + ) { + # Pass to as_familiar_collection + return(do.call( + as_familiar_collection, + args = c( + list( + "object" = list(object), + "familiar_data_names" = familiar_data_names, + "collection_name" = collection_name + ), + list(...) + )) + ) } ) +## as_familiar_collection (data.table) ----------------------------------------- + +#' @rdname as_familiar_collection-methods +setMethod( + "as_familiar_collection", + signature(object = "data.table"), + function( + object, + familiar_data_names = NULL, + collection_name = NULL, + ... + ) { + dots <- list(...) + + # Extract outcome_type and outcome_column to provide overrides. + outcome_type <- dots$outcome_type + dots$outcome_type <- NULL + if (is.null(outcome_type)) outcome_type <- waiver() + + outcome_column <- dots$outcome_column + dots$outcome_column <- NULL + if (is.null(outcome_column)) outcome_column <- waiver() + + if (is.waive(outcome_column) || is.waive(outcome_type)) outcome_type <- "unsupervised" + + # Extract .no_features_required to override checks on features in as_data_object. + .no_features_required <- dots$.no_features_required + dots$.no_features_required <- NULL + if (is.null(.no_features_required)) .no_features_required <- FALSE + + # Convert to dataObject. + object <- do.call( + as_data_object, + args = c( + list( + "data" = object, + "outcome_column" = outcome_column, + "outcome_type" = outcome_type, + ".no_features_required" = .no_features_required + ), + dots + ) + ) + + # Pass to method for dataObject. + return(do.call( + as_familiar_collection, + args = c( + list( + "object" = object, + "familiar_data_names" = familiar_data_names, + "collection_name" = collection_name + ), + dots + ) + )) + } +) + ## as_familiar_collection (list) ----------------------------------------------- @@ -433,18 +685,20 @@ setMethod( function( object, familiar_data_names = NULL, - collection_name = NULL, ...) { + collection_name = NULL, + ... + ) { # Load familiar objects. This does nothing if the list already contains only # familiar S4 objects, but will load any files from the path and will check # uniqueness of classes. object <- load_familiar_object(object = object) # Return the object if it contains a single familiarCollection. - if (length(object) == 1 && all(sapply(object, is, class2 = "familiarCollection"))) { - return(object[[1]]) + if (length(object) == 1L && all(sapply(object, is, class2 = "familiarCollection"))) { + return(object[[1L]]) } else if (all(sapply(object, is, class2 = "familiarCollection"))) { - stop("Only a single familiarCollection can be returned.") + ..error("Only a single familiarCollection can be returned.") } # Convert to familiarModel(s) to familiarData @@ -453,27 +707,60 @@ setMethod( as_familiar_data, args = c( list("object" = object), - list(...))) + list(...) + ) + ) # Store in list, if required if (!is(object, "list")) object <- list(object) } # Convert familiarEnsemble to familiarData - if (all(sapply(object, is, class2 = "familiarEnsemble")) && length(object) == 1) { + if (all(sapply(object, is, class2 = "familiarEnsemble")) && length(object) == 1L) { object <- do.call( as_familiar_data, args = c( list("object" = object), - list(...))) - + list(...) + ) + ) + # Store in list, if required. if (!is(object, "list")) object <- list(object) } else if (all(sapply(object, is, class2 = "familiarEnsemble"))) { - stop("A familiarData object can only be constructed from a single familiarEnsemble object.") + ..error("A familiarData object can only be constructed from a single familiarEnsemble object.") } + # Convert prediction table objects to familiarData. + if (all(sapply(object, is, class2 = "familiarDataElementPredictionTable"))) { + object <- do.call( + as_familiar_data, + args = c( + list("object" = object), + list(...) + ) + ) + + # Store in list, if required. + if (!is(object, "list")) object <- list(object) + } + + # Convert dataObject objects to familiarData. + if (all(sapply(object, is, class2 = "dataObject"))) { + object <- do.call( + as_familiar_data, + args = c( + list("object" = object), + list(...) + ) + ) + + # Store in list, if required. + if (!is(object, "list")) object <- list(object) + } + + # Check if all objects at this moments are familiarData objects. if (!all(sapply(object, is, class2 = "familiarData"))) { stop("Only familiarData objects can be used to construct a familiarCollection object.") } @@ -481,14 +768,6 @@ setMethod( # Obtain names of the familiarData objects. object_names <- sapply(object, function(fam_data_obj) (fam_data_obj@name)) - # Check if all the datasets are unique. - if (any(duplicated(object_names))) { - stop(paste0( - "familiarCollections cannot contain identical familiarData sets. ", - "The following duplicates were found: ", - paste_s(unique(object_names[duplicated(object_names)])))) - } - # Check if names for the data are externally provided, and obtain them from # the familiarData objects otherwise. if (is.null(familiar_data_names)) { @@ -499,6 +778,13 @@ setMethod( if (!is.factor(familiar_data_names)) { familiar_data_names <- factor(familiar_data_names, levels = unique(familiar_data_names)) } + + # Get names ordered correctly without duplicates. + data_set_table <- data.table::data.table( + name_object = object_names, + name_used = familiar_data_names + ) + data_set_table <- unique(data_set_table) # Check if the collection has a name if (is.null(collection_name)) { @@ -506,91 +792,120 @@ setMethod( } else { collection_name <- as.character(collection_name) } - + # Generate data names fam_collect <- methods::new("familiarCollection", name = collection_name, data_sets = sapply( object, - function(fam_data_obj) (fam_data_obj@name)), - outcome_type = object[[1]]@outcome_type, + function(fam_data_obj) (fam_data_obj@name) + ), + outcome_type = object[[1L]]@outcome_type, outcome_info = .aggregate_outcome_info(x = lapply( object, - function(list_elem) (list_elem@outcome_info))), + function(list_elem) (if (methods::.hasSlot(list_elem, "outcome_info")) return(list_elem@outcome_info)) + )), fs_vimp = collect( x = object, data_slot = "fs_vimp", - identifiers = c("fs_method")), + identifiers = c("vimp_method") + ), model_vimp = collect( x = object, data_slot = "model_vimp", - identifiers = c("fs_method", "learner")), + identifiers = c("vimp_method", "learner") + ), permutation_vimp = collect( x = object, - data_slot = "permutation_vimp"), + data_slot = "permutation_vimp" + ), hyperparameters = collect( x = object, data_slot = "hyperparameters", - identifiers = c("fs_method", "learner")), + identifiers = c("vimp_method", "learner") + ), hyperparameter_data = NULL, required_features = unique(unlist(lapply( object, - function(fam_data_obj) (fam_data_obj@required_features)))), + function(fam_data_obj) (fam_data_obj@required_features) + ))), model_features = unique(unlist(extract_from_slot( object_list = object, slot_name = "model_features", - na.rm = TRUE))), + na.rm = TRUE + ))), learner = unique(sapply( object, - function(fam_data_obj) (fam_data_obj@learner))), - fs_method = unique(sapply( + function(fam_data_obj) (fam_data_obj@learner) + )), + vimp_method = unique(sapply( object, - function(fam_data_obj) (fam_data_obj@fs_method))), + function(fam_data_obj) (fam_data_obj@vimp_method) + )), prediction_data = collect( x = object, - data_slot = "prediction_data"), + data_slot = "prediction_data" + ), confusion_matrix = collect( x = object, - data_slot = "confusion_matrix"), + data_slot = "confusion_matrix" + ), decision_curve_data = collect( x = object, - data_slot = "decision_curve_data"), + data_slot = "decision_curve_data" + ), calibration_info = collect( x = object, data_slot = "calibration_info", - identifiers = c("fs_method", "learner")), + identifiers = c("vimp_method", "learner") + ), calibration_data = collect( x = object, - data_slot = "calibration_data"), + data_slot = "calibration_data" + ), model_performance = collect( x = object, - data_slot = "model_performance"), + data_slot = "model_performance" + ), km_info = collect( x = object, data_slot = "km_info", - identifiers = c("fs_method", "learner")), + identifiers = c("vimp_method", "learner") + ), km_data = collect( x = object, - data_slot = "km_data"), + data_slot = "km_data" + ), auc_data = collect( x = object, - data_slot = "auc_data"), + data_slot = "auc_data" + ), univariate_analysis = collect( x = object, - data_slot = "univariate_analysis"), + data_slot = "univariate_analysis" + ), feature_expressions = collect( x = object, - data_slot = "feature_expressions"), + data_slot = "feature_expressions" + ), feature_similarity = collect( x = object, - data_slot = "feature_similarity"), + data_slot = "feature_similarity" + ), sample_similarity = collect( x = object, - data_slot = "sample_similarity"), + data_slot = "sample_similarity" + ), ice_data = collect( x = object, - data_slot = "ice_data"), - project_id = object[[1]]@project_id) + data_slot = "ice_data" + ), + shap_data = collect( + x = object, + data_slot = "shap_data" + ), + project_id = object[[1L]]@project_id + ) # Add a package version to the familiarCollection object fam_collect <- add_package_version(object = fam_collect) @@ -598,8 +913,10 @@ setMethod( # Create labels for the data names for correct ordering of plots etc. fam_collect <- set_data_set_names( x = fam_collect, - new = as.character(familiar_data_names), - order = levels(familiar_data_names)) + old = data_set_table$name_object, + new = as.character(data_set_table$name_used), + order = levels(data_set_table$name_used) + ) return(fam_collect) } @@ -615,7 +932,9 @@ setMethod( function( object, familiar_data_names = NULL, - collection_name = NULL, ...) { + collection_name = NULL, + ... + ) { # Pass to as_familiar_collection for lists to load and process objects # there. return(do.call( @@ -624,8 +943,11 @@ setMethod( list( "object" = as.list(object), "familiar_data_names" = familiar_data_names, - "collection_name" = collection_name), - list(...)))) + "collection_name" = collection_name + ), + list(...) + ) + )) } ) @@ -641,7 +963,8 @@ setMethod( # previous methods. ..error_cannot_convert_to_familiar_object( object = object, - expected_class = "familiarCollection") + expected_class = "familiarCollection" + ) } ) @@ -654,23 +977,28 @@ setMethod( # Determine if file(s) exist existing_files <- sapply(object, file.exists) if (!all(existing_files)) { - stop(paste0( + ..error(paste0( "Not all files could be found: ", - paste_s(object[!existing_files]))) + paste_s(object[!existing_files]) + )) } # Load object fam_object <- lapply(object, readRDS) # Check that all objects have the correct class. - if (!(all(sapply(fam_object, is, class2 = "familiarModel")) || - all(sapply(fam_object, is, class2 = "familiarEnsemble")) || - all(sapply(fam_object, is, class2 = "familiarData")) || - all(sapply(fam_object, is, class2 = "familiarCollection")))) { - stop(paste0( + if (!( + all(sapply(fam_object, is, class2 = "familiarModel")) || + all(sapply(fam_object, is, class2 = "familiarNoveltyDetector")) || + all(sapply(fam_object, is, class2 = "familiarEnsemble")) || + all(sapply(fam_object, is, class2 = "familiarData")) || + all(sapply(fam_object, is, class2 = "familiarCollection")) + )) { + ..error(paste0( "Could not load familiar objects because they are not uniquely ", - "familiarModel, familiarEnsemble, familiarData or ", - "familiarCollection objects.")) + "familiarModel, familiarNoveltyDetector, familiarEnsemble, familiarData or ", + "familiarCollection objects." + )) } # Update the objects for backward compatibility @@ -681,11 +1009,12 @@ setMethod( fam_object <- mapply( ..update_model_list, object = fam_object, - dir_path = object) + dir_path = object + ) } # Unlist if the input is singular. - if (length(object) == 1) fam_object <- fam_object[[1]] + if (length(object) == 1L) fam_object <- fam_object[[1L]] return(fam_object) } @@ -702,14 +1031,21 @@ setMethod( fam_object <- lapply(object, load_familiar_object) # Check that all objects have the correct class. - if (!(all(sapply(fam_object, is, class2 = "familiarModel")) || - all(sapply(fam_object, is, class2 = "familiarEnsemble")) || - all(sapply(fam_object, is, class2 = "familiarData")) || - all(sapply(fam_object, is, class2 = "familiarCollection")))) { - stop(paste0( + if (!( + all(sapply(fam_object, is, class2 = "familiarModel")) || + all(sapply(fam_object, is, class2 = "familiarNoveltyDetector")) || + all(sapply(fam_object, is, class2 = "familiarEnsemble")) || + all(sapply(fam_object, is, class2 = "familiarData")) || + all(sapply(fam_object, is, class2 = "familiarCollection")) || + all(sapply(fam_object, is, class2 = "dataObject")) || + all(sapply(fam_object, is, class2 = "familiarDataElementPredictionTable")) + )) { + ..error(paste0( "Could not load familiar objects because they are not uniquely ", - "familiarModel, familiarEnsemble, familiarData or familiarCollection ", - "objects.")) + "familiarDataElementPredictionTable", "dataObject", + "familiarModel, familiarNoveltyDetector, familiarEnsemble, familiarData ", + "or familiarCollection objects. Do not mix objects with different classes." + )) } # Update the objects for backward compatibility @@ -720,6 +1056,27 @@ setMethod( ) +# load_familiar_object (prediction table) -------------------------------------- +setMethod( + "load_familiar_object", + signature(object = "familiarDataElementPredictionTable"), + function(object) { + return(object) + } +) + + + +# load_familiar_object (dataObject) +setMethod( + "load_familiar_object", + signature(object = "dataObject"), + function(object) { + return(object) + } +) + + # load_familiar_object (general) ----------------------------------------------- setMethod( @@ -730,16 +1087,19 @@ setMethod( # been loaded. Else throw an error. if (is_any(object, class2 = c( - "familiarModel", "familiarEnsemble", "familiarData", "familiarCollection"))) { + "familiarModel", "familiarNoveltyDetector", + "familiarEnsemble", "familiarData", "familiarCollection" + ))) { # Make sure the S4 object is updated. object <- update_object(object = object) return(object) } else { - stop(paste0( + ..error(paste0( "The loaded object is not a familiar S4 object. Found: ", - paste_s(class(object)))) + paste_s(class(object)) + )) } } ) diff --git a/R/FamiliarObjectUpdate.R b/R/FamiliarObjectUpdate.R index 4d7b3ac4..3cdbac52 100644 --- a/R/FamiliarObjectUpdate.R +++ b/R/FamiliarObjectUpdate.R @@ -11,6 +11,9 @@ NULL #' a file. This mitigates compatibility issues when working with files that #' become outdated as new versions of familiar are released, e.g. because #' slots have been removed. +#' +#' Major version releases (e.g., versions 1.0.0, 2.0.0) introduce breaking +#' changes which can result in objects that cannot be updated. #' #' @param object A `familiarModel`, a `familiarEnsemble`, a `familiarData` or #' `familiarCollection` object. @@ -31,104 +34,11 @@ setMethod( "update_object", signature(object = "familiarModel"), function(object, ...) { - if (tail(object@familiar_version, n = 1L) < "0.0.0.54") { - # Rename req_feature_cols to required_features - attr(object, "required_features") <- attr(object, "req_feature_cols") - attr(object, "req_feature_cols") <- NULL - - # Rename important_features to model_features - attr(object, "model_features") <- attr(object, "important_features") - attr(object, "important_features") <- NULL - - # Introduce missing novelty_features slot by copying model_features. - attr(object, "novelty_features") <- attr(object, "model_features") - - # Remove signature altogether. - attr(object, "signature") <- NULL - - # Check that the model has been successfully trained. Since version - # 0.0.0.54, features from models that have not been trained will not be - # retained for further evaluation. - if (!model_is_trained(object)) { - object@required_features <- NULL - object@model_features <- NULL - object@novelty_features <- NULL - } - - # Add name attribute. - attr(object, "name") <- NA_character_ - } - - if (tail(object@familiar_version, n = 1L) < "0.0.0.55") { - # Add missing attributes. - attr(object, "trimmed_function") <- list() - attr(object, "learner_package") <- character(0L) - attr(object, "learner_version") <- as.package_version("0.0.0") - - # Rename is_anonymised. - attr(object, "is_trimmed") <- attr(object, "is_anonymised") - attr(object, "is_anonymised") <- NULL - } - - if (tail(object@familiar_version, n = 1L) < "1.0.0") { - # Rename learner_package to package - attr(object, "package") <- attr(object, "learner_package") - if (is.na(object@package)) { - methods::slot(object, "package", check = FALSE) <- NULL - } - - # Rename learner_version to package_version - attr(object, "package_version") <- attr(object, "learner_version") - if (object@learner_version == as.package_version("0.0.0")) { - methods::slot(object, "package_version", check = FALSE) <- NULL - } - - # Remove learner_package and learner_version attributes. - attr(object, "learner_package") <- NULL - attr(object, "learner_version") <- NULL - - # Replace any novelty detector, since these are now proper classes. - methods::slot(object, "novelty_detector", check = FALSE) <- NULL - } - - if (tail(object@familiar_version, n = 1L) < "1.1.0") { - # Add placeholder messages attribute. - attr(object, "messages") <- list() - } - - # Update attached feature info objects. - feature_names <- names(object@feature_info) - if (length(feature_names) > 0) { - object@feature_info <- lapply( - object@feature_info, - update_object) - names(object@feature_info) <- feature_names - } - - # Update attached novelty detector - if (!is.null(object@novelty_detector)) { - object@novelty_detector <- update_object(object@novelty_detector) - } - - - if (tail(object@familiar_version, n = 1L) < "1.3.0" && - is(object, "familiarGLM")) { - # Add feature_order slot to familiarGLM objects. - attr(object, "feature_order") <- character() - } - - if (tail(object@familiar_version, n = 1L) < "1.4.0") { - # Add a robust slot to familiarMetricRegression objects. - for (ii in seq_along(object@hyperparameter_data$metric_object)) { - if (is(object@hyperparameter_data$metric_object[[ii]], "familiarMetricRegression")) { - attr(object@hyperparameter_data$metric_object[[ii]], "robust") <- "none" - } - } - } - - if (!methods::validObject(object)) { - stop("Could not update the familiarModel object to the most recent definition.") + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } + + if (!methods::validObject(object)) ..error_updated_object_invalid(object) # Update package version. object <- add_package_version(object = object) @@ -146,41 +56,12 @@ setMethod( "update_object", signature(object = "familiarEnsemble"), function(object, ...) { - if (tail(object@familiar_version, n = 1L) < "0.0.0.54") { - # Rename req_feature_cols to required_features - attr(object, "required_features") <- attr(object, "req_feature_cols") - attr(object, "req_feature_cols") <- NULL - - # Rename important_features to model_features - attr(object, "model_features") <- attr(object, "important_features") - attr(object, "important_features") <- NULL - - # Introduce missing novelty_features slot by copying - # model_features. - attr(object, "novelty_features") <- attr(object, "model_features") - - # Set default model_dir_path, auto_detach and name attributes. - attr(object, "model_dir_path") <- NA_character_ - attr(object, "auto_detach") <- FALSE - attr(object, "name") <- NA_character_ + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } - - if (tail(object@familiar_version, n = 1L) < "0.0.0.55") { - # Remove is_anonymised. - attr(object, "is_anonymised") <- NULL - } - - # Update attached feature info objects. - feature_names <- names(object@feature_info) - object@feature_info <- lapply( - object@feature_info, - update_object) - names(object@feature_info) <- feature_names - - if (!methods::validObject(object)) { - stop("Could not update the familiarEnsemble object to the most recent definition.") - } - + + if (!methods::validObject(object)) ..error_updated_object_invalid(object) + # Update package version. object <- add_package_version(object = object) @@ -193,106 +74,14 @@ setMethod( #' @rdname update_object-methods setMethod( - "update_object", signature(object = "familiarData"), + "update_object", + signature(object = "familiarData"), function(object, ...) { - if (tail(object@familiar_version, n = 1L) < "0.0.0.54") { - # Rename req_feature_cols to required_features - attr(object, "required_features") <- attr(object, "req_feature_cols") - attr(object, "req_feature_cols") <- NULL - - # Rename important_features to model_features - attr(object, "model_features") <- attr(object, "important_features") - attr(object, "important_features") <- NULL - - # Rename mutual_correlation to feature_similarity - attr(object, "feature_similarity") <- attr(object, "mutual_correlation") - attr(object, "mutual_correlation") <- NULL - - # Add sample_similarity. - attr(object, "sample_similarity") <- attr(list(), "non_existing_element") - } - - if (tail(object@familiar_version, n = 1L) < "0.0.0.55") { - # Remove is_anonymised. - attr(object, "is_anonymised") <- NULL - } - - if (tail(object@familiar_version, n = 1L) < "1.2.0") { - # Update variable importance lists. - # Update fs_vimp slot by iterating over its contents. - object@fs_vimp <- lapply( - object@fs_vimp, - function(x, project_id, fs_method) { - # Check if the current element is empty. - if (is_empty(x)) return(x) - - # Iterate over variable importance. - x@data <- lapply( - split(x@data, by = c("data_id", "run_id")), - function(x, fs_method, project_id) { - as_vimp_table_object( - x = list("vimp" = x, "fs_method" = fs_method), - project_id = project_id) - }, - fs_method = fs_method, - project_id = project_id - ) - - return(x) - }, - fs_method = object@fs_method, - project_id = object@project_id) - - # Update model_vimp slot by iterating over its contents. - object@model_vimp <- lapply( - object@model_vimp, - function(x, project_id, learner) { - # Check if the current element is empty. - if (is_empty(x)) return(x) - - # Iterate over variable importance. - x@data <- lapply( - split(x@data, by = c("data_id", "run_id")), - function(x, learner, project_id) { - as_vimp_table_object( - x = list("vimp" = x, "fs_method" = learner), - project_id = project_id) - }, - learner = learner, - project_id = project_id - ) - - return(x) - }, - learner = object@learner, - project_id = object@project_id) - - # Update feature_expressions slot by iterating over its contents. - object@feature_expressions <- lapply( - object@feature_expressions, - function(x) { - x@feature_info <- update_object(x@feature_info) - - return(x) - }) + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } - if (tail(object@familiar_version, n = 1L) < "1.5.0") { - # Update feature_expressions slot by iterating over its contents. This is - # to account for changes in transformation objects, introduced with 1.5.0. - object@feature_expressions <- lapply( - object@feature_expressions, - function(x) { - x@feature_info <- update_object(x@feature_info) - - return(x) - } - ) - } - - if (!methods::validObject(object)) { - stop("Could not update the familiarData object to the most recent definition.") - } + if (!methods::validObject(object)) ..error_updated_object_invalid(object) # Update package version. object <- add_package_version(object = object) @@ -309,103 +98,11 @@ setMethod( setMethod( "update_object", signature(object = "familiarCollection"), function(object, ...) { - if (tail(object@familiar_version, n = 1L) < "0.0.0.54") { - # Rename req_feature_cols to required_features - attr(object, "required_features") <- attr(object, "req_feature_cols") - attr(object, "req_feature_cols") <- NULL - - # Rename important_features to model_features - attr(object, "model_features") <- attr(object, "important_features") - attr(object, "important_features") <- NULL - - # Rename collection_name to name - attr(object, "name") <- attr(object, "collection_name") - attr(object, "collection_name") <- NULL - - # Rename mutual_correlation to feature_similarity - attr(object, "feature_similarity") <- attr(object, "mutual_correlation") - attr(object, "mutual_correlation") <- NULL - - # Add sample_similarity. - attr(object, "sample_similarity") <- attr(list(), "non_existing_element") - } - - if (tail(object@familiar_version, n = 1L) < "0.0.0.55") { - # Remove is_anonymised. - attr(object, "is_anonymised") <- NULL - } - - if (tail(object@familiar_version, n = 1L) < "1.2.0") { - # Update fs_vimp slot by iterating over its contents. - object@fs_vimp <- lapply( - object@fs_vimp, - function(x, project_id) { - # Check if the current element is empty. - if (is_empty(x)) return(x) - - # Iterate over variable importance. - x@data <- lapply( - split(x@data, by = c("data_id", "run_id")), - function(x, fs_method, project_id) { - as_vimp_table_object( - x = list("vimp" = x, "fs_method" = fs_method), - project_id = project_id) - }, - fs_method = x@identifiers$fs_method, - project_id = project_id) - - return(x) - }, - project_id = object@project_id) - - # Update model_vimp slot by iterating over its contents. - object@model_vimp <- lapply( - object@model_vimp, - function(x, project_id) { - # Check if the current element is empty. - if (is_empty(x)) return(x) - - # Iterate over variable importance. - x@data <- lapply( - split(x@data, by = c("data_id", "run_id")), - function(x, fs_method, project_id) { - as_vimp_table_object( - x = list("vimp" = x, "fs_method" = fs_method), - project_id = project_id) - }, - fs_method = x@identifiers$learner, - project_id = project_id) - - return(x) - }, - project_id = object@project_id) - - # Update feature_expressions slot by iterating over its contents. - object@feature_expressions <- lapply( - object@feature_expressions, - function(x) { - x@feature_info <- update_object(x@feature_info) - - return(x) - }) - } - - if (tail(object@familiar_version, n = 1L) < "1.5.0") { - # Update feature_expressions slot by iterating over its contents. This is - # to account for changes in transformation objects, introduced with 1.5.0. - object@feature_expressions <- lapply( - object@feature_expressions, - function(x) { - x@feature_info <- update_object(x@feature_info) - - return(x) - } - ) + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } - if (!methods::validObject(object)) { - stop("Could not update the familiarCollection object to the most recent definition.") - } + if (!methods::validObject(object)) ..error_updated_object_invalid(object) # Update package version. object <- add_package_version(object = object) @@ -437,17 +134,12 @@ setMethod( "update_object", signature(object = "familiarNoveltyDetector"), function(object, ...) { - # Update attached feature info objects. - feature_names <- names(object@feature_info) - if (length(feature_names) > 0) { - object@feature_info <- lapply(object@feature_info, update_object) - names(object@feature_info) <- feature_names - } - - if (!methods::validObject(object)) { - stop("Could not update the familiarNoveltyDetector object to the most recent definition.") + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } - + + if (!methods::validObject(object)) ..error_updated_object_invalid(object) + # Update package version. object <- add_package_version(object = object) @@ -460,247 +152,15 @@ setMethod( ## update_object (featureInfo) ------------------------------------------------- #' @rdname update_object-methods setMethod( - "update_object", signature(object = "featureInfo"), + "update_object", + signature(object = "featureInfo"), function(object, ...) { - - # Add a placeholder familiar version slot if necessary. - if (!methods::.hasSlot(object, "familiar_version")) { - attr(object, "familiar_version") <- as.package_version("0.0.0") - } - - if (tail(object@familiar_version, n = 1L) < "1.2.0") { - # Prior to version 1.2.0, information used to process features was stored - # in ad-hoc lists. Since version 1.2.0 these have been replaced by S4 - # objects, which allows for much cleaner testing and updating. - - # Check if the object is generic/unset or was filled. - is_unset <- is.null(object@transformation_parameters) && - is.null(object@normalisation_parameters) && - is.null(object@batch_normalisation_parameters) && - is.null(object@imputation_parameters) && - is.null(object@cluster_parameters) - - # Only set attributes if a proper - if (!is_unset) { - ### Transformation ----------------------------------------------------- - - # Upgrade transformation parameters to a proper S4 object. - if (!is.null(object@transformation_parameters)) { - object@transformation_parameters <- ..create_transformation_parameter_skeleton( - feature_name = object@name, - feature_type = object@feature_type, - available = is_available(object), - method = object@transformation_parameters$transform_method, - lambda = object@transformation_parameters$transform_lambda) - - } else { - object@transformation_parameters <- ..create_transformation_parameter_skeleton( - feature_name = object@name, - feature_type = object@feature_type, - available = is_available(object), - method = "none") - } - - # Revise familiar version, because these now correspond basically to - # version 1.4.8 and earlier. Version 1.5.0 introduces transformers from - # power.transform. - object@transformation_parameters@familiar_version[ - length(object@transformation_parameters@familiar_version) - ] <- package_version("1.4.8") - - ### Normalisation ------------------------------------------------------ - - # Upgrade normalisation parameters to a proper S4 object. - if (!is.null(object@normalisation_parameters)) { - object@normalisation_parameters <- ..create_normalisation_parameter_skeleton( - feature_name = object@name, - feature_type = object@feature_type, - available = is_available(object), - method = object@normalisation_parameters$norm_method, - shift = object@normalisation_parameters$norm_shift, - scale = object@normalisation_parameters$norm_scale) - - } else { - object@normalisation_parameters <- ..create_normalisation_parameter_skeleton( - feature_name = object@name, - feature_type = object@feature_type, - available = is_available(object), - method = "none") - } - - ### Batch normalisation ------------------------------------------------ - - # Upgrade batch normalisation parameters to a proper S4 object. - if (!is.null(object@batch_normalisation_parameters)) { - # Determine the method used for batch normalisation. - batch_normalisation_method <- unique(sapply( - object@batch_normalisation_parameters, - function(x) (x$norm_method))) - batch_normalisation_method <- setdiff( - batch_normalisation_method, c("none", "unknown")) - - if (is_empty(batch_normalisation_method)) { - batch_normalisation_method <- "none" - } - - } else { - batch_normalisation_method <- "none" - } - - # Add container. - batch_normalisation_parameters <- ..create_batch_normalisation_parameter_skeleton( - feature_name = object@name, - feature_type = object@feature_type, - available = is_available(object), - method = batch_normalisation_method) - - # Update the container contents. - batch_normalisation_parameters@batch_parameters <- mapply( - function(x, batch, object) { - return(..create_normalisation_parameter_skeleton( - feature_name = object@name, - feature_type = object@feature_type, - available = is_available(object), - method = x$norm_method, - batch = batch, - shift = x$norm_shift, - scale = x$norm_scale)) - }, - x = object@batch_normalisation_parameters, - batch = names(object@batch_normalisation_parameters), - MoreArgs = list("object" = object)) - - # Update names. - names(batch_normalisation_parameters@batch_parameters) <- names(object@batch_normalisation_parameters) - - # Update batch normalisations parameters in the object. - object@batch_normalisation_parameters <- batch_normalisation_parameters - - # Mark complete - object@batch_normalisation_parameters@complete <- TRUE - - ### Imputation --------------------------------------------------------- - - # Update imputation parameters to a proper S4 object. - imputation_method <- ifelse( - is.null(object@imputation_parameters), - "none", - "simple") - - # Create an S4 skeleton. - imputation_object <- ..create_imputation_parameter_skeleton( - feature_name = object@name, - feature_type = object@feature_type, - available = is_available(object), - method = imputation_method) - - # Attach to imputation object. - if (!is.null(object@imputation_parameters)) { - imputation_object@model <- object@imputation_parameters$common_value - } - - # Set required features. - imputation_object@required_features <- object@name - - # Mark complete - imputation_object@complete <- TRUE - - # Attach to object. - object@imputation_parameters <- imputation_object - - ### Clustering --------------------------------------------------------- - - if (!is.null(object@cluster_parameters)) { - # Set parameters -- we can't really infer cluster linkage or the - # similarity metric from available information, and set placeholders - # that will allow the cluster parameter object to be formed. - - # Create temporary feature info object to avoid an incorrect check. - temp_feature_object <- object - temp_feature_object@cluster_parameters <- NULL - - cluster_parameter_options <- list( - "feature_info" = temp_feature_object, - "method" = "hclust", - "cluster_cut_method" = "fixed_cut", - "cluster_representation_method" = object@cluster_parameters$method, - "cluster_linkage" = "average", - "cluster_similarity_metric" = "mcfadden_r2", - "cluster_similarity_threshold" = 0.3) - - # Form parameter object. - cluster_parameter_object <- do.call( - .create_cluster_parameter_skeleton, - args = cluster_parameter_options) - - # Extract cluster parameters. - cluster_parameter_object <- cluster_parameter_object@cluster_parameters - - # Set parameters. - cluster_parameter_object@weight <- object@cluster_parameters$weight - cluster_parameter_object@invert <- object@cluster_parameters$invert - cluster_parameter_object@cluster_name <- ifelse( - object@cluster_parameters$cluster_size > 1, - object@cluster_parameters$cluster_name, - object@name) - cluster_parameter_object@cluster_size <- object@cluster_parameters$cluster_size - cluster_parameter_object@required_features <- object@cluster_parameters$required_features - - # Previously, features that form the cluster were not stored as - # information. To prevent issues with functions that generate a - # cluster table, set the required features instead. - cluster_parameter_object@cluster_features <- unique(c( - object@cluster_parameters$required_features, - object@name)) - - # Mark complete. - cluster_parameter_object@complete <- TRUE - - # Replace in the feature info object. - object@cluster_parameters <- cluster_parameter_object - - } else { - # Assume singular cluster. - cluster_parameter_options <- list( - "feature_info" = object, - "method" = "none") - - # Form parameter object. - cluster_parameter_object <- do.call( - .create_cluster_parameter_skeleton, - args = cluster_parameter_options) - - # Extract cluster parameters. - cluster_parameter_object <- cluster_parameter_object@cluster_parameters - - # Set parameters. - cluster_parameter_object@weight <- 1.0 - cluster_parameter_object@invert <- FALSE - cluster_parameter_object@cluster_name <- object@name - cluster_parameter_object@cluster_size <- 1L - cluster_parameter_object@required_features <- object@name - cluster_parameter_object@cluster_features <- object@name - - # Mark complete. - cluster_parameter_object@complete <- TRUE - - # Replace in the feature info object. - object@cluster_parameters <- cluster_parameter_object - } - } + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } - # Update objects separately. - object@transformation_parameters <- update_object(object = object@transformation_parameters) - object@normalisation_parameters <- update_object(object = object@normalisation_parameters) - object@batch_normalisation_parameters <- update_object(object = object@batch_normalisation_parameters) - object@imputation_parameters <- update_object(object = object@imputation_parameters) - object@cluster_parameters <- update_object(object = object@cluster_parameters) + if (!methods::validObject(object)) ..error_updated_object_invalid(object) - if (!methods::validObject(object)) { - stop("Could not update the featureInfo object to the most recent definition.") - } - # Update package version. object <- add_package_version(object = object) @@ -718,56 +178,11 @@ setMethod( signature(object = "featureInfoParametersTransformationPowerTransform"), function(object, ...) { - if (tail(object@familiar_version, n = 1L) < "1.5.0") { - # Transformation objects are now implemented using power.transform. - if (is(object, "featureInfoParametersTransformationNone")) { - transformer <- power.transform::create_transformer_skeleton(method = "none") - object <- methods::new( - "featureInfoParametersTransformationPowerTransform", - name = object@name, - familiar_version = object@familiar_version - ) - - } else if (is(object, "featureInfoParametersTransformationBoxCox")) { - transformer <- power.transform::create_transformer_skeleton( - method = "box_cox", - lambda = object@lambda - ) - object <- methods::new( - "featureInfoParametersTransformationPowerTransform", - name = object@name, - familiar_version = object@familiar_version - ) - - } else if (is(object, "featureInfoParametersTransformationYeoJohnson")) { - transformer <- power.transform::create_transformer_skeleton( - method = "yeo_johnson", - lambda = object@lambda - ) - object <- methods::new( - "featureInfoParametersTransformationPowerTransform", - name = object@name, - familiar_version = object@familiar_version - ) - - } else { - # Without explicit class (original object pre v1.2.0). - transformer <- power.transform::create_transformer_skeleton( - method = object@fitting_parameters$method, - lambda = object@fitting_parameters$lambda - ) - } - - object@complete <- TRUE - object@transformer <- transformer - object@method <- power.transform::get_transformation_method(transformer) + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } - if (!methods::validObject(object)) { - stop(paste0( - "Could not update the featureInfoParametersTransformationPowerTransform ", - "object to the most recent definition.")) - } + if (!methods::validObject(object)) ..error_updated_object_invalid(object) # Update package version. object <- add_package_version(object = object) @@ -785,28 +200,12 @@ setMethod( "update_object", signature(object = "experimentData"), function(object, ...) { - # Update feature info objects. - if (!is.null(object@feature_info)) { - for (feature_info_set in names(object@feature_info)) { - object@feature_info[[feature_info_set]] <- lapply( - object@feature_info[[feature_info_set]], - update_object) - } - } - - # Update vimp tables. - if (!is.null(object@vimp_table_list)) { - for (vimp_method in names(object@vimp_table_list)) { - object@vimp_table_list[[vimp_method]] <- lapply( - object@vimp_table_list[[vimp_method]], - update_object) - } - } - - if (!methods::validObject(object)) { - stop("Could not update the experimentData object to the most recent definition.") + if (tail(object@familiar_version, n = 1L) < "2.0.0") { + ..error_cannot_update_object(object, "2.0.0") } - + + if (!methods::validObject(object)) ..error_updated_object_invalid(object) + # Update package version. object <- add_package_version(object = object) @@ -827,7 +226,8 @@ setMethod( object <- lapply( object, update_object, - ...) + ... + ) return(object) } diff --git a/R/FamiliarS4Classes.R b/R/FamiliarS4Classes.R index aeb854ea..0bb4a7d2 100644 --- a/R/FamiliarS4Classes.R +++ b/R/FamiliarS4Classes.R @@ -25,8 +25,13 @@ #' @slot novelty_detector A familiarNoveltyDetector object that can be used to #' detect out-of-distribution samples. #' @slot learner Learning algorithm used to create the model. -#' @slot fs_method Feature selection method used to determine variable -#' importance for the model. +#' @slot vimp_method Method used to determine variable importance for the model. +#' @slot vimp_table Variable importance table or list of variable importance +#' tables for the model. +#' @slot vimp_aggregation_method Method used for aggregating variable importance +#' tables if more than one is present.) +#' @slot vimp_rank_threshold Threshold used for some variable importance +#' aggregation methods. #' @slot required_features The set of features required for complete #' reproduction, i.e. with imputation. #' @slot model_features The set of features that is used to train the model, @@ -35,6 +40,9 @@ #' @slot calibration_info Calibration information, e.g. baseline survival in the #' development cohort. #' @slot km_info Data concerning stratification into risk groups. +#' @slot data_id Internal identifier for the dataset used to train the model. +#' @slot run_id Internal identifier for the specific subset of the dataset used +#' used to train the model. #' @slot run_table Run table for the data used to train the model. Used #' internally. #' @slot settings A copy of the evaluation configuration parameters used at @@ -79,14 +87,24 @@ setClass("familiarModel", novelty_detector = "ANY", # Name of learner learner = "character", - # Name of feature selection method - fs_method = "character", + # Name of variable importance method + vimp_method = "character", + # Variable importance table + vimp_table = "ANY", + # Vimp aggregation method. + vimp_aggregation_method = "character", + # Vimp rank threshold. + vimp_rank_threshold = "integer", # Required features for complete reconstruction, including imputation. required_features = "ANY", # Features that are required for the model. model_features = "ANY", # Features that are required for novelty detection. novelty_features = "ANY", + # data_id for the data used to train the model. + data_id = "integer", + # run_id for the data used to train the model. + run_id = "integer", # Run table for the current model run_table = "ANY", # Information required to assess model calibrations (e.g. baseline survival) @@ -109,9 +127,10 @@ setClass("familiarModel", # Name of the package required to train the learner. package = "ANY", # Version of the learner for reproducibility. - package_version = "ANY"), + package_version = "ANY" + ), prototype = list( - name = character(0), + name = character(0L), model = NULL, outcome_type = NA_character_, outcome_info = NULL, @@ -122,12 +141,17 @@ setClass("familiarModel", calibration_model = NULL, novelty_detector = NULL, learner = NA_character_, - fs_method = NA_character_, + vimp_method = NA_character_, + vimp_table = NULL, + vimp_aggregation_method = NA_character_, + vimp_rank_threshold = NA_integer_, required_features = NULL, model_features = NULL, novelty_features = NULL, calibration_info = NULL, km_info = NULL, + data_id = NA_integer_, + run_id = NA_integer_, run_table = NULL, settings = NULL, is_trimmed = FALSE, @@ -136,7 +160,8 @@ setClass("familiarModel", project_id = NULL, familiar_version = NULL, package = NULL, - package_version = NULL) + package_version = NULL + ) ) @@ -155,8 +180,8 @@ setClass("familiarModel", #' @slot data_column_info Data information object containing information #' regarding identifier column names and outcome column names. #' @slot learner Learning algorithm used to create the models in the ensemble. -#' @slot fs_method Feature selection method used to determine variable -#' importance for the models in the ensemble. +#' @slot vimp_method Method used to determine variable importance for the models +#' in the ensemble. #' @slot feature_info List of objects containing feature information, e.g., #' name, class levels, transformation, normalisation and clustering #' parameters. @@ -166,6 +191,10 @@ setClass("familiarModel", #' models in the ensemble, #' @slot novelty_features The combined set of features that is used to train all #' novelty detectors in the ensemble. +#' @slot data_id Internal identifier for the dataset used to train or +#' evaluate the ensemble. +#' @slot run_id Internal identifier for the specific subset of the dataset used +#' used to train or evaluate the ensemble. #' @slot run_table Run table for the data used to train the ensemble. Used #' internally. #' @slot calibration_info Calibration information, e.g. baseline survival in the @@ -197,8 +226,8 @@ setClass("familiarEnsemble", data_column_info = "ANY", # Name of learner. learner = "character", - # Name of feature selection method. - fs_method = "character", + # Name of variable importance method. + vimp_method = "character", # Data required for feature pre-processing. feature_info = "ANY", # Required features for complete reconstruction, including imputation. @@ -208,8 +237,12 @@ setClass("familiarEnsemble", model_features = "ANY", # Features that are required for novelty detection. novelty_features = "ANY", - # Set of run tables for the current ensemble. This is only required for - # processing internal data. + # data_id for the data used to train the model. + data_id = "integer", + # run_id for the data used to train the model. + run_id = "integer", + # data_id for predictions. This forces the models to predict at the subsets + # in this layer, and overrides data_id (but only for predictions). run_table = "ANY", # Information required to assess model calibrations (e.g. baseline survival) calibration_info = "ANY", @@ -226,26 +259,36 @@ setClass("familiarEnsemble", # Project identifier for consistency tracking. project_id = "ANY", # Package version for backward compatibility checks. - familiar_version = "ANY"), + familiar_version = "ANY" + ), prototype = list( - name = character(0), + name = character(0L), model_list = NULL, outcome_type = NA_character_, outcome_info = NULL, data_column_info = NULL, learner = NA_character_, - fs_method = NA_character_, + vimp_method = NA_character_, feature_info = NULL, required_features = NULL, model_features = NULL, novelty_features = NULL, + data_id = NA_integer_, + run_id = NA_integer_, run_table = NULL, calibration_info = NULL, model_dir_path = NA_character_, auto_detach = FALSE, settings = NULL, project_id = NULL, - familiar_version = NULL) + familiar_version = NULL + ) +) + + +setClassUnion( + "familiarModelUnion", + members = c("familiarModel", "familiarEnsemble") ) @@ -261,8 +304,7 @@ setClass("familiarEnsemble", #' @slot outcome_type Outcome type of the data used to create the object. #' @slot outcome_info Outcome information object, which contains additional #' information concerning the outcome, such as class levels. -#' @slot fs_vimp Variable importance data collected from feature selection -#' methods. +#' @slot fs_vimp Data collected for variable importance methods. #' @slot model_vimp Variable importance data collected from model-specific #' algorithms implemented by models created by familiar. #' @slot permutation_vimp Data collected for permutation variable importance. @@ -275,8 +317,8 @@ setClass("familiarEnsemble", #' model or ensemble of models, but without imputation. #' @slot learner Learning algorithm used to create the model or ensemble of #' models. -#' @slot fs_method Feature selection method used to determine variable -#' importance for the model or ensemble of models. +#' @slot vimp_method Method used to determine variable importance for the model +#' or ensemble of models. #' @slot pooling_table Run table for the data underlying the familiarData #' object. Used internally. #' @slot prediction_data Model predictions for a model or ensemble of models for @@ -299,6 +341,8 @@ setClass("familiarEnsemble", #' @slot ice_data Individual conditional expectation data for features included #' in a model or ensemble of models, based on the underlying dataset. Partial #' dependence data are computed on the fly from these data. +#' @slot shap_data SHAP values for features included in a model or ensemble of +#' models. #' @slot univariate_analysis Univariate analysis of the underlying dataset. #' @slot feature_expressions Feature expression values of the underlying #' dataset. @@ -306,10 +350,6 @@ setClass("familiarEnsemble", #' dataset. #' @slot sample_similarity Sample similarity information of the underlying #' dataset. -#' @slot is_validation Signifies whether the underlying data forms a validation -#' dataset. Used internally. -#' @slot generating_ensemble Name of the ensemble that was used to generate the -#' familiarData object. #' @slot project_id Identifier of the project that generated the familiarData #' object. #' @slot familiar_version Version of the familiar package. @@ -327,7 +367,7 @@ setClass("familiarData", outcome_type = "character", # Outcome info, such as class levels, mean values etc. outcome_info = "ANY", - # Feature selection variable importance + # Variable importance method fs_vimp = "ANY", # Model variable importance model_vimp = "ANY", @@ -344,8 +384,8 @@ setClass("familiarData", model_features = "ANY", # Name of learner learner = "character", - # Name of feature selection method - fs_method = "character", + # Name of variable importance method + vimp_method = "character", # Run table for the current data pooling_table = "ANY", # Model predictions for later reference @@ -376,17 +416,15 @@ setClass("familiarData", sample_similarity = "ANY", # Information on individual conditional expectation ice_data = "ANY", - # Flag to signal whether the data concerns validation data (TRUE) or - # development data (FALSE) - is_validation = "logical", - # Name of the model ensemble used to generate this data - generating_ensemble = "character", + # Information on SHAP values + shap_data = "ANY", # Project identifier project_id = "ANY", # Package version for backward compatibility - familiar_version = "ANY"), + familiar_version = "ANY" + ), prototype = list( - name = character(0), + name = character(0L), outcome_type = NA_character_, outcome_info = NULL, fs_vimp = NULL, @@ -397,7 +435,7 @@ setClass("familiarData", required_features = NULL, model_features = NULL, learner = NA_character_, - fs_method = NA_character_, + vimp_method = NA_character_, pooling_table = NULL, prediction_data = NULL, confusion_matrix = NULL, @@ -413,12 +451,13 @@ setClass("familiarData", feature_similarity = NULL, sample_similarity = NULL, ice_data = NULL, - is_validation = FALSE, - generating_ensemble = character(0), + shap_data = NULL, project_id = NULL, - familiar_version = NULL) + familiar_version = NULL + ) ) + # familiarCollection object ---------------------------------------------------- #' Collection of familiar data. @@ -431,8 +470,7 @@ setClass("familiarData", #' @slot outcome_type Outcome type for which the collection was created. #' @slot outcome_info Outcome information object, which contains information #' concerning the outcome, such as class levels. -#' @slot fs_vimp Variable importance data collected by feature selection -#' methods. +#' @slot fs_vimp collected for variable importance methods. #' @slot model_vimp Variable importance data collected from model-specific #' algorithms implemented by models created by familiar. #' @slot permutation_vimp Data collected for permutation variable importance. @@ -444,7 +482,8 @@ setClass("familiarData", #' @slot model_features The set of features that are required for using the #' model, but without imputation. #' @slot learner Learning algorithm(s) used for data in the collection. -#' @slot fs_method Feature selection method(s) used for data in the collection. +#' @slot vimp_method Variable importance method(s) used for data in the +#' collection. #' @slot prediction_data Model predictions for the data in the collection. #' @slot confusion_matrix Confusion matrix information for the data in the #' collection. @@ -463,6 +502,8 @@ setClass("familiarData", #' @slot ice_data Individual conditional expectation data for data in the #' collection. Partial dependence data are computed on the fly from these #' data. +#' @slot shap_data SHAP values for features included in a model or ensemble of +#' models. #' @slot univariate_analysis Univariate analysis results of data in the #' collection. #' @slot feature_expressions Feature expression values for data in the @@ -475,9 +516,9 @@ setClass("familiarData", #' See `get_data_set_names` and `set_data_set_names`. #' @slot learner_labels Labels for the different learning algorithms used to #' create the collection. See `get_learner_names` and `set_learner_names`. -#' @slot fs_method_labels Labels for the different feature selection methods -#' used to create the collection. See `get_fs_method_names` and -#' `set_fs_method_names`. +#' @slot vimp_method_labels Labels for the different variable importance methods +#' used to create the collection. See `get_vimp_method_names` and +#' `set_vimp_method_names`. #' @slot feature_labels Labels for the features in this collection. See #' `get_feature_names` and `set_feature_names`. #' @slot km_group_labels Labels for the risk strata in this collection. See @@ -523,8 +564,8 @@ setClass("familiarCollection", model_features = "ANY", # Name of learner learner = "character", - # Name of feature selection method - fs_method = "character", + # Name of variable importance method + vimp_method = "character", # Model predictions for later reference prediction_data = "ANY", # Confusion matrix for categorical outcomes @@ -553,12 +594,14 @@ setClass("familiarCollection", sample_similarity = "ANY", # Information on individual conditional expectation ice_data = "ANY", + # Information on SHAP values + shap_data = "ANY", # Label and order of data names data_set_labels = "ANY", # Label and order of learners learner_labels = "ANY", - # Label and order of feature selection methods - fs_method_labels = "ANY", + # Label and order of variable importance methods + vimp_method_labels = "ANY", # Label and order of features feature_labels = "ANY", # Label and order of kaplan-meier groups @@ -568,10 +611,11 @@ setClass("familiarCollection", # Project identifier project_id = "ANY", # Package version for backward compatibility - familiar_version = "ANY"), + familiar_version = "ANY" + ), prototype = list( - name = character(0), - data_sets = character(0), + name = character(0L), + data_sets = character(0L), outcome_type = NA_character_, outcome_info = NULL, fs_vimp = NULL, @@ -582,7 +626,7 @@ setClass("familiarCollection", required_features = NULL, model_features = NULL, learner = NA_character_, - fs_method = NA_character_, + vimp_method = NA_character_, prediction_data = NULL, confusion_matrix = NULL, decision_curve_data = NULL, @@ -597,14 +641,16 @@ setClass("familiarCollection", feature_similarity = NULL, sample_similarity = NULL, ice_data = NULL, + shap_data = NULL, data_set_labels = NULL, learner_labels = NULL, - fs_method_labels = NULL, + vimp_method_labels = NULL, feature_labels = NULL, km_group_labels = NULL, class_labels = NULL, project_id = NULL, - familiar_version = NULL) + familiar_version = NULL + ) ) @@ -622,21 +668,22 @@ setClass("familiarCollection", #' @slot preprocessing_level character indicating the level of pre-processing #' already conducted. #' @slot outcome_type character, determines the outcome type. +#' @slot outcome_info Outcome information object, which contains additional +#' information concerning the outcome, such as class levels. +#' @slot feature_info List of objects containing feature information, e.g., +#' name, class levels, transformation, normalisation and clustering +#' parameters. Optional. #' @slot data_column_info Object containing column information. -#' @slot delay_loading logical. Allows delayed loading data, which enables data -#' parsing downstream without additional workflow complexity or memory -#' utilisation. -#' @slot perturb_level numeric. This is the perturbation level for data which -#' has not been loaded. Used for data retrieval by interacting with the run -#' table of the accompanying model. -#' @slot load_validation logical. This determines which internal data set will -#' be loaded. If TRUE, the validation data will be loaded, whereas FALSE loads -#' the development data. -#' @slot aggregate_on_load logical. Determines whether data is aggregated after -#' loading. -#' @slot sample_set_on_load NULL or vector of sample identifiers to be loaded. -#' -setClass("dataObject", +#' @slot data_id Data identifier for dataset. Set using internal routines if the +#' `dataObject` was created from a `delayedDataObject` +#' @slot run_id Run identifier for dataset. Set using internal routines if the +#' `dataObject` was created from a `delayedDataObject` +#' @slot validation Identifies if validation or development samples were loaded. +#' Set using internal routines if the `dataObject` was created from a +#' `delayedDataObject`. +#' @slot sample_seed Seed used for creating a bootstrap of the data. +setClass( + "dataObject", slots = list( # Data data = "ANY", @@ -646,30 +693,87 @@ setClass("dataObject", outcome_type = "character", # Outcome info, such as class levels, mean values etc. outcome_info = "ANY", - # Info related to the columns in the dataset. + # Info related to features in the data. + feature_info = "ANY", + # Info related to the other columns in the dataset. data_column_info = "ANY", - # Flag for delayed loading. This can only be meaningfully set using internal - # data. - delay_loading = "logical", - # Perturbation level for data which has not been loaded. Used for data - # retrieval in combination with the run table of the accompanying model. - perturb_level = "numeric", - # Determines which data should be loaded. - load_validation = "logical", - # Flag for aggregation after loading and pre-processing - aggregate_on_load = "logical", - # Samples to be loaded - sample_set_on_load = "ANY"), + # Data id + data_id = "integer", + # Run id + run_id = "integer", + # Validation marker. + validation = "logical", + # Sample seed + sample_seed = "integer" + ), prototype = list( data = NULL, preprocessing_level = "none", outcome_type = NA_character_, outcome_info = NULL, - delay_loading = FALSE, - perturb_level = NA_integer_, - load_validation = TRUE, - aggregate_on_load = FALSE, - sample_set_on_load = NULL) + feature_info = NULL, + data_column_info = NULL, + data_id = NA_integer_, + run_id = NA_integer_, + validation = NA, + sample_seed = NA_integer_ + ) +) + + + +# delayedDataObject object ----------------------------------------------------- + +#' Data object with delayed loading +#' +#' The delayed loading object provides an interface to the backend data. This +#' data object is typically used within the evaluation pipeline to load data +#' when needed. +#' +#' @slot data NULL or data table containing the data. If present (not `NULL`), +#' data is considered loaded. This should not happen -- load_data_object auto- +#' matically creates a dataObject from the delayedDataObject. +#' @slot preprocessing_level character indicating the level of pre-processing +#' already conducted. `"none"` by default. +#' @slot outcome_type character, determines the outcome type. +#' @slot outcome_info Outcome information object, which contains additional +#' information concerning the outcome, such as class levels. +#' @slot feature_info List of objects containing feature information, e.g., +#' name, class levels, transformation, normalisation and clustering +#' parameters. Optional. +#' @slot data_column_info Object containing column information. +#' @slot data_id integer. Defines the data_id of the dataset that should be +#' loaded. +#' @slot run_id integer. Defines the run_id of the dataset that should be load. +#' Together with data_id, run_id and validation allows for looking up the +#' sample set. If run_id is left unset (NA_integer_), this will force the +#' run_id to be set using the model, vimp_method or ensemble object. This is +#' used during the evaluation process to load data specifically related to +#' training, internal validation and external validation. The run-tables +#' (which contain information about data partitioning) associated with these +#' objects are used to look-up the run_id based on the data_id (that is always +#' explicitly set). The perform_task method for familiarTaskEvaluate uses this +#' aspect explicitly. +#' @slot validation logical. This determines which internal data set will be +#' loaded. If TRUE, the validation data will be loaded, whereas FALSE loads +#' the development data. +#' @slot aggregate_on_load logical. Determines whether data is aggregated after +#' loading. +#' @slot sample_set_on_load NULL or vector of sample identifiers to be loaded. +#' Overrides any `sample_seed` that may have been provided. +setClass( + "delayedDataObject", + contains = "dataObject", + slots = list( + # Flag for aggregation after loading and pre-processing + aggregate_on_load = "logical", + # Samples to be loaded. + sample_set_on_load = "ANY" + ), + prototype = list( + aggregate_on_load = NA, + sample_set_on_load = NULL + ) ) @@ -735,6 +839,7 @@ setClass("dataObject", #' features. #' @slot required_features Details features required for clustering or #' imputation. +#' @slot project_id Identifier of the project that generated this collection. #' @slot familiar_version Version of the familiar package. #' #' @export @@ -767,7 +872,9 @@ setClass("featureInfo", imputation_parameters = "ANY", cluster_parameters = "ANY", required_features = "ANY", - familiar_version = "ANY"), + project_id = "ANY", + familiar_version = "ANY" + ), prototype = list( name = NA_character_, set_descriptor = NA_character_, @@ -795,7 +902,9 @@ setClass("featureInfo", imputation_parameters = NULL, cluster_parameters = NULL, required_features = NULL, - familiar_version = NULL) + project_id = NULL, + familiar_version = NULL + ) ) @@ -822,11 +931,13 @@ setClass("featureInfoParameters", slots = list( name = "character", complete = "logical", - familiar_version = "ANY"), + familiar_version = "ANY" + ), prototype = list( name = NA_character_, complete = FALSE, - familiar_version = NULL) + familiar_version = NULL + ) ) @@ -836,11 +947,16 @@ setClass("featureInfoParameters", #' Variable importance table #' #' A vimpTable object contains information concerning variable importance of one -#' or more features. These objects are created during feature selection. +#' or more features. These objects are created during variable importance +#' computation.. #' #' @slot vimp_table Table containing features with corresponding scores. #' @slot vimp_method Method used to compute variable importance scores for each #' feature. +#' @slot data_id Internal identifier for the dataset used to derive the variable +#' importance table. +#' @slot run_id Internal identifier for the specific subset of the dataset used +#' to derive the variable importance table. #' @slot run_table Run table for the data used to compute variable importances #' from. Used internally. #' @slot score_aggregation Method used to aggregate the score of contrasts for @@ -904,7 +1020,9 @@ setClass("vimpTable", # Variable importance method that generated the current variable # importance table. vimp_method = "character", - # Run table for the current model + data_id = "integer", + run_id = "integer", + # Run table for the current table. run_table = "ANY", # Set how scores from encoded features should be aggregated. score_aggregation = "character", @@ -920,10 +1038,13 @@ setClass("vimpTable", # Version of familiar used to create the object. familiar_version = "ANY", # State of the object. - state = "character"), + state = "character" + ), prototype = list( vimp_table = NULL, vimp_method = NA_character_, + data_id = NA_integer_, + run_id = NA_integer_, run_table = NULL, score_aggregation = NA_character_, encoding_table = NULL, @@ -931,7 +1052,8 @@ setClass("vimpTable", invert = FALSE, project_id = NULL, familiar_version = NULL, - state = "initial") + state = "initial" + ) ) @@ -964,6 +1086,8 @@ setClass("vimpTable", #' outcomes. Currently unused. #' @slot normalisation_parameters Parameters used for normalising numeric #' outcomes. Currently unused. +#' @slot familiar_version Version of the familiar package used to create this +#' object. #' #' @export @@ -998,7 +1122,10 @@ setClass("outcomeInfo", # Transformation parameters for the outcome data. transformation_parameters = "ANY", # Normalisation parameters for the outcome data. - normalisation_parameters = "ANY"), + normalisation_parameters = "ANY", + # Version of familiar used to create the object. + familiar_version = "ANY" + ), prototype = list( name = NA_character_, outcome_type = NA_character_, @@ -1014,7 +1141,9 @@ setClass("outcomeInfo", data_id = NA_integer_, run_id = NA_integer_, transformation_parameters = NULL, - normalisation_parameters = NULL) + normalisation_parameters = NULL, + familiar_version = NULL + ) ) @@ -1031,6 +1160,10 @@ setClass("outcomeInfo", #' method. #' @slot vimp_method The character string indicating the variable importance #' method. +#' @slot vimp_aggregation_method Method used for aggregating variable importance +#' tables if more than one is present.) +#' @slot vimp_rank_threshold Threshold used for some variable importance +#' aggregation methods. #' @slot multivariate Flags whether the variable importance method is #' multivariate vs. univariate. #' @slot outcome_info Outcome information object, which contains additional @@ -1046,6 +1179,8 @@ setClass("outcomeInfo", #' importance method. Used internally. #' @slot project_id Identifier of the project that generated the #' familiarVimpMethod object. +#' @slot familiar_version Version of the familiar package used to create this +#' object. #' #' @export setClass("familiarVimpMethod", @@ -1056,6 +1191,10 @@ setClass("familiarVimpMethod", hyperparameters = "ANY", # Name of variable importance method vimp_method = "character", + # Vimp aggregation method. + vimp_aggregation_method = "character", + # Vimp rank threshold. + vimp_rank_threshold = "integer", # Indicates whether the method is a univariate or multivariate # method. multivariate = "logical", @@ -1070,18 +1209,25 @@ setClass("familiarVimpMethod", # Run table for the current vimp method run_table = "ANY", # Project identifier for consistency tracking - project_id = "ANY"), + project_id = "ANY", + # Version of familiar used to create the object. + familiar_version = "ANY" + ), prototype = list( outcome_type = NA_character_, hyperparameters = NULL, vimp_method = NA_character_, + vimp_aggregation_method = NA_character_, + vimp_rank_threshold = NA_integer_, multivariate = FALSE, outcome_info = NULL, feature_info = NULL, required_features = NULL, package = NULL, run_table = NULL, - project_id = NULL) + project_id = NULL, + familiar_version = NULL + ) ) @@ -1095,7 +1241,6 @@ setClass("familiarVimpMethod", #' dataset. #' #' @slot name Name of the familiarNoveltyDetector object. -#' @slot learner Learning algorithm used to create the novelty detector. #' @slot model The actual novelty detector trained using a specific algorithm, #' e.g. a isolation forest from the `isotree` package. #' @slot feature_info List of objects containing feature information, e.g., @@ -1103,18 +1248,33 @@ setClass("familiarVimpMethod", #' parameters. #' @slot data_column_info Data information object containing information #' regarding identifier column names. -#' @slot conversion_parameters Parameters used to convert raw output to -#' statistical probability of being out-of-distribution. Currently unused. #' @slot hyperparameters Set of hyperparameters used to train the detector. +#' @slot hyperparameter_data Information generated during hyperparameter +#' optimisation. Currently not used. +#' @slot calibration_model Model used to convert raw output to statistical +#' probability of being out-of-distribution. Currently not used. +#' @slot learner Learning algorithm used to create the novelty detector. +#' @slot vimp_method Method used to determine variable importance for the +#' novelty detector. +#' @slot vimp_table Variable importance table or list of variable importance +#' tables for the model. +#' @slot vimp_aggregation_method Method used for aggregating variable importance +#' tables if more than one is present.) +#' @slot vimp_rank_threshold Threshold used for some variable importance +#' aggregation methods. #' @slot required_features The set of features required for complete #' reproduction, i.e. with imputation. #' @slot model_features The set of features that is used to train the detector. +#' @slot data_id Internal identifier for the dataset used to train the detector. +#' @slot run_id Internal identifier for the specific subset of the dataset used +#' used to train the detector. #' @slot run_table Run table for the data used to train the detector. Used #' internally. #' @slot is_trimmed Flag that indicates whether the detector, stored in the #' `model` slot, has been trimmed. #' @slot trimmed_function List of functions whose output has been captured prior #' to trimming the model. +#' @slot messages List of warning and error messages generated during training. #' @slot project_id Identifier of the project that generated the #' familiarNoveltyDetector object. #' @slot familiar_version Version of the familiar package. @@ -1130,57 +1290,82 @@ setClass("familiarVimpMethod", setClass("familiarNoveltyDetector", slots = list( + # Model name. name = "character", - # Detector - learner = "character", # Model container model = "ANY", + # Data required for feature pre-processing + feature_info = "ANY", # Info related to the columns in the dataset. data_column_info = "ANY", - # Parameters needed to convert raw novelty scores into p-values. - conversion_parameters = "ANY", - # Hyperparameters used to create the novelty detector. + # Hyper-parameters (typically stored in the model as well) hyperparameters = "ANY", - # Data required for feature pre-processing - feature_info = "ANY", - # Required features for complete reconstruction, including - # imputation. + # Hyperparameter data, e.g. for visualising the hyperparameter space. + hyperparameter_data = "ANY", + # Models used for recalibration + calibration_model = "ANY", + # Name of learner + learner = "character", + # Name of variable importance method + vimp_method = "character", + # Variable importance table + vimp_table = "ANY", + # Vimp aggregation method. + vimp_aggregation_method = "character", + # Vimp rank threshold. + vimp_rank_threshold = "integer", + # Required features for complete reconstruction, including imputation. required_features = "ANY", - # Features that are required for novelty detection. + # Features that are required for the model. model_features = "ANY", + # data_id for the data used to train the model. + data_id = "integer", + # run_id for the data used to train the model. + run_id = "integer", # Run table for the current model run_table = "ANY", - # Flags trimming of the novelty detector. + # Flags trimming of the model is_trimmed = "logical", - # Restores functions lost due to model trimming, such as coef or - # vcov. + # Restores functions lost due to model trimming, such as coef or vcov. trimmed_function = "list", + # List of warning and error messages encountered during training. + messages = "list", # Project identifier for consistency tracking project_id = "ANY", - # Package version for backward compatibility. + # Package version for backward compatibility familiar_version = "ANY", # Name of the package required to train the learner. package = "ANY", # Version of the learner for reproducibility. - package_version = "ANY"), + package_version = "ANY" + ), prototype = list( - name = character(0), - learner = NA_character_, + name = character(0L), model = NULL, + feature_info = NULL, data_column_info = NULL, - conversion_parameters = NULL, hyperparameters = NULL, - feature_info = NULL, + hyperparameter_data = NULL, + calibration_model = NULL, + learner = NA_character_, + vimp_method = NA_character_, + vimp_table = NULL, + vimp_aggregation_method = NA_character_, + vimp_rank_threshold = NA_integer_, required_features = NULL, model_features = NULL, + data_id = NA_integer_, + run_id = NA_integer_, run_table = NULL, is_trimmed = FALSE, trimmed_function = list(), + messages = list(), project_id = NULL, familiar_version = NULL, package = NULL, - package_version = NULL) + package_version = NULL + ) ) @@ -1247,9 +1432,10 @@ setClass("familiarHyperparameterLearner", # Name of the package required to train the learner. package = "ANY", # Version of the learner for reproducibility. - package_version = "ANY"), + package_version = "ANY" + ), prototype = list( - name = character(0), + name = character(0L), learner = NA_character_, target_learner = NA_character_, target_outcome_type = NA_character_, @@ -1260,7 +1446,8 @@ setClass("familiarHyperparameterLearner", project_id = NULL, familiar_version = NULL, package = NULL, - package_version = NULL) + package_version = NULL + ) ) @@ -1284,7 +1471,8 @@ setClass("familiarHyperparameterLearner", #' #' @export -setClass("familiarMetric", +setClass( + "familiarMetric", slots = list( # The metric itself. metric = "character", @@ -1298,14 +1486,16 @@ setClass("familiarMetric", # function from. baseline_value = "ANY", # Flag that sets whether higher values denote better performance. - higher_better = "logical"), + higher_better = "logical" + ), prototype = list( metric = NA_character_, outcome_type = NA_character_, name = NA_character_, value_range = c(NA_real_, NA_real_), baseline_value = NULL, - higher_better = TRUE) + higher_better = TRUE + ) ) @@ -1403,12 +1593,13 @@ setClass("familiarMetric", #' #' @export -setClass("familiarDataElement", +setClass( + "familiarDataElement", slots = list( # The primary results. data = "ANY", - # Identifiers of the data, e.g. the generating model name, the - # feature-selection method and learner. + # Identifiers of the data, e.g. the generating model name, the variable + # importance method and learner. identifiers = "ANY", # The level of detail at which the data was computed. detail_level = "character", @@ -1428,7 +1619,8 @@ setClass("familiarDataElement", grouping_column = "ANY", # Flag that signals whether the data is aggregated, e.g. by computing # confidence intervals and a bias-corrected value. - is_aggregated = "logical"), + is_aggregated = "logical" + ), prototype = list( data = NULL, identifiers = NULL, @@ -1438,7 +1630,8 @@ setClass("familiarDataElement", bootstrap_ci_method = NA_character_, value_column = NA_character_, grouping_column = NULL, - is_aggregated = FALSE) + is_aggregated = FALSE + ) ) @@ -1458,6 +1651,9 @@ setClass("familiarDataElement", #' @slot feature_info Feature information objects. Only available if the #' experimentData object was generated using the `precompute_feature_info` or #' `precompute_vimp` functions. +#' @slot vimp_hyperparameter_list List of hyperparameters for variable importance +#' objects. Only available if the experimentData object was created using the +#' `precompute_vimp` function. #' @slot vimp_table_list List of variable importance table objects. Only #' available if the experimentData object was created using the #' `precompute_vimp` function. @@ -1474,7 +1670,8 @@ setClass("familiarDataElement", #' \code{\link{precompute_feature_info}}, \code{\link{precompute_vimp}} #' @export -setClass("experimentData", +setClass( + "experimentData", slots = list( # Experimental design. experiment_setup = "ANY", @@ -1482,17 +1679,110 @@ setClass("experimentData", iteration_list = "ANY", # List of feature information objects. feature_info = "ANY", + # List of variable importance hyperparameters. + vimp_hyperparameter_list = "ANY", # List of variable importance tables. vimp_table_list = "ANY", # Project identifier for consistency tracking project_id = "ANY", # Package version for backward compatibility - familiar_version = "ANY"), + familiar_version = "ANY" + ), prototype = list( experiment_setup = NULL, iteration_list = NULL, feature_info = NULL, + vimp_hyperparameter_list = NULL, vimp_table_list = NULL, project_id = NULL, - familiar_version = NULL) + familiar_version = NULL + ) +) + + + +# familiarDataElementPredictionTable object ------------------------------------ +setClass( + "familiarDataElementPredictionTable", + contains = "familiarDataElement", + slots = list( + "learner" = "character", + "vimp_method" = "character", + "ensemble_method" = "character", + "percentiles" = "ANY", + "outcome_type" = "ANY", + "identifier_data" = "ANY", + "reference_data" = "ANY", + "prediction_data" = "ANY" + ), + prototype = methods::prototype( + bootstrap_ci_method = "percentile", + learner = "custom_learner", + vimp_method = "custom_vimp_method", + ensemble_method = "median", + percentiles = NULL, + outcome_type = NULL, + identifier_data = NULL, + reference_data = NULL, + prediction_data = NULL + ) +) + + + +# familiarTask object ---------------------------------------------------------- +setClass( + "familiarTask", + slots = list( + "task_name" = "character", + "task_id" = "integer", + "n_tasks" = "integer", + "data_id" = "integer", + "run_id" = "integer", + "run_table" = "ANY", + "file" = "character", + "project_id" = "ANY" + ), + prototype = methods::prototype( + task_name = NA_character_, + task_id = 1L, + n_tasks = 1L, + data_id = NA_integer_, + run_id = NA_integer_, + run_table = NULL, + file = NA_character_, + project_id = NULL + ) +) + + +# familiarPlot object ---------------------------------------------------------- +setClass( + "familiarPlot", + slots = list( + "gtable" = "ANY", + "global_elements" = "ANY", + "row_id" = "integer", + "col_id" = "integer", + "remove_strip_x" = "logical", + "remove_strip_y" = "logical", + "remove_axis_text_x" = "logical", + "remove_axis_text_y" = "logical", + "remove_axis_label_x" = "logical", + "remove_axis_label_y" = "logical", + "remove_panel" = "logical" + ), + prototype = methods::prototype( + gtable = NULL, + global_elements = NULL, + row_id = NA_integer_, + col_id = NA_integer_, + remove_strip_x = FALSE, + remove_strip_y = FALSE, + remove_axis_text_x = FALSE, + remove_axis_text_y = FALSE, + remove_axis_label_x = FALSE, + remove_axis_label_y = FALSE, + remove_panel = FALSE + ) ) diff --git a/R/FamiliarS4Generics.R b/R/FamiliarS4Generics.R index 463b28ef..46b29b89 100644 --- a/R/FamiliarS4Generics.R +++ b/R/FamiliarS4Generics.R @@ -2,6 +2,10 @@ # explicity imported. setGeneric("save") +setGeneric(".complete", function(object, ...) standardGeneric(".complete")) + +setGeneric(".copy", function(object, ...) standardGeneric(".copy")) + setGeneric(".predict", function(object, data, ...) standardGeneric(".predict")) setGeneric(".predict_novelty", function(object, data, ...) standardGeneric(".predict_novelty")) @@ -10,17 +14,13 @@ setGeneric(".predict_risk_stratification", function(object, data, ...) standardG setGeneric(".train", function(object, data, ...) standardGeneric(".train")) -setGeneric(".train_novelty_detector", function(object, data, ...) standardGeneric(".train_novelty_detector")) - setGeneric("require_package", function(x, ...) standardGeneric("require_package")) setGeneric("set_package_version", function(object, ...) standardGeneric("set_package_version")) setGeneric("check_package_version", function(object, ...) standardGeneric("check_package_version")) -setGeneric("get_signature", function(object, ...) standardGeneric("get_signature")) - -setGeneric("set_signature", function(object, ...) standardGeneric("set_signature")) +setGeneric("get_signature_features", function(object, ...) standardGeneric("get_signature_features")) setGeneric("model_is_trained", function(object, ...) standardGeneric("model_is_trained")) @@ -64,14 +64,14 @@ setGeneric("normalise_features", function(data, ...) standardGeneric("normalise_ setGeneric("batch_normalise_features", function(data, ...) standardGeneric("batch_normalise_features")) -setGeneric("remove_missing_outcomes", function(data, ...) standardGeneric("remove_missing_outcomes")) - setGeneric("impute_features", function(data, ...) standardGeneric("impute_features")) setGeneric("cluster_features", function(data, ...) standardGeneric("cluster_features")) setGeneric("aggregate_data", function(data, ...) standardGeneric("aggregate_data")) +setGeneric("select_unique_data", function(data, ...) standardGeneric("select_unique_data")) + setGeneric("select_features", function(data, ...) standardGeneric("select_features")) setGeneric("preprocess_data", function(data, object, ...) standardGeneric("preprocess_data")) @@ -94,6 +94,8 @@ setGeneric("get_required_features", function(x, ...) standardGeneric("get_requir setGeneric("get_model_features", function(x, ...) standardGeneric("get_model_features")) +setGeneric("set_model_features", function(object, ...) standardGeneric("set_model_features")) + # clustering methods ----------------------------------------------------------- @@ -159,8 +161,6 @@ setGeneric("get_class_probability_name", function(x, ...) standardGeneric("get_c setGeneric("encode_categorical_variables", function(object, data, ...) standardGeneric("encode_categorical_variables")) -setGeneric("get_placeholder_prediction_table", function(object, data, ...) standardGeneric("get_placeholder_prediction_table")) - setGeneric("has_bad_training_data", function(object, data, ...) standardGeneric("has_bad_training_data")) setGeneric("has_optimised_hyperparameters", function(object, ...) standardGeneric("has_optimised_hyperparameters")) @@ -173,6 +173,8 @@ setGeneric("get_subsample", function(data, ...) standardGeneric("get_subsample") setGeneric("create_instance_weights", function(data, ...) standardGeneric("create_instance_weights")) +setGeneric(".create_outcome_info", function(object, ...) standardGeneric(".create_outcome_info")) + # familiarModel methods -------------------------------------------------------- @@ -186,8 +188,6 @@ setGeneric("..train_naive", function(object, data, ...) standardGeneric("..train setGeneric("..predict", function(object, data, ...) standardGeneric("..predict")) -setGeneric("..predict_survival_probability", function(object, data, time, ...) standardGeneric("..predict_survival_probability")) - setGeneric("..set_recalibration_model", function(object, data, ...) standardGeneric("..set_recalibration_model")) setGeneric("..vimp", function(object, ...) standardGeneric("..vimp")) @@ -196,7 +196,12 @@ setGeneric("get_prediction_type", function(object, ...) standardGeneric("get_pre setGeneric("..set_calibration_info", function(object, data, ...) standardGeneric("..set_calibration_info")) -setGeneric("..set_risk_stratification_thresholds", function(object, data, ...) standardGeneric("..set_risk_stratification_thresholds")) +setGeneric( + "..set_risk_stratification_thresholds", + function(object, data, ...) { + standardGeneric("..set_risk_stratification_thresholds") + } +) setGeneric("..set_vimp_parameters", function(object, ...) standardGeneric("..set_vimp_parameters")) @@ -216,6 +221,7 @@ setGeneric(".trim_model", function(object, ...) standardGeneric(".trim_model")) setGeneric("requires_naive_model", function(object, ...) standardGeneric("requires_naive_model")) +setGeneric("..get_prediction_table_type", function(object, ...) standardGeneric("..get_prediction_table_type")) # familiarNoveltyDetector methods ---------------------------------------------- @@ -228,7 +234,7 @@ setGeneric(".vimp", function(object, ...) standardGeneric(".vimp")) setGeneric("promote_vimp_method", function(object, ...) standardGeneric("promote_vimp_method")) -setGeneric("prepare_vimp_object", function(data, ...) standardGeneric("prepare_vimp_object")) +setGeneric("test_create_vimp_method", function(data, ...) standardGeneric("test_create_vimp_method")) @@ -258,7 +264,7 @@ setGeneric("set_data_set_names", function(x, ...) standardGeneric("set_data_set_ setGeneric("set_learner_names", function(x, ...) standardGeneric("set_learner_names")) -setGeneric("set_fs_method_names", function(x, ...) standardGeneric("set_fs_method_names")) +setGeneric("set_vimp_method_names", function(x, ...) standardGeneric("set_vimp_method_names")) setGeneric("set_feature_names", function(x, ...) standardGeneric("set_feature_names")) @@ -270,7 +276,7 @@ setGeneric("get_data_set_names", function(x, ...) standardGeneric("get_data_set_ setGeneric("get_learner_names", function(x, ...) standardGeneric("get_learner_names")) -setGeneric("get_fs_method_names", function(x, ...) standardGeneric("get_fs_method_names")) +setGeneric("get_vimp_method_names", function(x, ...) standardGeneric("get_vimp_method_names")) setGeneric("get_feature_names", function(x, ...) standardGeneric("get_feature_names")) @@ -282,7 +288,7 @@ setGeneric("get_data_set_name_levels", function(x, ...) standardGeneric("get_dat setGeneric("get_learner_name_levels", function(x, ...) standardGeneric("get_learner_name_levels")) -setGeneric("get_fs_method_name_levels", function(x, ...) standardGeneric("get_fs_method_name_levels")) +setGeneric("get_vimp_method_name_levels", function(x, ...) standardGeneric("get_vimp_method_name_levels")) setGeneric("get_feature_name_levels", function(x, ...) standardGeneric("get_feature_name_levels")) @@ -311,8 +317,20 @@ setGeneric(".compute_data_element_estimates", function(x, ...) standardGeneric(" setGeneric("..compute_data_element_estimates", function(x, ...) standardGeneric("..compute_data_element_estimates")) -setGeneric("collect", function(x, ...) standardGeneric("collect")) +setGeneric(".merge_slots_into_data", function(x, ...) standardGeneric(".merge_slots_into_data")) + +setGeneric(".extract_slots_from_data", function(x, ...) standardGeneric(".extract_slots_from_data")) +setGeneric(".as_data_table", function(x, ...) standardGeneric(".as_data_table")) + +setGeneric( + ".convert_value_to_grouping_column", + function(x, ...) { + standardGeneric(".convert_value_to_grouping_column") + } +) + +setGeneric("collect", function(x, ...) standardGeneric("collect")) # vimpTable methods ------------------------------------------------------------ @@ -348,3 +366,22 @@ setGeneric("feature_info_complete", function(object, ...) standardGeneric("featu setGeneric("add_feature_info_parameters", function(object, data, ...) standardGeneric("add_feature_info_parameters")) setGeneric("apply_feature_info_parameters", function(object, data, ...) standardGeneric("apply_feature_info_parameters")) + + + +# task methods ----------------------------------------------------------------- +setGeneric(".set_file_name", function(object, ...) standardGeneric(".set_file_name")) + +setGeneric(".file_exists", function(object, ...) standardGeneric(".file_exists")) + +setGeneric(".perform_task", function(object, data, ...) standardGeneric(".perform_task")) + +setGeneric(".get_task_descriptor", function(object, ...) standardGeneric(".get_task_descriptor")) + +setGeneric(".get_feature_info_list", function(object, ...) standardGeneric(".get_feature_info_list")) + +setGeneric(".get_hyperparameters", function(object, ...) standardGeneric(".get_hyperparameters")) + +setGeneric(".get_variable_importance_table", function(object, ...) standardGeneric(".get_variable_importance_table")) + +setGeneric(".get_current_run_table", function(object, ...) standardGeneric(".get_current_run_table")) diff --git a/R/FamiliarSharedS4Methods.R b/R/FamiliarSharedS4Methods.R index 329db803..94bb661f 100644 --- a/R/FamiliarSharedS4Methods.R +++ b/R/FamiliarSharedS4Methods.R @@ -2,20 +2,25 @@ # Adds the version of the familiar package used to generate the object. This # allows for backward compatibility. + # Look-up of the familiar version takes more time than one would expect. Use + # caching. + current_version <- rlang::env_cache( + familiar_global_env, + "familiar_version", + default = utils::packageVersion("familiar") + ) + if (is.null(object@familiar_version)) { # Set package version. - object@familiar_version <- utils::packageVersion("familiar") + object@familiar_version <- current_version - } else if (tail(object@familiar_version, n = 1) < utils::packageVersion("familiar") && - head(object@familiar_version, n = 1) == "0.0.0") { - # Replace version. - object@familiar_version <- utils::packageVersion("familiar") - } else if (tail(object@familiar_version, n = 1) < utils::packageVersion("familiar")) { + } else if (tail(object@familiar_version, n = 1L) < current_version) { # Check if package version differs from the currently installed version. # This is usually done when updating the object. object@familiar_version <- c( object@familiar_version, - utils::packageVersion("familiar")) + current_version + ) } return(object) @@ -28,11 +33,12 @@ version_string <- paste0("v", head(object@familiar_version, n = 1L)) # Add version string if the object was updated from a previous version. - if (length(object@familiar_version) > 1) { + if (length(object@familiar_version) > 1L) { version_string <- paste0( version_string, " -> ", - tail(object@familiar_version, n = 1L)) + tail(object@familiar_version, n = 1L) + ) } return(version_string) @@ -58,7 +64,7 @@ } # Add file name. - if (object@project_id == 0 && length(object@name) > 0) { + if (is.null(object@project_id) && length(object@name) > 0L) { file_name <- object@name } else { file_name <- get_object_name(object = object) @@ -72,7 +78,8 @@ dir_path = dir_path, object_type = object_type, learner = object@learner, - fs_method = object@fs_method) + vimp_method = object@vimp_method + ) # Check if the directory exists, and create anew if not if (!dir.exists(dir_path)) dir.create(dir_path, recursive = TRUE) @@ -91,21 +98,26 @@ setMethod( "has_bad_training_data", signature( object = "ANY", - data = "dataObject"), + data = "dataObject" + ), function( object, data, allow_no_features = FALSE, - ...) { + ... + ) { # Checks the data for consistency and usability. Any errors are passed as # attributes - if (!(is(object, "familiarModel") || - is(object, "familiarVimpMethod") || - is(object, "familiarNoveltyDetector"))) { + if (!( + is(object, "familiarModel") || + is(object, "familiarVimpMethod") || + is(object, "familiarNoveltyDetector") + )) { ..error_reached_unreachable_code(paste0( "has_bad_training_data: object is not a familiarModel, ", - "familiarVimpMethod or familiarNoveltyDetector.")) + "familiarVimpMethod or familiarNoveltyDetector." + )) } # One cannot train without data or on a single sample. @@ -116,10 +128,11 @@ setMethod( return(return_value) } - if (data.table::uniqueN(data@data, by = get_id_columns(id_depth = "sample")) < 2) { + if (get_n_samples(data) < 2L) { return_value <- TRUE attr(return_value, "error") <- paste0( - "Only one sample was available to train the model.") + "Only one sample was available to train the model." + ) return(return_value) } @@ -137,48 +150,53 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "has_bad_training_data: could not find outcomeInfo object attached to ", - "familiarModel/familiarVimpMethod or dataObject.")) + "familiarModel/familiarVimpMethod or dataObject." + )) } if (object@outcome_type == "survival") { # Check that not all data are censored. censoring_variable <- outcome_info@censored - if (length(censoring_variable) > 0) { + if (length(censoring_variable) > 0L) { if (all(data@data$outcome_event == censoring_variable)) { return_value <- TRUE attr(return_value, "error") <- paste0( "All instances in the data set were censored. ", - "Events are required for training the model.") + "Events are required for training the model." + ) return(return_value) } } # The same as above. - if (all(data@data$outcome_event == 0)) { + if (all(data@data$outcome_event == 0L)) { return_value <- TRUE attr(return_value, "error") <- paste0( "All instances in the data set were censored. ", - "Events are required for training the model.") + "Events are required for training the model." + ) return(return_value) } # Check that not all data have the same survival time. - if (all(data@data$outcome_time == data@data$outcome_time[1])) { + if (all(data@data$outcome_time == data@data$outcome_time[1L])) { return_value <- TRUE attr(return_value, "error") <- paste0( - "All instances in the data set had the same recorded survival time.") + "All instances in the data set had the same recorded survival time." + ) return(return_value) } } else if (object@outcome_type %in% c("binomial", "multinomial")) { # Check that not all data have the same class. - if (data.table::uniqueN(data@data$outcome) == 1) { + if (data.table::uniqueN(data@data$outcome) == 1L) { return_value <- TRUE attr(return_value, "error") <- paste0( - "All instances in the data set were of the same class.") + "All instances in the data set were of the same class." + ) return(return_value) } @@ -187,17 +205,19 @@ setMethod( if (data.table::uniqueN(data@data$outcome) < nlevels(data@data$outcome)) { return_value <- TRUE attr(return_value, "error") <- paste0( - "Some expected classes were not found in the data set.") + "Some expected classes were not found in the data set." + ) return(return_value) } - } else if (object@outcome_type %in% c("count", "continuous")) { + } else if (object@outcome_type %in% c("continuous")) { # Check that not all data have the same outcome value. - if (all(data@data$outcome == data@data$outcome[1])) { + if (all(data@data$outcome == data@data$outcome[1L])) { return_value <- TRUE attr(return_value, "error") <- paste0( - "All instances in the data set had the same outcome value.") + "All instances in the data set had the same outcome value." + ) return(return_value) } @@ -221,7 +241,8 @@ setMethod( # store the reason. if (!(is(object, "familiarModel"))) { ..error_reached_unreachable_code( - ".why_bad_training_data: object is not a familiarModel.") + ".why_bad_training_data: object is not a familiarModel." + ) } # Store error messages and return the object. diff --git a/R/FamiliarVimpMethod.R b/R/FamiliarVimpMethod.R index f1da4bfb..d49e2bbd 100644 --- a/R/FamiliarVimpMethod.R +++ b/R/FamiliarVimpMethod.R @@ -27,15 +27,18 @@ setMethod( # Set standard purposes for common uses. if (!is.null(purpose)) { if (purpose %in% c("vimp")) { - purpose <- switch(purpose, - "vimp" = "to determine variable importance") + purpose <- switch( + purpose, + "vimp" = "to determine variable importance" + ) } } return(invisible(.require_package( x = x@package, purpose = purpose, - message_type = message_type))) + message_type = message_type + ))) } ) @@ -61,7 +64,8 @@ setMethod( # This is a fall-back method. return(get_placeholder_vimp_table( vimp_method = object@vimp_method, - run_table = object@run_table)) + run_table = object@run_table + )) } ) @@ -71,12 +75,18 @@ setMethod( setMethod( ".vimp", signature(object = "familiarVimpMethod"), - function(object, data, is_pre_processed = FALSE, ...) { + function( + object, + data, + is_pre_processed = FALSE, + cl = NULL, + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table cluster_name <- NULL # Check if the class of object is a subclass of familiarVimpMethod - if (!is_subclass(class(object)[1], "familiarVimpMethod")) { + if (!is_subclass(class(object)[1L], "familiarVimpMethod")) { object <- promote_vimp_method(object) } @@ -84,7 +94,8 @@ setMethod( if (is_empty(data)) { return(get_placeholder_vimp_table( vimp_method = object@vimp_method, - run_table = object@run_table)) + run_table = object@run_table + )) } # Prepare input data @@ -92,7 +103,8 @@ setMethod( object = object, data = data, is_pre_processed = is_pre_processed, - stop_at = "clustering") + stop_at = "clustering" + ) # Work only with data that has known outcomes when determining variable # importance. @@ -103,36 +115,43 @@ setMethod( if (is_empty(data)) { return(get_placeholder_vimp_table( vimp_method = object@vimp_method, - run_table = object@run_table)) + run_table = object@run_table + )) } - + # Identify invariant features and remove them. available_features <- get_feature_columns(x = data) - is_invariant <- sapply( - available_features, - function(feature, data) is_singular_data(data[, get(feature)]), - data = data@data) - + is_invariant <- fam_sapply( + cl = cl, + X = data@data[, mget(available_features)], + FUN = is_singular_data, + progress_bar = FALSE, + chopchop = TRUE + ) invariant_features <- available_features[is_invariant] # Remove invariant features. - if (length(invariant_features) > 0) { + if (length(invariant_features) > 0L) { data <- filter_features( data = data, - remove_features = invariant_features) + remove_features = invariant_features + ) } # Check that the data is suitable for predictions. if (has_bad_training_data(object = object, data = data)) { return(get_placeholder_vimp_table( vimp_method = object@vimp_method, - run_table = object@run_table)) + run_table = object@run_table + )) } # Determine variable importance. vimp_object <- ..vimp( object = object, - data = data) + data = data, + cl = cl + ) # Find signature features. signature_features <- names(object@feature_info)[sapply(object@feature_info, is_in_signature)] @@ -140,18 +159,19 @@ setMethod( # Remove signature features. vimp_object <- remove_signature_features( vimp_object, - features = signature_features) + features = signature_features + ) # Set up a table with clustering information. cluster_table <- .create_clustering_table(object@feature_info) # Remove invariant features from the cluster_table - if (length(invariant_features) > 0) { + if (length(invariant_features) > 0L) { cluster_table <- cluster_table[!cluster_name %in% invariant_features] } # Remove features in the signature. - if (length(signature_features) > 0) { + if (length(signature_features) > 0L) { cluster_table <- cluster_table[!cluster_name %in% signature_features] } @@ -174,12 +194,17 @@ setMethod( setMethod( ".vimp", signature(object = "familiarModel"), - function(object, data, is_pre_processed = FALSE, ...) { + function( + object, + data, + is_pre_processed = FALSE, + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table cluster_name <- NULL # Check if the class of object is a subclass of familiarModel. - if (!is_subclass(class(object)[1], "familiarModel")) { + if (!is_subclass(class(object)[1L], "familiarModel")) { object <- promote_learner(object) } @@ -187,7 +212,8 @@ setMethod( if (is_empty(data)) { return(get_placeholder_vimp_table( vimp_method = object@learner, - run_table = object@run_table)) + run_table = object@run_table + )) } # Prepare input data @@ -195,7 +221,8 @@ setMethod( object = object, data = data, is_pre_processed = is_pre_processed, - stop_at = "clustering") + stop_at = "clustering" + ) # Work only with data that has known outcomes when determining variable # importance. @@ -206,7 +233,8 @@ setMethod( if (is_empty(data)) { return(get_placeholder_vimp_table( vimp_method = object@learner, - run_table = object@run_table)) + run_table = object@run_table + )) } # Identify invariant features and remove them. @@ -214,28 +242,32 @@ setMethod( is_invariant <- sapply( available_features, function(feature, data) is_singular_data(data[, get(feature)]), - data = data@data) + data = data@data + ) invariant_features <- available_features[is_invariant] # Remove invariant features. - if (length(invariant_features) > 0) { + if (length(invariant_features) > 0L) { data <- filter_features( data = data, - remove_features = invariant_features) + remove_features = invariant_features + ) } # Check that the data is suitable for predictions. if (has_bad_training_data(object = object, data = data)) { return(get_placeholder_vimp_table( vimp_method = object@learner, - run_table = object@run_table)) + run_table = object@run_table + )) } # Determine variable importance. vimp_object <- ..vimp( object = object, - data = data) + data = data + ) # Find signature features. signature_features <- names(object@feature_info)[sapply(object@feature_info, is_in_signature)] @@ -243,18 +275,19 @@ setMethod( # Remove signature features. vimp_object <- remove_signature_features( vimp_object, - features = signature_features) + features = signature_features + ) # Set up a table with clustering information. cluster_table <- .create_clustering_table(object@feature_info) # Remove invariant features from the cluster_table - if (length(invariant_features) > 0) { + if (length(invariant_features) > 0L) { cluster_table <- cluster_table[!cluster_name %in% invariant_features] } # Remove features in the signature. - if (length(signature_features) > 0) { + if (length(signature_features) > 0L) { cluster_table <- cluster_table[!cluster_name %in% signature_features] } diff --git a/R/FeatureInfo.R b/R/FeatureInfo.R index b0be5f5e..84ce6299 100644 --- a/R/FeatureInfo.R +++ b/R/FeatureInfo.R @@ -2,102 +2,15 @@ #' @include FamiliarS4Classes.R NULL -create_feature_info <- function( - data, - signature = NULL, - ...) { - # This creates a list of featureInfo objects, with processing, based on data. - # This code is primarily used within unit tests. - - # Reconstitute settings from the data. - settings <- extract_settings_from_data(data = data) - - # Update some missing settings that can be fixed within this method. - settings$data$train_cohorts <- unique(data@data[[get_id_columns(single_column = "batch")]]) - - # Parse the remaining settings that are important. - settings <- do.call( - .parse_general_settings, - args = c( - list( - "settings" = settings, - "data" = data@data), - list(...))) - - # Create a list of featureInfo objects. - feature_info_list <- .get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = data@outcome_type) - - # Extract the generic data. - feature_info_list <- feature_info_list[["generic"]] - - # Add signature feature info - feature_info_list <- add_signature_info( - feature_info_list = feature_info_list, - signature = signature) - - # Perform some pre-processing (i.e. remove singular features) - feature_info_list <- .determine_preprocessing_parameters( - cl = NULL, - data = data, - feature_info_list = feature_info_list, - settings = settings, - verbose = FALSE) - - return(feature_info_list) -} - - - -.get_feature_info_data <- function( - data, - file_paths, - project_id, - outcome_type) { - # Create path to the feature info file - feature_info_file <- .get_feature_info_file_name( - file_paths = file_paths, - project_id = project_id) - - if (is.null(file_paths)) { - # Create, but do not store to disk. - feature_info_list <- list() - feature_info_list[["generic"]] <- .get_generic_feature_info( - data = data, - outcome_type = outcome_type, - descriptor = NULL) - - } else if (!file.exists(feature_info_file)) { - # Generate feature information - feature_info_list <- list() - feature_info_list[["generic"]] <- .get_generic_feature_info( - data = data, - outcome_type = outcome_type, - descriptor = NULL) - - # Write to file - saveRDS(feature_info_list, file = feature_info_file) - - } else { - # Read from file. - feature_info_list <- readRDS(feature_info_file) - - # Update to current standard. - feature_info_list <- update_object(feature_info_list) - } - - return(feature_info_list) -} .get_generic_feature_info <- function( data, outcome_type, - descriptor = NULL) { + descriptor = NULL, + project_id +) { # Initialises feature_info objects # Expect that data is a data.table. @@ -106,12 +19,13 @@ create_feature_info <- function( # Identify feature columns feature_columns <- get_feature_columns( x = data, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Iterate over feature columns and create a list of feature_info objects feature_info_list <- lapply( feature_columns, - function(ii, data, descriptor) { + function(ii, data, descriptor, project_id) { # Determine feature type if (is.factor(data[[ii]])) { feature_type <- "factor" @@ -126,7 +40,8 @@ create_feature_info <- function( "featureInfo", name = ii, set_descriptor = ifelse(is.null(descriptor), NA_character_, as.character(descriptor)), - feature_type = feature_type) + feature_type = feature_type + ) # Set factor levels for future reproducibility if (feature_type == "factor") { @@ -140,13 +55,18 @@ create_feature_info <- function( feature_info@removed_unknown_type <- TRUE } + # Add project_id. + feature_info@project_id + # Update the familiar version. feature_info <- add_package_version(object = feature_info) return(feature_info) }, data = data, - descriptor = descriptor) + descriptor = descriptor, + project_id = project_id + ) # Set names in the list of featureInfo objects names(feature_info_list) <- feature_columns @@ -159,7 +79,9 @@ create_feature_info <- function( add_control_info <- function( feature_info_list, data_id, - run_id) { + run_id, + project_id +) { # Control information is added to every feature regardless of "removed'. # Make sure that both identifiers are integers @@ -169,15 +91,18 @@ add_control_info <- function( # Update the feature info list. feature_info_list <- lapply( feature_info_list, - function(object, data_id, run_id) { + function(object, data_id, run_id, project_id) { # Add data and run ids. object@data_id <- data_id object@run_id <- run_id + object@project_id <- project_id return(object) }, data_id = data_id, - run_id = run_id) + run_id = run_id, + project_id = project_id + ) return(feature_info_list) } @@ -186,7 +111,8 @@ add_control_info <- function( add_signature_info <- function( feature_info_list, - signature = NULL) { + signature = NULL +) { # Sets the in_signature flag on features in the signature variable. # Check if there is a signature @@ -207,7 +133,8 @@ add_signature_info <- function( return(object) }, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Update the names names(upd_list) <- signature @@ -222,7 +149,8 @@ add_signature_info <- function( add_novelty_info <- function( feature_info_list, - novelty_features = NULL) { + novelty_features = NULL +) { # Sets the in_novelty flag on features in the novelty_features variable. # Check if there is a signature @@ -243,7 +171,8 @@ add_novelty_info <- function( return(object) }, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Update the names names(upd_list) <- novelty_features @@ -256,10 +185,24 @@ add_novelty_info <- function( +add_fairness_info <- function( + feature_info_list, + fairness_features = NULL +) { + if (is.null(fairness_features)) return(feature_info_list) + + # TODO: Implement fairness features. + browser() +} + + + add_missing_value_fractions <- function( cl = NULL, feature_info_list, - data, threshold) { + data, + threshold +) { # Add the fraction of missing values for features # Identify the feature columns in the data @@ -272,7 +215,8 @@ add_missing_value_fractions <- function( X = data@data[, mget(feature_columns)], FUN = function(data) (return(sum(is_valid_data(data)))), progress_bar = FALSE, - chopchop = TRUE) + chopchop = TRUE + ) # Determine fraction of missing values missing_frac <- 1.0 - n_valid_val / nrow(data@data) @@ -299,7 +243,8 @@ add_missing_value_fractions <- function( feature_columns = feature_columns, feature_info_list = feature_info_list, missing_frac = missing_frac, - threshold = threshold) + threshold = threshold + ) # Set names of the updated list names(upd_list) <- feature_columns @@ -314,8 +259,7 @@ add_missing_value_fractions <- function( add_required_features <- function(feature_info_list) { # Find features that are not removed - available_features <- get_available_features( - feature_info_list = feature_info_list) + available_features <- get_available_features(feature_info_list = feature_info_list) # Add required features slot upd_list <- lapply( @@ -329,14 +273,16 @@ add_required_features <- function(feature_info_list) { # Required features for imputation if (is(object@imputation_parameters, "featureInfoParametersImputation")) { - required_features <- c( - required_features, object@imputation_parameters@required_features) + required_features <- union( + required_features, object@imputation_parameters@required_features + ) } # Required features for clustering if (is(object@cluster_parameters, "featureInfoParametersCluster")) { - required_features <- c( - required_features, object@cluster_parameters@required_features) + required_features <- union( + required_features, object@cluster_parameters@required_features + ) } # Add required features @@ -344,7 +290,8 @@ add_required_features <- function(feature_info_list) { return(object) }, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Set names of the updated list names(upd_list) <- available_features @@ -361,7 +308,8 @@ add_required_features <- function(feature_info_list) { compute_feature_distribution_data <- function( cl, feature_info_list, - data) { + data +) { # Identify the feature columns in the data feature_columns <- get_feature_columns(x = data) @@ -373,9 +321,10 @@ compute_feature_distribution_data <- function( object = feature_info_list[feature_columns], x = data@data[, mget(feature_columns)], progress_bar = FALSE, - chopchop = TRUE) + chopchop = TRUE + ) - if (length(feature_columns) > 0) { + if (length(feature_columns) > 0L) { feature_info_list[feature_columns] <- updated_feature_info } @@ -400,15 +349,26 @@ compute_feature_distribution_data <- function( # Number of samples distr_list[["n"]] <- length(x) - # Five-number summary of outcome values - distr_list[["fivenum"]] <- fivenum_summary(x, na.rm = TRUE) + if (anyNA(x)) x <- x[!is.na(x)] + + # Five-number summary of feature values + distr_list[["fivenum"]] <- fivenum_summary(x, na.rm = FALSE) # Mean value - distr_list[["mean"]] <- mean(x, na.rm = TRUE) + distr_list[["mean"]] <- mean(x, na.rm = FALSE) + + # Percentile summary of feature values + distr_list[["pctl"]] <- stats::spline( + x = (seq_along(x) - 1L) / (length(x) - 1L), + y = sort(x), + method = "hyman", + xout = (seq_len(101L) - 1L) / 100L + )$y } else { ..error_reached_unreachable_code( - ".compute_feature_distribution_data: unknown feature type encountered.") + ".compute_feature_distribution_data: unknown feature type encountered." + ) } # Add to slot @@ -422,7 +382,8 @@ compute_feature_distribution_data <- function( find_invariant_features <- function( cl = NULL, feature_info_list, - data) { + data +) { # Find features that are invariant. Such features are ill-behaved and should # be removed. @@ -436,12 +397,13 @@ find_invariant_features <- function( X = data@data[, mget(feature_columns)], FUN = is_singular_data, progress_bar = FALSE, - chopchop = TRUE) + chopchop = TRUE + ) singular_features <- feature_columns[singular_features] # Iterate over singular features and mark for removal - if (length(singular_features) > 0) { + if (length(singular_features) > 0L) { upd_list <- lapply( singular_features, function(ii, feature_info_list) { @@ -456,7 +418,8 @@ find_invariant_features <- function( return(object) }, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Add names to the elements of upd_list names(upd_list) <- singular_features @@ -474,7 +437,8 @@ find_low_variance_features <- function( cl = NULL, feature_info_list, data, - settings) { + settings +) { # Determine which features have a very low variance and remove these # Suppress NOTES due to non-standard evaluation in data.table @@ -487,11 +451,12 @@ find_low_variance_features <- function( is_numeric <- sapply( feature_columns, function(ii, data) (is.numeric(data@data[[ii]])), - data = data) + data = data + ) numeric_columns <- feature_columns[is_numeric] # Skip if there are no numeric columns - if (length(numeric_columns) == 0) return(feature_info_list) + if (length(numeric_columns) == 0L) return(feature_info_list) # Determine variance. feature_variances <- fam_sapply( @@ -501,18 +466,20 @@ find_low_variance_features <- function( FUN = stats::var, progress_bar = FALSE, na.rm = TRUE, - chopchop = TRUE) + chopchop = TRUE + ) # Define a data table containing the variances variance_data <- data.table::data.table( "name" = numeric_columns, - "variance" = feature_variances) + "variance" = feature_variances + ) # Set missing parameters if (is.null(settings$prep$low_var_threshold)) { # If unset, potentially include all data, pending # low_var_max_feature_set_size. - settings$prep$low_var_threshold <- -1 + settings$prep$low_var_threshold <- -1.0 } if (is.null(settings$prep$low_var_max_feature_set_size)) { @@ -524,14 +491,15 @@ find_low_variance_features <- function( if (settings$prep$low_var_max_feature_set_size > nrow(variance_data)) { # If the number allowed features in the feature set exceeds the actual # number of features, set the mimimum variance threshold to 0. - min_var_thresh <- 0 + min_var_thresh <- 0.0 } else { # Else, set the minimum variance threshold to the level that corresponds to # maximum feature set size. min_var_thresh <- sort( variance_data$variance, - decreasing = TRUE)[settings$prep$max_var_feat_set_size] + decreasing = TRUE + )[settings$prep$max_var_feat_set_size] } # Set the variance threshold @@ -541,7 +509,7 @@ find_low_variance_features <- function( low_variance_features <- variance_data[variance < sel_var_thresh]$name # Set removal status - if (length(low_variance_features) > 0) { + if (length(low_variance_features) > 0L) { upd_list <- lapply( low_variance_features, function(ii, feature_info_list) { @@ -556,7 +524,8 @@ find_low_variance_features <- function( return(object) }, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Add names to the elements of upd_list names(upd_list) <- low_variance_features @@ -574,13 +543,14 @@ find_non_robust_features <- function( cl = NULL, feature_info_list, data, - settings) { + settings +) { # Determine which features lack robustness and are to be removed. This is only # possible for repeated measurements. # Check if repeated measurements are present, otherwise return feature info # list as is.. - if (all(data@data$repetition_id == 1)) return(feature_info_list) + if (all(data@data$repetition_id == 1L)) return(feature_info_list) # Determine which columns contain feature data feature_columns <- get_feature_columns(x = data) @@ -589,11 +559,12 @@ find_non_robust_features <- function( is_numeric <- sapply( feature_columns, function(ii, data) (is.numeric(data@data[[ii]])), - data = data) + data = data + ) numeric_columns <- feature_columns[is_numeric] # Skip if there are no columns with numeric data. - if (length(numeric_columns) == 0) return(feature_info_list) + if (length(numeric_columns) == 0L) return(feature_info_list) # Read several items from settings icc_type <- settings$prep$robustness_icc_type @@ -610,8 +581,10 @@ find_non_robust_features <- function( progress_bar = FALSE, MoreArgs = list( "id_data" = data@data[, mget(get_id_columns())], - "type" = icc_type), - chopchop = TRUE) + "type" = icc_type + ), + chopchop = TRUE + ) # Combine ICC data from list icc_table <- data.table::rbindlist(icc_list) @@ -620,7 +593,7 @@ find_non_robust_features <- function( low_robustness_features <- icc_table[get(icc_filter_column) < icc_threshold]$feature # Set removal flags for features with low robustness - if (length(low_robustness_features) > 0) { + if (length(low_robustness_features) > 0L) { upd_list <- lapply( low_robustness_features, function(ii, feature_info_list) { @@ -635,7 +608,8 @@ find_non_robust_features <- function( return(object) }, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Add names to the elements of upd_list names(upd_list) <- low_robustness_features @@ -653,25 +627,25 @@ find_unimportant_features <- function( cl = NULL, feature_info_list, data, - settings) { + settings +) { # Find which features are not important for the current endpoint. # Suppress NOTES due to non-standard evaluation in data.table - p_full <- q_full <- p_val <- q_val <- name <- NULL - p_median <- q_median <- q_sel <- p_sel <- NULL + p_full <- p_val <- name <- p_median <- p_sel <- NULL - # Base calculatutions on medians/modes for repeated data. Repeated + # Base calculations on medians/modes for repeated data. Repeated # measurements are not independent and may inflate statistics. data <- aggregate_data(data = data) # Determine feature columns feature_columns <- get_feature_columns(x = data) - # Set q-value to 1 if none is provided + # Set p-value to 1 if none is provided if (is.null(settings$prep$univar_threshold)) { # If NULL, allow potential selection of all features, pending # univar_feat_set_size. - settings$prep$univar_threshold <- 1 + settings$prep$univar_threshold <- 1.0 } if (is.null(settings$prep$univar_feat_set_size)) { @@ -681,18 +655,20 @@ find_unimportant_features <- function( } # Generate bootstraps - n_iter <- 10 + n_iter <- 10L iter_list <- .create_bootstraps( n_iter = n_iter, settings = settings, data = data@data, - stratify = TRUE) + stratify = TRUE + ) # Calculate p-values of the coefficients regr_pval <- compute_univariable_p_values( cl = cl, data_obj = data, - feature_columns = feature_columns) + feature_columns = feature_columns + ) # Find and replace non-finite values regr_pval[!is.finite(regr_pval)] <- 1.0 @@ -700,74 +676,55 @@ find_unimportant_features <- function( # Add to table. regression_data <- data.table::data.table( "name" = names(regr_pval), - "p_full" = regr_pval) - regression_data[!is.finite(p_full), "p_full" := 1] - - # Calculate q-value - if (nrow(regression_data) >= 2 && is_package_installed(name = "qvalue")) { - ..deprecation_qvalue() - regression_data[, "q_full" := qvalue::qvalue(p = p_full, lambda = 0)$qvalues] - - } else { - regression_data[, "q_full" := p_full] - } + "p_full" = regr_pval + ) + regression_data[!is.finite(p_full), "p_full" := 1.0] - if (settings$prep$univar_metric == "q_value") { - # Filter out features with high q-value - feature_columns <- feature_columns[ - feature_columns %in% regression_data[ - q_full <= settings$prep$univar_threshold, ]$name] - - } else if (settings$prep$univar_metric == "p_value") { + if (settings$prep$univar_metric == "p_value") { # Filter out features with high p-value feature_columns <- feature_columns[ feature_columns %in% regression_data[ - p_full <= settings$prep$univar_threshold, ]$name] + p_full <= settings$prep$univar_threshold + , + ]$name + ] } # Initiate storage list regression_data_bootstrap <- list() # Iterate over bootstraps - for (ii in 1:n_iter) { + for (ii in 1L:n_iter) { # Bootstrap data bootstrap_samples <- select_data_from_samples( data = data, - samples = iter_list$train_list[[ii]]) + samples = iter_list$train_list[[ii]] + ) # Calculate p-values for the current bootstrap - if (length(feature_columns) > 0) { + if (length(feature_columns) > 0L) { regr_pval <- compute_univariable_p_values( cl = cl, data_obj = bootstrap_samples, - feature_columns = feature_columns) + feature_columns = feature_columns + ) regression_data_bootstrap[[ii]] <- data.table::data.table( "name" = names(regr_pval), "p_val" = regr_pval, - "iter_id" = ii) + "iter_id" = ii + ) regression_data_bootstrap[[ii]][!is.finite(p_val), "p_val" := 1.0] - - # Calculate q-values for the current bootstrap - if ( - nrow(regression_data_bootstrap[[ii]]) >= 2 && - is_package_installed(name = "qvalue")) { - ..deprecation_qvalue() - regression_data_bootstrap[[ii]][, "q_val" := qvalue::qvalue(p = p_val, lambda = 0)$qvalues] - - } else { - regression_data_bootstrap[[ii]][, "q_val" := p_val] - } rm(regr_pval) } else { regression_data_bootstrap[[ii]] <- data.table::data.table( - "name" = character(), - "p_val" = numeric(), - "iter_id" = numeric(), - "q_val" = numeric()) + "name" = character(0L), + "p_val" = numeric(0L), + "iter_id" = numeric(0L) + ) } rm(bootstrap_samples) @@ -777,35 +734,35 @@ find_unimportant_features <- function( regression_data_bootstrap <- data.table::rbindlist(regression_data_bootstrap) # Calculate median metric values of the bootstraps - regression_data_bootstrap <- regression_data_bootstrap[, list( - "p_median" = stats::median(p_val, na.rm = TRUE), - "q_median" = stats::median(q_val, na.rm = TRUE)), - by = name] + regression_data_bootstrap <- regression_data_bootstrap[ + , + list("p_median" = stats::median(p_val, na.rm = TRUE)), + by = name + ] # Merge median metric value table and the full table regression_data_bootstrap <- merge( x = regression_data_bootstrap, y = regression_data, by = "name", - all = TRUE) + all = TRUE + ) # Address non-finite entries - regression_data_bootstrap[!is.finite(p_median), "p_median" := 1] - regression_data_bootstrap[!is.finite(q_median), "q_median" := 1] + regression_data_bootstrap[!is.finite(p_median), "p_median" := 1.0] # Find the worst entries among the bootstraps and the full analysis - regression_data_bootstrap[, ":="( - "p_sel" = pmax(p_median, p_full), - "q_sel" = pmax(q_median, q_full)), - by = name] + regression_data_bootstrap[ + , + ":="("p_sel" = pmax(p_median, p_full)), + by = name + ] rm(regression_data) # Determine cutoff required to obtain the maximally sized feature set if (settings$prep$univar_feat_set_size > nrow(regression_data_bootstrap)) { - max_thresh <- 1 - } else if (settings$prep$univar_metric == "q_value") { - max_thresh <- sort(regression_data_bootstrap$q_sel)[settings$prep$univar_feat_set_size] + max_thresh <- 1.0 } else if (settings$prep$univar_metric == "p_value") { max_thresh <- sort(regression_data_bootstrap$p_sel)[settings$prep$univar_feat_set_size] } @@ -813,16 +770,14 @@ find_unimportant_features <- function( # Set the actual q threshold (the lower of max_q_thresh and settings$prep$univar_threshold) sel_thresh <- min(max_thresh, settings$prep$univar_threshold) - # Return features which have a q-value above the selected threshold - if (settings$prep$univar_metric == "q_value") { - unimportant_features <- regression_data_bootstrap[q_sel > sel_thresh, ]$name - } else if (settings$prep$univar_metric == "p_value") { + # Return features which have a p-value above the selected threshold + if (settings$prep$univar_metric == "p_value") { unimportant_features <- regression_data_bootstrap[p_sel > sel_thresh, ]$name } else { - unimportant_features <- character(0) + unimportant_features <- character(0L) } - if (length(unimportant_features) > 0) { + if (length(unimportant_features) > 0L) { upd_list <- lapply( unimportant_features, function(ii, feature_info_list) { @@ -837,7 +792,8 @@ find_unimportant_features <- function( return(object) }, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Add names to the elements of upd_list names(upd_list) <- unimportant_features @@ -855,12 +811,13 @@ get_available_features <- function( feature_info_list, data_obj = NULL, exclude_signature = FALSE, - exclude_novelty = FALSE) { + exclude_novelty = FALSE +) { # Determine the intersect of features a removed slot == FALSE and available # columns in dt (if not NULL). # Check that any features are available. - if (length(feature_info_list) == 0) return(NULL) + if (length(feature_info_list) == 0L) return(NULL) available_list_features <- names(feature_info_list)[sapply(feature_info_list, is_available)] @@ -900,7 +857,8 @@ get_available_features <- function( find_novelty_features <- function( model_features = NULL, - feature_info_list) { + feature_info_list +) { # Find additional features that should be used for novelty detection. novelty_features <- unlist(lapply( feature_info_list, @@ -909,7 +867,8 @@ find_novelty_features <- function( if (!feature_info@in_novelty) return(NULL) return(feature_info@name) - })) + } + )) return(union(model_features, novelty_features)) } @@ -925,7 +884,8 @@ trim_unused_features_from_list <- function(feature_info_list) { if (feature_info@removed) return(NULL) return(feature_info@required_features) - })) + } + )) # All required features. required_features <- unique(required_features) @@ -938,7 +898,8 @@ trim_unused_features_from_list <- function(feature_info_list) { if (!feature_info@in_signature) return(NULL) return(feature_info@name) - })) + } + )) # All novelty features. novelty_features <- unlist(lapply( @@ -948,12 +909,14 @@ trim_unused_features_from_list <- function(feature_info_list) { if (!feature_info@in_novelty) return(NULL) return(feature_info@name) - })) + } + )) features_kept <- unique(c( required_features, signature_features, - novelty_features)) + novelty_features + )) return(feature_info_list[features_kept]) } @@ -964,7 +927,8 @@ trim_unused_features_from_list <- function(feature_info_list) { feature, object, model_list, - stop_at = "imputation") { + stop_at = "imputation" +) { # Suppress NOTES due to non-standard evaluation in data.table min <- Q1 <- median <- Q3 <- max <- count <- NULL @@ -979,7 +943,8 @@ trim_unused_features_from_list <- function(feature_info_list) { return(fam_model@feature_info[[feature]]) } }, - feature = feature) + feature = feature + ) # Remove NULL entries feature_info_list[sapply(feature_info_list, is.null)] <- NULL @@ -987,12 +952,13 @@ trim_unused_features_from_list <- function(feature_info_list) { # Create a skeleton feature_info <- methods::new("featureInfo", name = feature, - set_descriptor = feature_info_list[[1]]@set_descriptor, - feature_type = feature_info_list[[1]]@feature_type, - levels = feature_info_list[[1]]@levels, - data_id = as.integer(object@run_table$ensemble_data_id), - run_id = as.integer(object@run_table$ensemble_run_id), - in_signature = feature_info_list[[1]]@in_signature) + set_descriptor = feature_info_list[[1L]]@set_descriptor, + feature_type = feature_info_list[[1L]]@feature_type, + levels = feature_info_list[[1L]]@levels, + data_id = as.integer(object@data_id), + run_id = as.integer(object@run_id), + in_signature = feature_info_list[[1L]]@in_signature + ) # Add package version. feature_info <- add_package_version(object = feature_info) @@ -1001,32 +967,41 @@ trim_unused_features_from_list <- function(feature_info_list) { feature_info@fraction_missing <- mean(extract_from_slot( object_list = feature_info_list, slot_name = "fraction_missing", - na.rm = TRUE)) + na.rm = TRUE + )) - if (!all_empty_slot( - object_list = feature_info_list, - slot_name = "robustness")) { + if ( + !all_empty_slot( + object_list = feature_info_list, + slot_name = "robustness" + ) + ) { # Compute average robustness feature_info@robustness <- mean(extract_from_slot( object_list = feature_info_list, slot_name = "robustness", - na.rm = TRUE)) + na.rm = TRUE + )) } - if (!all_empty_slot( - object_list = feature_info_list, - slot_name = "univariate_importance")) { + if ( + !all_empty_slot( + object_list = feature_info_list, + slot_name = "univariate_importance" + ) + ) { # Compute average univariate importance feature_info@univariate_importance <- mean(extract_from_slot( object_list = feature_info_list, slot_name = "univariate_importance", - na.rm = TRUE)) + na.rm = TRUE + )) } # Find distribution items - distribution_items <- names(feature_info_list[[1]]@distribution) + distribution_items <- names(feature_info_list[[1L]]@distribution) if (!is.null(distribution_items)) { # Placeholder list @@ -1039,13 +1014,14 @@ trim_unused_features_from_list <- function(feature_info_list) { fivenum_values <- lapply( feature_info_list, function(feature_info, item) (feature_info@distribution[[item]]), - item = item) + item = item + ) # Combine all the data.tables fivenum_values <- data.table::rbindlist(fivenum_values) # Check for zero-length lists. - if (is_empty(fivenum_values)) next() + if (is_empty(fivenum_values)) next # Summarise fivenum_values <- fivenum_values[, list( @@ -1064,7 +1040,8 @@ trim_unused_features_from_list <- function(feature_info_list) { frequency_values <- lapply( feature_info_list, function(feature_info, item) (feature_info@distribution[[item]]), - item = item) + item = item + ) # Combine all the data.tables frequency_values <- data.table::rbindlist(frequency_values) @@ -1073,6 +1050,24 @@ trim_unused_features_from_list <- function(feature_info_list) { # Summarise and add to list distr_list[[item]] <- frequency_values[, list("count" = mean(count)), by = "factor_level"] + + } else if (grepl(pattern = "pctl", x = item, fixed = TRUE)) { + + # Aggregate from list + pctl_values <- unlist( + lapply( + feature_info_list, + function(feature_info, item) (feature_info@distribution[[item]]), + item = item + ), + use.names = FALSE + ) + + # Check for zero-length lists. + if (is_empty(pctl_values)) next + + # Add to list + distr_list[[item]] <- unique(sort(pctl_values)) } else { # Find mean value @@ -1080,7 +1075,8 @@ trim_unused_features_from_list <- function(feature_info_list) { object_list = feature_info_list, slot_name = "distribution", slot_element = item, - na.rm = TRUE)) + na.rm = TRUE + )) } } @@ -1095,7 +1091,8 @@ trim_unused_features_from_list <- function(feature_info_list) { transformation_parameter_data <- ..collect_and_aggregate_transformation_info( feature_info_list = feature_info_list, instance_mask = instance_mask, - feature_name = feature) + feature_name = feature + ) # Set the aggregated transformation parameters. feature_info@transformation_parameters <- transformation_parameter_data$parameters @@ -1107,7 +1104,8 @@ trim_unused_features_from_list <- function(feature_info_list) { normalisation_parameter_data <- ..collect_and_aggregate_normalisation_info( feature_info_list = feature_info_list, instance_mask = instance_mask, - feature_name = feature) + feature_name = feature + ) # Set the aggregated normalisation methods. feature_info@normalisation_parameters <- normalisation_parameter_data$parameters @@ -1119,7 +1117,8 @@ trim_unused_features_from_list <- function(feature_info_list) { batch_normalisation_parameter_data <- ..collect_and_aggregate_batch_normalisation_info( feature_info_list = feature_info_list, instance_mask = instance_mask, - feature_name = feature) + feature_name = feature + ) # Update batch normalisation parameter data. feature_info@batch_normalisation_parameters <- batch_normalisation_parameter_data$parameters @@ -1131,7 +1130,8 @@ trim_unused_features_from_list <- function(feature_info_list) { imputation_parameter_data <- ..collect_and_aggregate_imputation_info( feature_info_list = feature_info_list, feature_name = feature, - feature_type = feature_info@feature_type) + feature_type = feature_info@feature_type + ) # Add to slot. feature_info@imputation_parameters <- imputation_parameter_data$parameters @@ -1162,17 +1162,19 @@ trim_unused_features_from_list <- function(feature_info_list) { if (feature_type == "categorical") { # Show levels, including which level is the reference. classes_str <- object@levels - classes_str[1] <- paste0(classes_str[1], " (reference)") + classes_str[1L] <- paste0(classes_str[1L], " (reference)") feature_str <- paste0( feature_str, ", with levels: ", - paste_s(classes_str)) + paste_s(classes_str) + ) } else if (feature_type == "ordinal") { # Show ordered levels of the ordinal. feature_str <- paste0( feature_str, ", with levels: ", - paste0(object@levels, collapse = " < ")) + paste0(object@levels, collapse = " < ") + ) } return(paste0(feature_str, line_end)) @@ -1206,7 +1208,8 @@ setMethod( power.transform::get_shift(transform_parameters@transformer), ", and scale = ", power.transform::get_scale(transform_parameters@transformer), - ".\n") + ".\n" + ) } } } @@ -1226,7 +1229,8 @@ setMethod( normalisation_parameters@shift, " and scale = ", normalisation_parameters@scale, - ".\n") + ".\n" + ) } } else if (is(normalisation_parameters, "featureInfoParametersNormalisationShift")) { @@ -1236,7 +1240,8 @@ setMethod( normalisation_parameters@method, ") with shift = ", normalisation_parameters@shift, - ".\n") + ".\n" + ) } } } @@ -1253,28 +1258,36 @@ setMethod( for (normalisation_parameters in batch_parameters@batch_parameters) { if (is(normalisation_parameters, "featureInfoParametersNormalisationShiftScale")) { if (normalisation_parameters@shift != 0.0 || normalisation_parameters@scale != 1.0) { - batch_norm_str <- c(batch_norm_str, paste0( - " [", - normalisation_parameters@batch, - "] normalisation (", - normalisation_parameters@method, - ") with shift = ", - normalisation_parameters@shift, - " and scale = ", - normalisation_parameters@scale, - ".\n")) + batch_norm_str <- c( + batch_norm_str, + paste0( + " [", + normalisation_parameters@batch, + "] normalisation (", + normalisation_parameters@method, + ") with shift = ", + normalisation_parameters@shift, + " and scale = ", + normalisation_parameters@scale, + ".\n" + ) + ) } } else if (is(normalisation_parameters, "featureInfoParametersNormalisationShift")) { if (normalisation_parameters@shift != 0.0) { - batch_norm_str <- c(batch_norm_str, paste0( - " [", - normalisation_parameters@batch, - "] normalisation (", - normalisation_parameters@method, - ") with shift = ", - normalisation_parameters@shift, - ".\n")) + batch_norm_str <- c( + batch_norm_str, + paste0( + " [", + normalisation_parameters@batch, + "] normalisation (", + normalisation_parameters@method, + ") with shift = ", + normalisation_parameters@shift, + ".\n" + ) + ) } } } @@ -1287,24 +1300,27 @@ setMethod( # Attempt to create an actual descriptor, if meaningful. if (is(object@cluster_parameters, "featureInfoParametersCluster")) { - if (object@cluster_parameters@cluster_size > 1) { + if (object@cluster_parameters@cluster_size > 1L) { + # Find the feature(s) required to form the cluster. cluster_feature_names <- object@cluster_parameters@required_features # Find the clustering method. if (is(object@cluster_parameters@method, "clusterMethod")) { cluster_method_str <- paste0( - "(", object@cluster_parameters@method@method, ") ") + "(", object@cluster_parameters@method@method, ") " + ) } else if (is(object@cluster_parameters@method, "character")) { cluster_method_str <- paste0( - "(", object@cluster_parameters@method, ") ") + "(", object@cluster_parameters@method, ") " + ) } else { cluster_method_str <- NULL } - if (length(cluster_feature_names) == 1) { + if (length(cluster_feature_names) == 1L) { # Only one feature is required to form the cluster. if (cluster_feature_names == object@name) { # The current feature is the reference feature. @@ -1312,8 +1328,13 @@ setMethod( " forms cluster ", cluster_method_str, "with ", - object@cluster_parameters@cluster_size - 1, - " other features, and is the reference feature.\n") + object@cluster_parameters@cluster_size - 1L, + " other features, and is the reference feature." + ) + + # Determine other features that are clustered with the current + # feature. + other_features <- setdiff(object@cluster_parameters@cluster_features, object@name) } else { # The current feature is not the reference feature. @@ -1321,10 +1342,18 @@ setMethod( " forms cluster ", cluster_method_str, "with ", - object@cluster_parameters@cluster_size - 1, + object@cluster_parameters@cluster_size - 1L, " other features, with ", cluster_feature_names, - " as the reference feature.\n") + " as the reference feature." + ) + + # Determine other features that are clustered with the current + # feature. + other_features <- setdiff( + object@cluster_parameters@cluster_features, + c(object@name, cluster_feature_names) + ) } } else { @@ -1334,16 +1363,37 @@ setMethod( cluster_method_str, "with ", paste_s(setdiff(cluster_feature_names, object@name)), - ".\n") + "." + ) + + # Determine other features that are clustered with the current + # feature. + other_features <- setdiff( + object@cluster_parameters@cluster_features, + c(object@name, cluster_feature_names) + ) } + + # Mention additional features in the cluster. + if (length(other_features) > 0L) { + cluster_str <- c( + cluster_str, + paste0(" Other feature(s) in the cluster: ", paste_sh(other_features)) + ) + } + + # Close cluster part of the string. + cluster_str <- c(cluster_str, "\n") } } # Make the feature string complete, depending on additional information. - if (length(transform_str) == 0 && - length(normalisation_str) == 0 && - length(batch_norm_str) == 0 && - length(cluster_str) == 0) { + if ( + length(transform_str) == 0L && + length(normalisation_str) == 0L && + length(batch_norm_str) == 0L && + length(cluster_str) == 0L + ) { feature_str <- paste0(feature_str, ".\n") } else { @@ -1352,10 +1402,10 @@ setMethod( # Export to console. cat(feature_str) - if (length(transform_str) > 0) cat(transform_str) - if (length(normalisation_str) > 0) cat(normalisation_str) - if (length(batch_norm_str) > 0) cat(batch_norm_str) - if (length(cluster_str) > 0) cat(cluster_str) + if (length(transform_str) > 0L) cat(transform_str, sep = "") + if (length(normalisation_str) > 0L) cat(normalisation_str, sep = "") + if (length(batch_norm_str) > 0L) cat(batch_norm_str, sep = "") + if (length(cluster_str) > 0L) cat(cluster_str, sep = "") } ) @@ -1370,26 +1420,22 @@ setMethod( if (!is_available(object)) return(TRUE) if (level == "none") return(TRUE) + if (level == "signature") return(TRUE) if (!feature_info_complete(object@transformation_parameters)) return(FALSE) - if (level == "transformation") return(TRUE) if (!feature_info_complete(object@normalisation_parameters)) return(FALSE) - if (level == "normalisation") return(TRUE) if (!feature_info_complete(object@batch_normalisation_parameters)) return(FALSE) - if (level == "batch_normalisation") return(TRUE) if (!feature_info_complete(object@imputation_parameters)) return(FALSE) - if (level == "imputation") return(TRUE) if (!feature_info_complete(object@cluster_parameters)) return(FALSE) - if (level == "clustering") return(TRUE) return(TRUE) @@ -1406,7 +1452,8 @@ setMethod( return(all(sapply( object, feature_info_complete, - level = level))) + level = level + ))) } ) diff --git a/R/FeatureInfoParameters.R b/R/FeatureInfoParameters.R index 7e74875b..1ac0bc4f 100644 --- a/R/FeatureInfoParameters.R +++ b/R/FeatureInfoParameters.R @@ -8,11 +8,13 @@ setMethod( "add_feature_info_parameters", signature( object = "NULL", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # This is when feature info parameters are completely missing. return(object) } @@ -25,11 +27,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParameters", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # Default behaviour is to return the object as is. return(object) } @@ -41,11 +45,13 @@ setMethod( "apply_feature_info_parameters", signature( object = "NULL", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # This is when feature info parameters are completely missing. return(data) } @@ -58,11 +64,13 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParameters", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # Default behaviour is to return the data as is. return(data) } diff --git a/R/FeatureSelection.R b/R/FeatureSelection.R deleted file mode 100644 index 0a9c146b..00000000 --- a/R/FeatureSelection.R +++ /dev/null @@ -1,235 +0,0 @@ -run_feature_selection <- function( - cl, - project_list, - settings, - file_paths, - message_indent = 0L, - verbose = TRUE) { - # Check which data object is required for performing feature selection. - fs_data_id <- .get_process_step_data_identifier( - project_info = project_list, - process_step = "fs") - - # Get feature selection methods that still need to be checked. - run_fs_methods <- .find_missing_feature_selection_data( - project_list = project_list, - settings = settings, - file_paths = file_paths) - - # Get runs - run_list <- .get_run_list( - iteration_list = project_list$iter_list, - data_id = fs_data_id) - - # Remove cluster information in case no parallelisation is provided. - cl_fs <- NULL - if (settings$fs$do_parallel) cl_fs <- cl - - # Create variable importance matrices by iterating over feature selection - # methods - for (curr_fs_method in run_fs_methods) { - logger_message( - paste0( - "\nFeature selection: starting feature selection using \"", - curr_fs_method, "\" method."), - indent = message_indent, - verbose = verbose) - - # Optimise models used for feature selection - hpo_list <- run_hyperparameter_optimisation( - cl = cl, - project_list = project_list, - data_id = fs_data_id, - settings = settings, - file_paths = file_paths, - vimp_method = curr_fs_method, - message_indent = message_indent + 1L, - verbose = verbose) - - # Create variable importance information by iterating over the list of runs. - vimp_list <- fam_mapply_lb( - cl = cl_fs, - assign = "all", - FUN = compute_variable_importance, - run = run_list, - progress_bar = verbose, - MoreArgs = list( - "fs_method" = curr_fs_method, - "hpo_list" = hpo_list, - "settings" = settings)) - - # Save to file - saveRDS(vimp_list, file = .get_feature_selection_data_filename( - project_id = project_list$project_id, - fs_method = curr_fs_method, - file_paths = file_paths)) - - # Message that feature selection has been completed. - logger_message(paste0( - "Feature selection: feature selection using \"", - curr_fs_method, "\" method has been completed."), - indent = message_indent, - verbose = verbose - ) - } - - invisible(TRUE) -} - - - -compute_variable_importance <- function( - run, - fs_method, - hpo_list, - settings) { - # Function for calculating variable importance - - # Data will be loaded at run time in .vimp. - data <- methods::new("dataObject", - data = NULL, - preprocessing_level = "none", - outcome_type = settings$data$outcome_type, - delay_loading = TRUE, - perturb_level = tail(run$run_table, n = 1)$perturb_level, - load_validation = FALSE, - aggregate_on_load = FALSE, - outcome_info = create_outcome_info(settings = settings)) - - # Load hyperparameters, if any. - parameter_list <- .find_hyperparameters_for_run( - run = run, - hpo_list = hpo_list, - as_list = TRUE) - - # Load feature_info_list - feature_info_list <- .get_feature_info_list(run = run) - - # Create the variable importance method object or familiar model object to - # compute variable importance with. - vimp_object <- methods::new("familiarVimpMethod", - outcome_type = data@outcome_type, - hyperparameters = parameter_list, - vimp_method = fs_method, - outcome_info = .get_outcome_info(), - run_table = run$run_table) - - # Promote to the correct subclass. - vimp_object <- promote_vimp_method(object = vimp_object) - - # Set multivariate methods. - if (is(vimp_object, "familiarModel")) is_multivariate <- TRUE - if (is(vimp_object, "familiarVimpMethod")) is_multivariate <- vimp_object@multivariate - - # Find required features. Exclude the signature features at this point, as - # these will have been dropped from the variable importance table. - required_features <- get_required_features( - x = data, - feature_info_list = feature_info_list, - exclude_signature = !is_multivariate) - - # Limit to required features. - vimp_object@required_features <- required_features - vimp_object@feature_info <- feature_info_list[required_features] - - # Compute variable importance. - vimp_object <- .vimp( - object = vimp_object, - data = data) - - return(vimp_object) -} - - - -.find_missing_feature_selection_data <- function( - project_list, - settings, - file_paths) { - # Suppress NOTES due to non-standard evaluation in data.table - fs_method <- fs_file <- NULL - - # All feature selection methods - file_table <- data.table::data.table("fs_method" = settings$fs$fs_methods) - - # Add expected feature selection file names - file_table[, "fs_file" := .get_feature_selection_data_filename( - project_id = project_list$project_id, - fs_method = fs_method, - file_paths = file_paths)] - - # List files in directory - file_list <- normalizePath( - list.files( - path = file_paths$fs_dir, - pattern = paste0(project_list$project_id, "_fs_"), - full.names = TRUE, - recursive = TRUE), - mustWork = FALSE) - - # Remove files which have already been selected - file_table <- file_table[!fs_file %in% file_list, ] - - return(file_table$fs_method) -} - - - -.get_feature_selection_data_filename <- function( - fs_method, - project_id, - file_paths) { - return(normalizePath( - file.path( - file_paths$fs_dir, - paste0(project_id, "_fs_", fs_method, ".RDS")), - mustWork = FALSE)) -} - - - -.retrieve_feature_selection_data <- function( - fs_method, - project_list, - file_paths) { - # Iterate over the variable importance methods to select the correct files. - vimp_table_list <- lapply( - fs_method, - function(x, project_list, file_paths) { - # Attempt to read the object. This should produce a list of variable - # importance tables. - vimp_table_sub_list <- tryCatch( - readRDS(.get_feature_selection_data_filename( - fs_method = x, - project_id = project_list$project_id, - file_paths = file_paths)), - error = identity) - - # Check if there were issues reading the file. - if (inherits(vimp_table_sub_list, "error")) return(NULL) - - # Iterate over contents of the variable importance table list to update - # these to the latest definitions. - vimp_table_sub_list <- lapply( - vimp_table_sub_list, - function(x, project_id) { - # Upgrade the object for backward compatibility. - if (!is(x, "vimpTable")) x <- as_vimp_table_object(x, project_id = project_id) - - # Update variable importance table objects to the most recent - # definition. - return(update_object(x)) - }, - project_id = project_list$project_id) - - # Return list of vimpTable objects. - return(vimp_table_sub_list) - }, - project_list = project_list, - file_paths = file_paths) - - # Update names - names(vimp_table_list) <- fs_method - - return(vimp_table_list) -} diff --git a/R/FunctionWrapperUtilities.R b/R/FunctionWrapperUtilities.R index e73b5f76..3ff1f49c 100644 --- a/R/FunctionWrapperUtilities.R +++ b/R/FunctionWrapperUtilities.R @@ -2,20 +2,23 @@ do.call_strict <- function( what, args, quote = FALSE, - envir = parent.frame()) { + envir = parent.frame() +) { # Only pass fully matching arguments. Side effect is that ... is always empty. # Use with care in case arguments need to be passed to another function. # Get arguments that can be passed. passable_argument_names <- intersect( names(formals(what)), - names(args)) + names(args) + ) return(do.call( what, args = args[passable_argument_names], quote = quote, - envir = envir)) + envir = envir + )) } @@ -27,7 +30,8 @@ do.call_with_timeout <- function( quote = FALSE, envir = parent.frame(), muffle = TRUE, - additional_packages = NULL) { + additional_packages = NULL +) { # Set up the muffler that captures all output. muffle_fun <- identity @@ -36,29 +40,38 @@ do.call_with_timeout <- function( if (!require_package( "callr", purpose = "to allow for executing functions with timeout", - message_type = "warning")) { + message_type = "warning" + )) { # If callr cannot be loaded, execute the function as is. - muffle_fun(value <- do.call( - what = what, - args = args, - envir = envir)) + muffle_fun( + value <- do.call( + what = what, + args = args, + envir = envir + ) + ) # Return data. return(list( "value" = value, - "timeout" = FALSE)) + "timeout" = FALSE + )) } else if (!is.finite(timeout)) { # If there is no finite timeout, execute the function as is. - muffle_fun(value <- do.call( - what = what, - args = args, - envir = envir)) + muffle_fun( + value <- do.call( + what = what, + args = args, + envir = envir + ) + ) # Return data. return(list( "value" = value, - "timeout" = FALSE)) + "timeout" = FALSE + )) } else { bg_function_wrapper <- function(what, args, additional_packages) { @@ -77,8 +90,10 @@ do.call_with_timeout <- function( args = list( "what" = what, "args" = args, - "additional_packages" = additional_packages), - package = TRUE) + "additional_packages" = additional_packages + ), + package = TRUE + ) # Wait until the timeout, or until the background process completes, # whichever happens first. @@ -105,7 +120,8 @@ do.call_with_handlers_timeout <- function( quote = FALSE, envir = parent.frame(), muffle = TRUE, - additional_packages = NULL) { + additional_packages = NULL +) { # Pass to do.call_with_timeout, which then calls do.call_with_handlers on # "what" with specified arguments "args". results <- do.call_with_timeout( @@ -115,10 +131,12 @@ do.call_with_handlers_timeout <- function( "args" = args, "quote" = quote, "envir" = envir, - "muffle" = muffle), + "muffle" = muffle + ), timeout = timeout, muffle = muffle, - additional_packages = additional_packages) + additional_packages = additional_packages + ) # Flatten results. if (!is.null(results$value)) { @@ -137,7 +155,8 @@ do.call_with_handlers <- function( args, quote = FALSE, envir = parent.frame(), - muffle = TRUE) { + muffle = TRUE +) { # Set up the muffler that captures all output. muffle_fun <- identity if (muffle) muffle_fun <- quiet @@ -146,23 +165,30 @@ do.call_with_handlers <- function( # written after the tryCatch. warn_logs <- error_logs <- NULL - muffle_fun(value <- tryCatch( - withCallingHandlers( - do.call(what = what, args = args, envir = envir), - warning = function(w) { - # Since warn_logs is found in the enclosing frame, we either have to use - # <<- to access and update this variable. However, this causes CRAN - # notes, because <<- can be a global assignment, i.e. in the user space. - # Hence we explicitly use get and assign to update the variable. - warn_logs <- assign( - "warn_logs", - append(get("warn_logs"), condition_parser(w)), - inherits = TRUE) - - # This prevents any warnings from being generated outside the function. - invokeRestart("muffleWarning") - }), - error = identity)) + muffle_fun( + value <- tryCatch( + withCallingHandlers( + do.call(what = what, args = args, envir = envir), + warning = function(w) { + # Since warn_logs is found in the enclosing frame, we either have to + # use <<- to access and update this variable. However, this causes + # CRAN notes, because <<- can be a global assignment, i.e. in the user + # space. Hence we explicitly use get and assign to update the + # variable. + warn_logs <- assign( + "warn_logs", + append(get("warn_logs"), condition_parser(w)), + inherits = TRUE + ) + + # This prevents any warnings from being generated outside the + # function. + invokeRestart("muffleWarning") + } + ), + error = identity + ) + ) if (inherits(value, "error")) { error_logs <- condition_parser(value) @@ -172,7 +198,60 @@ do.call_with_handlers <- function( return(list( "value" = value, "warning" = warn_logs, - "error" = error_logs)) + "error" = error_logs + )) +} + + + +do.call_external <- function( + what, + args, + additional_packages = NULL +) { + + bg_function_wrapper <- function( + what, + args, + additional_packages + ) { + if (!is.null(bg_function_wrapper)) { + for (package in additional_packages) { + requireNamespace(package) + } + } + + do.call( + what = what, + args = args + ) + } + + # Launch as background. + bg_process <- callr::r_bg( + func = bg_function_wrapper, + args = list( + "what" = what, + "args" = args, + "additional_packages" = additional_packages + ), + package = TRUE + ) + + # Wait until the background process completes. + bg_process$wait() + + # Check if the external process crashed. + if (bg_process$get_exit_status() == 0L) { + # If TRUE, results can be read. + results <- bg_process$get_result() + + } else { + # If FALSE, the external process disconnected. + results <- list("error" = paste0("External process was lost with exit status", bg_process$get_exit_status())) + } + + return(results) } @@ -188,7 +267,7 @@ condition_parser <- function(x, ...) { if (!is.null(condition_call)) { # Get the condition call. Also, just in case, select only the first section # that contains the function itself. - deparsed_condition_call <- deparse1(condition_call)[1] + deparsed_condition_call <- deparse1(condition_call)[1L] # We remove the function arguments from the call to prevent leaking data, if # any. Identify the first parenthesis that opens the argument section. @@ -196,14 +275,16 @@ condition_parser <- function(x, ...) { text = deparsed_condition_call, pattern = "(", fixed = TRUE - )[1] + )[1L] # Check if a parenthesis appears in the initial section of the call. - if (parenthesis_position > -1) { + if (parenthesis_position > -1L) { # Select the function name which appears prior to the parenthesis. - deparsed_condition_call <- substr(deparsed_condition_call, + deparsed_condition_call <- substr( + deparsed_condition_call, start = 1L, - stop = parenthesis_position - 1L) + stop = parenthesis_position - 1L + ) } else { # If no parenthesis appears, the function call was likely cut off prior to @@ -211,11 +292,12 @@ condition_parser <- function(x, ...) { deparsed_condition_call <- paste0(deparsed_condition_call, "[...]") } - if (nchar(deparsed_condition_call) > 0) { + if (nchar(deparsed_condition_call) > 0L) { # Add in the deparsed condition call, and combine. parsed_condition <- paste0( deparsed_condition_call, ": ", - condition_message) + condition_message + ) } else { parsed_condition <- condition_message @@ -247,7 +329,7 @@ condition_summary <- function(x) { # Show the number of times the condition has appeared, but ignore if it # only appeared once. - if (x$n > 1) { + if (x$n > 1L) { message_string <- c(message_string, paste0("(", x$n, "x) ")) } @@ -256,7 +338,8 @@ condition_summary <- function(x) { return(paste0(message_string, collapse = "")) }, - USE.NAMES = FALSE) + USE.NAMES = FALSE + ) return(unname(summary_vector)) } diff --git a/R/HyperparameterOptimisation.R b/R/HyperparameterOptimisation.R index 3e1f77aa..b221193c 100644 --- a/R/HyperparameterOptimisation.R +++ b/R/HyperparameterOptimisation.R @@ -13,7 +13,8 @@ run_hyperparameter_optimisation <- function( vimp_method, learner = NULL, message_indent = 0L, - verbose = TRUE) { + verbose = TRUE +) { # Hyper-parameters are parameters of a learner, such as the signature size or # the number of trees in a random forest. The selection of hyper-parameters # influences predictive performance of a model, often to a large extent. @@ -53,50 +54,58 @@ run_hyperparameter_optimisation <- function( # # If not provided by the user, hyper-parameters and corresponding meta-data # are sourced from the learner. - - # In absence of a learner, we assume that feature selection is performed. + + # In absence of a learner, we assume that variable importance is computed. is_vimp <- is.null(learner) - + if (is.null(project_list)) project_list <- get_project_list() if (is.null(settings)) settings <- get_settings() if (is.null(file_paths)) file_paths <- get_file_paths() - - # Get the iteration list for the feature selection or model development step - # for which hyperparameter optimisation is performed. + + # Get the iteration list for the variable importance computation or model + # development step for which hyperparameter optimisation is performed. hpo_id_list <- .get_preprocessing_iteration_identifiers(run = .get_run_list( iteration_list = project_list$iter_list, data_id = data_id, - run_id = 1L)) - + run_id = 1L + )) + iteration_list <- .get_run_list( iteration_list = project_list$iter_list, - data_id = hpo_id_list$data) - + data_id = hpo_id_list$data + ) + # Generate objects for hyperparameter optimisation. - object_list <- lapply(iteration_list, + object_list <- lapply( + iteration_list, .create_hyperparameter_optimisation_initial_objects, vimp_method = vimp_method, learner = learner, settings = settings, - project_id = project_list$project_id) - + project_id = project_list$project_id + ) + # Replace objects that already exist as a file. - object_list <- lapply(object_list, + object_list <- lapply( + object_list, .collect_hyperparameter_optimisation_completed_objects, vimp_method = vimp_method, learner = learner, - file_paths = file_paths) - + file_paths = file_paths + ) + # Check which objects have already been created. - object_exist <- sapply(object_list, + object_exist <- sapply( + object_list, .exists_hyperparameter_optimisation_object, vimp_method = vimp_method, learner = learner, - file_paths = file_paths) - + file_paths = file_paths + ) + # Return objects as is in case they already exist. if (all(object_exist)) return(object_list) - + # Determine how parallel processing takes place. if (settings$hpo$do_parallel %in% c("TRUE", "inner")) { cl_inner <- cl @@ -105,49 +114,57 @@ run_hyperparameter_optimisation <- function( } else if (settings$hpo$do_parallel %in% c("outer")) { cl_inner <- NULL cl_outer <- cl - + if (!is.null(cl_outer)) { logger_message( paste0( "Hyperparameter optimisation: Load-balanced parallel processing ", - "is done in the outer loop. No progress can be displayed."), + "is done in the outer loop. No progress can be displayed." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } } else { cl_inner <- cl_outer <- NULL } - + # Message start of hyperparameter optimisation. if (is_vimp) { logger_message( paste0( "Hyperparameter optimisation: Starting parameter optimisation for the ", - vimp_method, " variable importance method."), + vimp_method, " variable importance method." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else { logger_message( paste0( "Hyperparameter optimisation: Starting parameter optimisation for the ", learner, " learner, based on variable importances from the ", - vimp_method, " variable importance method."), + vimp_method, " variable importance method." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } - + # Generate experiment info experiment_info <- lapply( which(!object_exist), function(ii, n_total) { return(list( "experiment_id" = ii, - "n_experiment_total" = n_total)) + "n_experiment_total" = n_total + )) }, - n_total = length(object_exist)) - + n_total = length(object_exist) + ) + # Pass to fam_mapply_lb to allow for passing cluster objects to the # optimise_hyperparameters method. new_object_list <- fam_mapply_lb( @@ -182,20 +199,24 @@ run_hyperparameter_optimisation <- function( "verbose" = verbose, "message_indent" = message_indent + 1L, "save_in_place" = TRUE, - "is_vimp" = is.null(learner))) - + "is_vimp" = is.null(learner) + ) + ) + # Fill in object list. object_list[!object_exist] <- new_object_list - + # Message completion of hyperparameter optimisation. if (is_vimp) { logger_message("", verbose = verbose) logger_message( paste0( "Hyperparameter optimisation: Completed parameter optimisation for the ", - vimp_method, " variable importance method."), + vimp_method, " variable importance method." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else { logger_message("", verbose = verbose) @@ -203,11 +224,13 @@ run_hyperparameter_optimisation <- function( paste0( "Hyperparameter optimisation: Completed parameter optimisation for the ", learner, " learner, based on variable importances from the ", - vimp_method, " variable importance method."), + vimp_method, " variable importance method." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } - + # Return the object which contains the (optimised) hyperparameters. return(object_list) } @@ -219,13 +242,15 @@ setMethod( "optimise_hyperparameters", signature( object = "ANY", - data = "NULL"), + data = "NULL" + ), function( object, data, ..., save_in_place = FALSE, - is_vimp = NULL) { + is_vimp = NULL + ) { # Create dataset on the fly. This is the usual route for # summon_familiar. data <- methods::new( @@ -234,45 +259,51 @@ setMethod( preprocessing_level = "none", outcome_type = object@outcome_type, delay_loading = TRUE, - perturb_level = tail(object@run_table, n = 1)$perturb_level, + perturb_level = tail(object@run_table, n = 1L)$perturb_level, load_validation = FALSE, aggregate_on_load = FALSE, - outcome_info = object@outcome_info) - + outcome_info = object@outcome_info + ) + # Make sure the input data is processed. data <- process_input_data( object = object, data = data ) - + # Check that any data is present. if (is_empty(data)) return(object) - + # Call proper routine. new_object <- do.call( optimise_hyperparameters, args = c( list( "object" = object, - "data" = data), - list(...))) + "data" = data + ), + list(...) + ) + ) # Check if the code is called downstream from summon_familiar. is_main_process <- !inherits(tryCatch(get_file_paths(), error = identity), "error") - + # Save object. if (save_in_place && is_main_process) { .create_hyperparameter_optimisation_directory( object = new_object, - is_vimp = is_vimp) - + is_vimp = is_vimp + ) + file_path <- .get_hyperparameter_optimisation_object_path( object = new_object, - is_vimp = is_vimp) - + is_vimp = is_vimp + ) + saveRDS(new_object, file = file_path) } - + return(new_object) } ) @@ -284,20 +315,23 @@ setMethod( "optimise_hyperparameters", signature( object = "familiarNoveltyDetector", - data = "dataObject"), + data = "dataObject" + ), function( object, data, user_list = NULL, - ...) { + ... + ) { # Obtain standard parameters. parameter_list <- get_default_hyperparameters( object = object, - data = data) - + data = data + ) + # Check that any parameters are present. if (is_empty(parameter_list)) return(object) - + # Set the user_list if it is not present, or set through hyperparameter # attribute. if (is.null(user_list) && is.null(object@hyperparameters)) { @@ -305,31 +339,35 @@ setMethod( } else if (is.null(user_list) && !is.null(object@hyperparameters)) { user_list <- object@hyperparameters } - + # Recreate the default parameter list with information from the # user-provided list, if any. This allows for changing some hyperparameter # settings that depend on other hyperparameters. parameter_list <- get_default_hyperparameters( object = object, data = data, - user_list = user_list) - + user_list = user_list + ) + # Update the parameter list With user-defined variables. parameter_list <- .update_hyperparameters( parameter_list = parameter_list, - user_list = user_list) - + user_list = user_list + ) + if (.any_randomised_hyperparameters(parameter_list = parameter_list)) { ..error_reached_unreachable_code(paste0( "optimise_hyperparameters,familiarNoveltyDetector,dataObject: ", - "unset hyperparameters are present, but not expected.")) + "unset hyperparameters are present, but not expected." + )) } - + # Update hyperparameters to set any fixed parameters. object@hyperparameters <- lapply( parameter_list, - function(list_entry) list_entry$init_config) - + function(list_entry) list_entry$init_config + ) + return(object) } ) @@ -341,20 +379,26 @@ setMethod( "optimise_hyperparameters", signature( object = "familiarVimpMethod", - data = "dataObject"), + data = "dataObject" + ), function( object, data, user_list = NULL, - ...) { + ... + ) { # Obtain standard parameters. parameter_list <- get_default_hyperparameters( object = object, - data = data) - + data = data + ) + # Check that any parameters are present. - if (is_empty(parameter_list)) return(object) - + if (is_empty(parameter_list)) { + object@hyperparameters <- list() + return(object) + } + # Set the user_list if it is not present, or set through hyperparameter # attribute. if (is.null(user_list) && is.null(object@hyperparameters)) { @@ -362,35 +406,39 @@ setMethod( } else if (is.null(user_list) && !is.null(object@hyperparameters)) { user_list <- object@hyperparameters } - - # Set the signature size. This parameter may not be used by all feature - # selection methods, and will be ignored in that case. + + # Set the signature size. This parameter may not be used by all variable + # importance methods, and will be ignored in that case. user_list$sign_size <- get_n_features(x = data) - + # Recreate the default parameter list with information from the # user-provided list, if any. This allows for changing some hyperparameter # settings that depend on other hyperparameters. parameter_list <- get_default_hyperparameters( object = object, data = data, - user_list = user_list) - + user_list = user_list + ) + # Update the parameter list With user-defined variables. parameter_list <- .update_hyperparameters( parameter_list = parameter_list, - user_list = user_list) - + user_list = user_list + ) + if (.any_randomised_hyperparameters(parameter_list = parameter_list)) { ..error_reached_unreachable_code(paste0( "optimise_hyperparameters,familiarVimpMethod,dataObject: ", - "unset hyperparameters are present, but not expected.")) + "unset hyperparameters are present, but not expected." + )) } - + # Update hyperparameters to set any fixed parameters. object@hyperparameters <- lapply( parameter_list, - function(list_entry) list_entry$init_config) - + function(list_entry) list_entry$init_config + ) + return(object) } ) @@ -401,7 +449,8 @@ setMethod( "optimise_hyperparameters", signature( object = "familiarModel", - data = "dataObject"), + data = "dataObject" + ), function( object, data, @@ -414,7 +463,6 @@ setMethod( grid_initialisation_method = "fixed_subsample", exploration_method = "successive_halving", n_random_sets = 100L, - determine_vimp = TRUE, measure_time = TRUE, hyperparameter_learner = "gaussian_process", n_max_bootstraps = 20L, @@ -425,12 +473,13 @@ setMethod( n_challengers = 20L, intensify_stop_p_value = 0.05, convergence_tolerance = NULL, - convergence_stopping = 3, - no_decent_model_stopping = 4, + convergence_stopping = 3L, + no_decent_model_stopping = 4L, time_limit = NULL, verbose = TRUE, message_indent = 0L, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table param_id <- NULL @@ -440,57 +489,63 @@ setMethod( paste0( "Starting hyperparameter optimisation for data subsample ", experiment_info$experiment_id, " of ", - experiment_info$n_experiment_total, "."), + experiment_info$n_experiment_total, "." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } - + # Set default metric if (is.waive(metric)) metric <- .get_default_metric(outcome_type = object@outcome_type) - + # Set convergence tolerance, if it has not been set. if (is.null(convergence_tolerance)) { # Get the number of samples. n_samples <- get_n_samples(data, "series") - + # Nothing to do if there are no samples. - if (n_samples == 0) return(object) - + if (n_samples == 0L) return(object) + # Set convergence tolerance. convergence_tolerance <- 0.1 * 1.0 / sqrt(n_samples) - + # Limit to -4 if (convergence_tolerance < 1E-4) convergence_tolerance <- 1E-4 } - + # Check if the metric is ok. Packed into a for loop to enable multi-metric # optimisation. sapply(metric, .check_metric_outcome_type, outcome_type = object@outcome_type) - + # Check if acquisition_function is correctly specified. .check_parameter_value_is_valid( x = acquisition_function, var_name = "acquisition_function", - values = .get_available_acquisition_functions()) - + values = .get_available_acquisition_functions() + ) + # Check if hyperparameter learner is correctly specified. .check_parameter_value_is_valid( x = hyperparameter_learner, var_name = "hyperparameter_learner", - values = .get_available_hyperparameter_learners()) - + values = .get_available_hyperparameter_learners() + ) + # Check if optimisation_function is correctly specified. .check_parameter_value_is_valid( x = optimisation_function, var_name = "optimisation_function", - values = .get_available_optimisation_functions(hyperparameter_learner = hyperparameter_learner)) - + values = .get_available_optimisation_functions(hyperparameter_learner = hyperparameter_learner) + ) + # Check if exploration_method is correctly specified. .check_parameter_value_is_valid( x = exploration_method, var_name = "exploration_method", - values = .get_available_hyperparameter_exploration_methods()) - + values = .get_available_hyperparameter_exploration_methods() + ) + # Report on methodology used. optimisation_description <- switch( optimisation_function, @@ -498,78 +553,98 @@ setMethod( "validation" = "maximising out-of-bag performance", "balanced" = paste0( "maximising out-of-bag performance while constraining performance ", - "differences between in-bag and out-of-bag data"), + "differences between in-bag and out-of-bag data" + ), "stronger_balance" = paste0( "maximising out-of-bag performance while strongly constraining ", - "performance differences between in-bag and out-of-bag data"), + "performance differences between in-bag and out-of-bag data" + ), "validation_minus_sd" = paste0( "maximising out-of-bag performance while penalising variance ", - "using the lower 1 standard deviation bound"), + "using the lower 1 standard deviation bound" + ), "validation_25th_percentile" = paste0( "maximising out-of-bag performance while penalising variance ", - "using the 25th percentile bound"), + "using the 25th percentile bound" + ), "model_estimate" = "maximising performance estimates from the hyperparameter model", "model_estimate_minus_sd" = paste0( "maximising performances estimates while penalising variance ", - "estimated by the model"), + "estimated by the model" + ), "model_balanced_estimate" = paste0( "maximising performance under estimates of the performance differences ", - "between in-bag and out-of-bag data"), + "between in-bag and out-of-bag data" + ), "model_balanced_estimate_minus_sd" = paste0( "maximising performance under estimates of the performance differences ", "between in-bag and out-of-bag data while penalising ", - "estimated variance in performance differences")) - + "estimated variance in performance differences" + ) + ) + logger_message( paste0( "Hyperparameter optimisation is conducted using the ", - paste_s(metric), ifelse(length(metric) > 1, " metrics", " metric"), - " by ", optimisation_description, "."), + paste_s(metric), ifelse(length(metric) > 1L, " metrics", " metric"), + " by ", optimisation_description, "." + ), indent = message_indent + 1L, - verbose = verbose) - + verbose = verbose + ) + inference_description <- switch( hyperparameter_learner, "random_forest" = "selected after inferring utility using a Random Forest", "gaussian_process" = paste0( "selected after inferring utility using a ", - "localised approximate Gaussian Process"), + "localised approximate Gaussian Process" + ), "bayesian_additive_regression_trees" = paste0( "selected after inferring utility using ", - "Bayesian Additive Regression Trees"), + "Bayesian Additive Regression Trees" + ), "bart" = paste0( "selected after inferring utility using ", - "Bayesian Additive Regression Trees"), + "Bayesian Additive Regression Trees" + ), "random" = "drawn randomly", - "random_search" = "drawn randomly") - + "random_search" = "drawn randomly" + ) + logger_message( paste0( "Candidate hyperparameter sets after the initial run are ", - inference_description, "."), + inference_description, "." + ), indent = message_indent + 1L, - verbose = verbose) - + verbose = verbose + ) + if (!hyperparameter_learner %in% c("random", "random_search")) { utility_description <- switch( acquisition_function, "improvement_probability" = paste0( - "probability of improvement over the best known hyperparameter set"), + "probability of improvement over the best known hyperparameter set" + ), "improvement_empirical_probability" = paste0( "empirical probability of improvement over ", - "the best known hyperparameter set"), + "the best known hyperparameter set" + ), "expected_improvement" = "expected improvement", "upper_confidence_bound" = "the upper regret bound", - "bayes_upper_confidence_bound" = "the Bayesian upper confidence bound") - + "bayes_upper_confidence_bound" = "the Bayesian upper confidence bound" + ) + logger_message( paste0("Utility is measured as ", utility_description, "."), indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) } - + ## Create and update hyperparameter sets ----------------------------------- - + # Set the user_list if it is not present, or set through hyperparameter # attribute. if (is.null(user_list) && is.null(object@hyperparameters)) { @@ -577,73 +652,86 @@ setMethod( } else if (is.null(user_list) && !is.null(object@hyperparameters)) { user_list <- object@hyperparameters } - + # Create the default parameter list with information from the user-provided # list, if any. This allows for changing some hyperparameter settings that # depend on other hyperparameters. parameter_list <- get_default_hyperparameters( object = object, data = data, - user_list = user_list) - + user_list = user_list + ) + # Check that any parameters are present. if (is_empty(parameter_list)) return(object) - + # Update the parameter list With user-defined variables. parameter_list <- .update_hyperparameters( parameter_list = parameter_list, user_list = user_list, n_features = ifelse( - object@fs_method %in% .get_available_no_features_vimp_methods(), - 0L, get_n_features(data))) - + object@vimp_method %in% .get_available_no_features_vimp_methods(), + 0L, + get_n_features(data) + ) + ) + # Check that any parameters can be randomised. if (!.any_randomised_hyperparameters(parameter_list = parameter_list)) { # Update hyperparameters to set any fixed parameters. object@hyperparameters <- lapply( parameter_list, - function(list_entry) list_entry$init_config) - + function(list_entry) list_entry$init_config + ) + logger_message( paste0( "Hyperparameter optimisation: All hyperparameters are fixed. ", - "No optimisation is required."), + "No optimisation is required." + ), indent = message_indent, - verbose = verbose) - - return(object) + verbose = verbose + ) + + # Only exit if variable importance is not required. + if (!is_empty(object@vimp_table)) { + return(object) + } } - + ## Create bootstrap samples ------------------------------------------------ - + # Generate bootstrap samples bootstraps <- tryCatch( .create_bootstraps( n_iter = n_max_bootstraps, outcome_type = object@outcome_type, - data = data@data), - error = identity) - + data = data@data + ), + error = identity + ) + # Check that bootstraps could be created. This may fail if the data set is # too small. if (inherits(bootstraps, "error")) { logger_message( paste0( "Hyperparameter optimisation: Failed to create bootstraps. ", - "The dataset may be too small."), + "The dataset may be too small." + ), indent = message_indent, - verbose = verbose) - + verbose = verbose + ) + # Remove any fixed hyperparameters. object@hyperparameters <- NULL - + return(object) } - + ## Create or obtain variable importance ------------------------------------ - rank_table_list <- .compute_hyperparameter_variable_importance( + vimp_table_list <- .compute_hyperparameter_variable_importance( cl = cl, - determine_vimp = determine_vimp, object = object, data = data, bootstraps = bootstraps$train_list, @@ -662,8 +750,18 @@ setMethod( convergence_stopping = min(c(convergence_stopping, 3L)), time_limit = time_limit, verbose = verbose, - message_indent = message_indent) - + message_indent = message_indent + ) + + # Attach variable importance tables. + object@vimp_table <- vimp_table_list + + # Break if there is nothing to optimise, This continues the earlier check, + # but after setting the variable importance table. + if (!.any_randomised_hyperparameters(parameter_list = parameter_list)) { + return(object) + } + ## Set signature size ------------------------------------------------------ # Signature size depends on the variable importance method that is used. @@ -671,83 +769,94 @@ setMethod( # Set signature size. user_list$sign_size <- .set_signature_size( object = object, - rank_table_list = rank_table_list, - suggested_range = user_list$sign_size) + vimp_table_list = vimp_table_list, + suggested_range = user_list$sign_size + ) # Update the parameter list With user-defined variables. parameter_list <- .update_hyperparameters( parameter_list = parameter_list, user_list = user_list, - n_features = get_n_features(data)) - + n_features = get_n_features(data) + ) + # Check that any parameters can be randomised. if (!.any_randomised_hyperparameters(parameter_list = parameter_list)) { # Update hyperparameters to set any fixed parameters. object@hyperparameters <- lapply( parameter_list, - function(list_entry) list_entry$init_config) - + function(list_entry) list_entry$init_config + ) + logger_message( paste0( "Hyperparameter optimisation: All hyperparameters are fixed. ", - "No optimisation is required."), + "No optimisation is required." + ), indent = message_indent, - verbose = verbose) - + verbose = verbose + ) + return(object) } } - + ## Create metric objects --------------------------------------------------- - + # Update the outcome_info attribute of the familiar model. This is required # to set the metric baseline value. object@outcome_info <- .compute_outcome_distribution_data( object = object@outcome_info, - data = data) - + data = data + ) + # Create metric objects. metric_object_list <- lapply( metric, as_metric, - object = object) + outcome_type = object@outcome_type + ) # Add baseline values for each metric. metric_object_list <- lapply( metric_object_list, set_metric_baseline_value, object = object, - data = data) - + data = data + ) + ## Create initial set of randomised hyperparameters and bootstraps --------- - + # Update the parameter list to make sure that categorical variables # are encoded as factors. parameter_list <- .encode_categorical_hyperparameters(parameter_list) - + # Create initial set of configurations. parameter_table <- ..create_initial_hyperparameter_set( parameter_list = parameter_list, grid_initialisation_method = grid_initialisation_method, - n_random_sets = n_random_sets) - + n_random_sets = n_random_sets + ) + # Check that the parameter table is not empty. if (is_empty(parameter_table)) { logger_message( paste0( "Hyperparameter optimisation: No hyperparameters were found ", - "to initialise the optimisation process."), + "to initialise the optimisation process." + ), indent = message_indent, - verbose = verbose) - + verbose = verbose + ) + # Remove any fixed hyperparameters. object@hyperparameters <- NULL - + return(object) } - + ## Setup the hyperparameter model prototype -------------------------------- - + # Set up the model prototype. optimisation_model_prototype <- methods::new( "familiarHyperparameterLearner", @@ -755,18 +864,19 @@ setMethod( target_learner = object@learner, target_outcome_type = object@outcome_type, optimisation_metric = metric, - optimisation_function = optimisation_function) - + optimisation_function = optimisation_function + ) + ## Perform initial set of computations ------------------------------------- - + # Initialise the process clock. process_clock <- NULL if (!is.null(time_limit)) { if (require_package( c("callr", "microbenchmark"), purpose = "to measure hyperparameter optimisation time", - message_type = "warning")) { - + message_type = "warning" + )) { process_clock <- ProcessClock$new() on.exit(process_clock$close(), add = TRUE) @@ -776,22 +886,24 @@ setMethod( time_limit <- NULL } } - + if (measure_time & n_initial_bootstraps > 1L) { # Start with an initial run to measure performance and time. run_table <- ..create_hyperparameter_run_table( run_ids = 1L, - parameter_ids = parameter_table$param_id) - + parameter_ids = parameter_table$param_id + ) + # Message begin. logger_message( paste0( "Compute initial model performance based on ", - nrow(run_table), " hyperparameter sets."), + nrow(run_table), " hyperparameter sets." + ), indent = message_indent + 1L, verbose = verbose ) - + # Build and evaluate models. This creates a table with metric values, # objective scores for in-bag and out-of-bag data. score_results <- .compute_hyperparameter_model_performance( @@ -800,22 +912,24 @@ setMethod( run_table = run_table, bootstraps = bootstraps, data = data, - rank_table_list = rank_table_list, + vimp_table_list = vimp_table_list, parameter_table = parameter_table, metric_objects = metric_object_list, iteration_id = 0L, - verbose = verbose) - + verbose = verbose + ) + # Get score table. score_table <- score_results$results - + # Get errors encountered during model training. train_errors <- score_results$error - + if (.optimisation_process_time_available( process_clock = process_clock, time_limit = time_limit, - verbose = FALSE)) { + verbose = FALSE + )) { # Set up the runs for the remaining initial computations. run_table <- ..create_hyperparameter_run_table( @@ -824,22 +938,26 @@ setMethod( score_table = score_table, parameter_table = parameter_table, optimisation_model = optimisation_model_prototype, - n_max_bootstraps = n_max_bootstraps) - + n_max_bootstraps = n_max_bootstraps + ) + logger_message( paste0( "Compute initial model performance based on the second batch of ", - nrow(run_table), " hyperparameter sets."), + nrow(run_table), " hyperparameter sets." + ), indent = message_indent + 1L, - verbose = verbose) - + verbose = verbose + ) + # Create a model to predict the time a process takes to complete # training. time_optimisation_model <- .create_hyperparameter_time_optimisation_model( score_table = score_table, parameter_table = parameter_table, - optimisation_function = optimisation_function) - + optimisation_function = optimisation_function + ) + # Compute second batch of results. score_results <- .compute_hyperparameter_model_performance( cl = cl, @@ -847,19 +965,22 @@ setMethod( run_table = run_table, bootstraps = bootstraps, data = data, - rank_table_list = rank_table_list, + vimp_table_list = vimp_table_list, parameter_table = parameter_table, metric_objects = metric_object_list, iteration_id = 0L, time_optimisation_model = time_optimisation_model, overhead_time = score_results$overhead_time, - verbose = verbose) - + verbose = verbose + ) + # Add new data to score and optimisation tables. - score_table <- rbind(score_table, + score_table <- rbind( + score_table, score_results$results, - use.names = TRUE) - + use.names = TRUE + ) + # Add errors encountered during model training. train_errors <- c(train_errors, score_results$error) } @@ -870,14 +991,16 @@ setMethod( run_ids = seq_len(n_initial_bootstraps), parameter_ids = parameter_table$param_id ) - + logger_message( paste0( "Compute initial model performance based on ", - nrow(run_table), " hyperparameter sets."), + nrow(run_table), " hyperparameter sets." + ), indent = message_indent + 1L, - verbose = verbose) - + verbose = verbose + ) + # Build and evaluate models. This creates a table with metric values, # objective scores for in-bag and out-of-bag data. score_results <- .compute_hyperparameter_model_performance( @@ -886,19 +1009,20 @@ setMethod( run_table = run_table, bootstraps = bootstraps, data = data, - rank_table_list = rank_table_list, + vimp_table_list = vimp_table_list, parameter_table = parameter_table, iteration_id = 0L, metric_objects = metric_object_list, - verbose = verbose) - + verbose = verbose + ) + # Get score table. score_table <- score_results$results - + # Get errors encountered during model training. train_errors <- score_results$error } - + # Find information regarding the dataset that has the highest optimisation # score. incumbent_set <- get_best_hyperparameter_set( @@ -906,8 +1030,9 @@ setMethod( parameter_table = parameter_table, optimisation_model = optimisation_model_prototype, n_max_bootstraps = n_max_bootstraps, - n = 1L) - + n = 1L + ) + # Message the user concerning the initial optimisation score. logger_message( paste0( @@ -915,13 +1040,16 @@ setMethod( ..parse_optimisation_summary_to_string( parameter_set = incumbent_set, parameter_table = parameter_table, - parameter_list = parameter_list)), + parameter_list = parameter_list + ) + ), indent = message_indent + 1L, - verbose = verbose) - + verbose = verbose + ) + # Check whether any combination yielded anything valid. skip_optimisation <- incumbent_set$summary_score <= ..get_replacement_optimisation_score() - + # Update n_intensify_step_bootstraps and n_max_intensify_steps when # exploration_method equals none. There is no reason to perform steps # sequentially as there is no pruning. @@ -932,13 +1060,14 @@ setMethod( n_max_intensify_steps <- 1L n_intensify_step_bootstraps <- 1L } - + # Create list with stopping criteria based on initial runs. stop_list <- ..update_hyperparameter_optimisation_stopping_criteria( set_data = incumbent_set, stop_data = NULL, - tolerance = convergence_tolerance) - + tolerance = convergence_tolerance + ) + optimisation_step <- 0L while (optimisation_step < n_max_optimisation_steps && !skip_optimisation) { # Stop optimisation if there is no time left. This is an initial check @@ -947,18 +1076,20 @@ setMethod( if (!.optimisation_process_time_available( process_clock = process_clock, time_limit = time_limit, - verbose = FALSE)) { + verbose = FALSE + )) { break } - + ## SMBO - Intensify ------------------------------------------------------ - + # Create a model to predict the time a process takes to complete training. time_optimisation_model <- .create_hyperparameter_time_optimisation_model( score_table = score_table, parameter_table = parameter_table, - optimisation_function = optimisation_function) - + optimisation_function = optimisation_function + ) + # Local neighbourhood + random hyperparameter randomisation for challenger # configurations. This selects challengers combinations. challenger_data <- .create_hyperparameter_challenger_sets( @@ -971,30 +1102,32 @@ setMethod( n_max_bootstraps = n_max_bootstraps, smbo_iter = optimisation_step, measure_time = measure_time, - n_challengers = n_challengers) - + n_challengers = n_challengers + ) + # Check that any challenger datasets were found. if (is_empty(challenger_data)) break - + # Add challenger parameters to the parameter table parameter_table <- rbind( parameter_table, challenger_data, - use.names = TRUE) + use.names = TRUE + ) # Select only unique parameters parameter_table <- unique(parameter_table, by = "param_id") - + # Determine parameter ids from incumbent and challenger parameter_id_incumbent <- incumbent_set$param_id parameter_id_challenger <- challenger_data$param_id - + # Drop incumbent parameter id from the list of challengers parameter_id_challenger <- setdiff(parameter_id_challenger, parameter_id_incumbent) - + # Check if there are any challengers left - if (length(parameter_id_challenger) == 0) break - + if (length(parameter_id_challenger) == 0L) break + # Start intensification rounds n_intensify_steps <- 0L while (n_intensify_steps < n_max_intensify_steps) { @@ -1002,10 +1135,11 @@ setMethod( if (!.optimisation_process_time_available( process_clock = process_clock, time_limit = time_limit, - verbose = FALSE)) { + verbose = FALSE + )) { break } - + # Create run table. run_table <- ..create_hyperparameter_intensify_run_table( parameter_id_incumbent = parameter_id_incumbent, @@ -1013,19 +1147,22 @@ setMethod( score_table = score_table, n_max_bootstraps = n_max_bootstraps, n_intensify_step_bootstraps = n_intensify_step_bootstraps, - exploration_method = exploration_method) - + exploration_method = exploration_method + ) + # Check if there are any runs to perform. if (is_empty(run_table)) break - + # Message the user. logger_message( paste0( "Intensify step ", n_intensify_steps + 1L, " using ", - length(parameter_id_challenger), " challenger hyperparameter sets."), + length(parameter_id_challenger), " challenger hyperparameter sets." + ), indent = message_indent + 1L, - verbose = verbose) - + verbose = verbose + ) + # Compute metric values for the bootstraps of the incumbent and # challenger parameter sets. score_results <- .compute_hyperparameter_model_performance( @@ -1034,23 +1171,25 @@ setMethod( run_table = run_table, bootstraps = bootstraps, data = data, - rank_table_list = rank_table_list, + vimp_table_list = vimp_table_list, parameter_table = parameter_table, metric_objects = metric_object_list, iteration_id = optimisation_step + 1L, time_optimisation_model = time_optimisation_model, overhead_time = score_results$overhead_time, - verbose = verbose) - + verbose = verbose + ) + # Get score table. Add new data to score and optimisation tables. score_table <- rbind( score_table, score_results$results, - use.names = TRUE) + use.names = TRUE + ) # Add errors encountered during model training. train_errors <- c(train_errors, score_results$error) - + # Find scores and return parameter ids for challenger and incumbent # hyperparameter sets. Compared to the original SMAC algorithm, we # actively eliminate unsuccessful challengers. To do so we determine the @@ -1063,43 +1202,47 @@ setMethod( parameter_id_incumbent = parameter_id_incumbent, parameter_id_challenger = parameter_id_challenger, exploration_method = exploration_method, - intensify_stop_p_value = intensify_stop_p_value) - + intensify_stop_p_value = intensify_stop_p_value + ) + # Extract hyperparameter set identifiers. parameter_id_incumbent <- runoff_parameter_ids$parameter_id_incumbent parameter_id_challenger <- runoff_parameter_ids$parameter_id_challenger - + # Check if there are challengers remaining - if (length(parameter_id_challenger) == 0) break - + if (length(parameter_id_challenger) == 0L) break + # Update intensify iterator n_intensify_steps <- n_intensify_steps + 1L - + # Update the model that predicts the time a process takes to complete # training. time_optimisation_model <- .create_hyperparameter_time_optimisation_model( score_table = score_table, parameter_table = parameter_table, - optimisation_function = optimisation_function) + optimisation_function = optimisation_function + ) } - + ## SMBO - Evaluate ------------------------------------------------------- # We assess improvement to provide early stopping on non-improving # incumbents. - + # Get all runs and compute details for the incumbent set. incumbent_set <- get_best_hyperparameter_set( score_table = score_table, parameter_table = parameter_table, optimisation_model = optimisation_model_prototype, - n_max_bootstraps = n_max_bootstraps) - + n_max_bootstraps = n_max_bootstraps + ) + # Update list with stopping criteria stop_list <- ..update_hyperparameter_optimisation_stopping_criteria( set_data = incumbent_set, stop_data = stop_list, - tolerance = convergence_tolerance) - + tolerance = convergence_tolerance + ) + # Message progress. logger_message( paste0( @@ -1107,138 +1250,160 @@ setMethod( ..parse_optimisation_summary_to_string( parameter_set = incumbent_set, parameter_table = parameter_table, - parameter_list = parameter_list)), + parameter_list = parameter_list + ) + ), indent = message_indent + 1L, - verbose = verbose) - + verbose = verbose + ) + # Check time and finish the optimisation process if required. This will # also automatically generate a message if verbose is TRUE. if (!.optimisation_process_time_available( process_clock = process_clock, time_limit = time_limit, message_indent = message_indent, - verbose = verbose)) { + verbose = verbose + )) { break } - + # Break if the convergence counter reaches a certain number - if (stop_list$convergence_counter_score >= convergence_stopping || - stop_list$convergence_counter_parameter_id >= convergence_stopping) { + if ( + stop_list$convergence_counter_score >= convergence_stopping || + stop_list$convergence_counter_parameter_id >= convergence_stopping + ) { # Message convergence logger_message( paste0( "Hyperparameter optimisation: Optimisation stopped early ", - "as convergence was achieved."), + "as convergence was achieved." + ), indent = message_indent, - verbose = verbose) - + verbose = verbose + ) + # Stop SMBO break } - + # Break if no model better than the naive model was found. if (stop_list$no_naive_improvement_counter >= no_decent_model_stopping) { # Message early stopping. logger_message( paste0( "Hyperparameter optimisation: Optimisation stopped early because ", - "no models were found to perform better than naive models."), + "no models were found to perform better than naive models." + ), indent = message_indent, - verbose = verbose) - + verbose = verbose + ) + # Stop SMBO. break } - + # Update main iterator optimisation_step <- optimisation_step + 1L } ## SMBO - Wrap-up and report------------------------------------------------ - + # Get all runs and determine incumbent parameter id. incumbent_set <- get_best_hyperparameter_set( score_table = score_table, parameter_table = parameter_table, optimisation_model = optimisation_model_prototype, - n_max_bootstraps = n_max_bootstraps) - + n_max_bootstraps = n_max_bootstraps + ) + # Add corresponding hyper parameters and remove redundant columns. optimal_set_table <- parameter_table[param_id == incumbent_set$param_id, ] optimal_set_table[, "param_id" := NULL] - + # Check that a suitable set of hyperparameters was found. if (incumbent_set$summary_score <= ..get_replacement_optimisation_score()) { # In this case, no suitable hyperparameters were found, for whatever # reason. - + logger_message( paste0( "Hyperparameter optimisation: No suitable set of ", - "hyperparameters was found."), + "hyperparameters was found." + ), indent = message_indent, - verbose = verbose) - + verbose = verbose + ) + # Report on errors. if (!is.null(train_errors)) { # Generate a summary of the errors. train_errors <- condition_summary(train_errors) - + # Notify that one or more errors were encountered. logger_message( paste0( "Hyperparameter optimisation: The following ", - ifelse(length(train_errors) == 1, "error was", "errors were"), - " encountered while training models:"), + ifelse(length(train_errors) == 1L, "error was", "errors were"), + " encountered while training models:" + ), indent = message_indent, - verbose = verbose) - + verbose = verbose + ) + # Show errors. sapply( train_errors, logger_message, indent = message_indent + 1L, - verbose = verbose) + verbose = verbose + ) } - + # Set NULL. object@hyperparameters <- NULL - } else if (incumbent_set$validation_score < 0.0 && - !object@fs_method %in% c("none", "signature_only")) { + } else if ( + incumbent_set$validation_score < 0.0 && + !object@vimp_method %in% c("none", "signature_only") + ) { # In this case, no set of hyperparameters found that led to a model that # was better than the naive model. We then train a naive model instead, by # forcing sign_size to 0. - + object@hyperparameters <- as.list(optimal_set_table) - object@hyperparameters$sign_size <- 0 - + object@hyperparameters$sign_size <- 0L + logger_message( paste0( "Hyperparameter optimisation: No set of hyperparameters was identified that ", - "leads to a model that performs better than a naive model."), + "leads to a model that performs better than a naive model." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else { # In this case the model trained properly. object@hyperparameters <- as.list(optimal_set_table) - + logger_message( paste0( "Hyperparameter optimisation: A suitable set of hyperparameters was identified: ", ..parse_optimisation_summary_to_string( parameter_set = incumbent_set, parameter_table = parameter_table, - parameter_list = parameter_list) + parameter_list = parameter_list + ) ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } - + time_taken <- NULL if (is(process_clock, "processClock")) time_taken <- process_clock$time(units = "mins") - + # Update attributes of object. object@hyperparameter_data <- list( "score_table" = score_table, @@ -1251,7 +1416,7 @@ setMethod( "n_samples" = get_n_samples(data), "n_features" = get_n_features(data) ) - + return(object) } ) @@ -1263,64 +1428,71 @@ setMethod( vimp_method, learner = NULL, settings, - project_id) { + project_id +) { # Obtain feature information list. feature_info_list <- .get_feature_info_list(run = run) if (is.null(learner)) { # Create the variable importance met hod object or familiar model object to # compute variable importance with. - object <- promote_vimp_method(object = methods::new("familiarVimpMethod", + object <- promote_vimp_method(object = methods::new( + "familiarVimpMethod", outcome_type = settings$data$outcome_type, - hyperparameters = settings$fs$param[[vimp_method]], + hyperparameters = settings$vimp$param[[vimp_method]], vimp_method = vimp_method, outcome_info = .get_outcome_info(), run_table = run$run_table, - project_id = project_id)) - + project_id = project_id + )) + # Set multivariate methods. if (is(object, "familiarModel")) is_multivariate <- TRUE if (is(object, "familiarVimpMethod")) is_multivariate <- object@multivariate - + # Find required features. required_features <- get_required_features( x = feature_info_list, - exclude_signature = !is_multivariate) - + exclude_signature = !is_multivariate + ) + # Limit to required features. In principle, this removes signature features # which are not assessed through variable importance. feature_info_list <- feature_info_list[required_features] - + # Update the object. object@required_features <- required_features object@feature_info <- feature_info_list } else { # Create familiar model object. The following need to be updated: - object <- promote_learner(object = methods::new("familiarModel", + object <- promote_learner(object = methods::new( + "familiarModel", outcome_type = settings$data$outcome_type, hyperparameters = settings$mb$hyper_param[[learner]], learner = learner, - fs_method = vimp_method, + vimp_method = vimp_method, run_table = run$run_table, outcome_info = .get_outcome_info(), settings = settings$eval, - project_id = project_id)) - + project_id = project_id + )) + # Find required features. required_features <- get_required_features( x = feature_info_list, - exclude_signature = FALSE) - + exclude_signature = FALSE + ) + # Limit to required features. In principle, this removes signature features # which are not assessed through variable importance. feature_info_list <- feature_info_list[required_features] - + # Update the object. object@required_features <- required_features object@feature_info <- feature_info_list } - + return(object) } @@ -1329,25 +1501,26 @@ setMethod( .create_hyperparameter_optimisation_directory <- function( object, is_vimp, - file_paths = NULL) { + file_paths = NULL +) { # Set file paths. if (is.null(file_paths)) file_paths <- get_file_paths() - + if (is(object, "familiarVimpMethod")) { vimp_method <- object@vimp_method } else if (is_vimp) { vimp_method <- object@learner } else { - vimp_method <- object@fs_method + vimp_method <- object@vimp_method } - + # Set created hyperparameters. if (is_vimp) { - dir_path <- file.path(file_paths$fs_dir, vimp_method) + dir_path <- file.path(file_paths$vimp_dir, vimp_method) } else { dir_path <- file.path(file_paths$mb_dir, object@learner, vimp_method) } - + # Create directory if it does not exist. if (!dir.exists(dir_path)) dir.create(dir_path, recursive = TRUE) @@ -1360,16 +1533,18 @@ setMethod( object, vimp_method, learner, - file_paths) { + file_paths +) { # Identify file path to object. file_path <- .get_hyperparameter_optimisation_object_path( object = object, is_vimp = is.null(learner), - file_paths = file_paths) - + file_paths = file_paths + ) + if (file.exists(file_path)) object <- readRDS(file_path) - + return(object) } @@ -1379,14 +1554,16 @@ setMethod( object, vimp_method, learner, - file_paths) { + file_paths +) { # Identify file path to object. file_path <- .get_hyperparameter_optimisation_object_path( object = object, is_vimp = is.null(learner), - file_paths = file_paths) - + file_paths = file_paths + ) + return(file.exists(file_path)) } @@ -1395,30 +1572,32 @@ setMethod( .get_hyperparameter_optimisation_object_path <- function( object, is_vimp, - file_paths = NULL) { + file_paths = NULL +) { if (is.null(file_paths)) file_paths <- get_file_paths() - + # Extract data and run id - object_data_id <- tail(object@run_table, n = 1)$data_id - object_run_id <- tail(object@run_table, n = 1)$run_id - + object_data_id <- tail(object@run_table, n = 1L)$data_id + object_run_id <- tail(object@run_table, n = 1L)$run_id + # Get the variable importance method. if (is_vimp && is(object, "familiarVimpMethod")) { vimp_method <- object@vimp_method } else if (is_vimp) { vimp_method <- object@learner } else { - vimp_method <- object@fs_method + vimp_method <- object@vimp_method } - + if (is_vimp) { - dir_path <- file.path(file_paths$fs_dir, vimp_method) + dir_path <- file.path(file_paths$vimp_dir, vimp_method) file_name <- paste0( object@project_id, "_hyperparameters_", vimp_method, "_", object_data_id, "_", - object_run_id, ".RDS") + object_run_id, ".RDS" + ) } else { dir_path <- file.path(file_paths$mb_dir, object@learner, vimp_method) @@ -1427,13 +1606,15 @@ setMethod( object@learner, "_", vimp_method, "_", object_data_id, "_", - object_run_id, ".RDS") + object_run_id, ".RDS" + ) } - + file_path <- normalizePath( file.path(dir_path, file_name), - mustWork = FALSE) - + mustWork = FALSE + ) + return(file_path) } @@ -1443,16 +1624,18 @@ setMethod( run, hpo_list, allow_random_selection = FALSE, - as_list = FALSE) { + as_list = FALSE +) { # Suppress NOTES due to non-standard evaluation in data.table data_id <- run_id <- NULL - + # Identify the right entry on hpo_list. for (ii in rev(run$run_table$perturb_level)) { run_id_list <- .get_iteration_identifiers( run = run, - perturb_level = ii) - + perturb_level = ii + ) + # Check whether there are any matching data and run ids by determining the # number of rows in the table after matching match_hpo <- sapply( @@ -1463,24 +1646,25 @@ setMethod( match_size <- nrow(iter_hpo@run_table[data_id == run_id_list$data & run_id == run_id_list$run]) # Return TRUE if any matching rows are found. - return(match_size > 0) + return(match_size > 0L) }, - run_id_list = run_id_list) - + run_id_list = run_id_list + ) + # If there is a match, we step out of the loop if (any(match_hpo)) break } - + # Extract the table of parameters - if (allow_random_selection && sum(match_hpo) > 1) { - random_set <- sample(which(match_hpo), size = 1) - + if (allow_random_selection && sum(match_hpo) > 1L) { + random_set <- sample(which(match_hpo), size = 1L) + object <- hpo_list[[random_set]] } else { - object <- hpo_list[match_hpo][[1]] + object <- hpo_list[match_hpo][[1L]] } - + if (as_list) { return(object@hyperparameters) } else { diff --git a/R/HyperparameterOptimisationMetaLearners.R b/R/HyperparameterOptimisationMetaLearners.R index 6fb74320..21d8bf9f 100644 --- a/R/HyperparameterOptimisationMetaLearners.R +++ b/R/HyperparameterOptimisationMetaLearners.R @@ -9,21 +9,23 @@ n_challengers = 20L, smbo_iter, measure_time, - random_admixture_fraction = 0.20) { + random_admixture_fraction = 0.20 +) { # Suppress NOTES due to non-standard evaluation in data.table param_id <- expected_train_time <- utility <- summary_score <- weight <- NULL is_observed <- .NATURAL <- i.param_id <- NULL # Set the maximum number of local steps based on the number of randomisable # hyperparameters. - n_max_local_steps <- 2 * sum(sapply(parameter_list, function(x) (x$randomise))) + n_max_local_steps <- 2L * sum(sapply(parameter_list, function(x) (x$randomise))) # Train hyperparameter optimisation model. if (!model_is_trained(score_optimisation_model)) { score_optimisation_model <- .train( object = score_optimisation_model, data = score_table, - parameter_data = parameter_table) + parameter_data = parameter_table + ) } # Find information regarding the dataset that has the highest @@ -33,7 +35,8 @@ parameter_table = parameter_table, optimisation_model = score_optimisation_model, n_max_bootstraps = n_max_bootstraps, - n = 1L) + n = 1L + ) # Generate random sets-------------------------------------------------------- @@ -47,33 +50,39 @@ # Generate random sets random_sets <- lapply( - seq_len(n_random_sets * 10), + seq_len(n_random_sets * 10L), function(ii, parameter_list) { # Create random configuration. return(..randomise_hyperparameter_set( parameter_list = parameter_list, - local = FALSE)) + local = FALSE + )) }, - parameter_list = parameter_list) + parameter_list = parameter_list + ) # Combine random sets into a data.table. random_sets <- unique(data.table::rbindlist(random_sets, use.names = TRUE)) # Compute expected improvement. - if (!is_empty(random_sets) && - !is(score_optimisation_model, "familiarHyperparameterRandomSearch")) { + if ( + !is_empty(random_sets) && + !is(score_optimisation_model, "familiarHyperparameterRandomSearch") + ) { random_sets[, "utility" := .compute_utility_value( parameter_set = .SD, score_model = score_optimisation_model, acquisition_data = incumbent_set, - acquisition_function = acquisition_function)] + acquisition_function = acquisition_function + )] } # Compute expect train time. if (!is_empty(random_sets)) { random_sets[, "expected_train_time" := .compute_expected_train_time( parameter_set = .SD, - time_model = time_optimisation_model)] + time_model = time_optimisation_model + )] } # Identify local sets -------------------------------------------------------- @@ -82,13 +91,16 @@ # Find local sets local_sets <- list() - if (n_local_sets > 0 && - !is(score_optimisation_model, "familiarHyperparameterRandomSearch")) { + if ( + n_local_sets > 0L && + !is(score_optimisation_model, "familiarHyperparameterRandomSearch") + ) { # Create a table of summary scores to identify the best sets. summary_score_table <- .compute_hyperparameter_summary_score( score_table = score_table, parameter_table = parameter_table, - optimisation_model = score_optimisation_model) + optimisation_model = score_optimisation_model + ) # Find the most promising samples by comparing against the median. summary_score_table[, "weight" := summary_score - stats::median(summary_score)] @@ -106,17 +118,19 @@ # Select the hyperparameter ids to sample, starting with the most promising # samples first. summary_score_table <- summary_score_table[, "n_select" := round( - 2.0 * n_local_sets * weight^2 / sum(weight^2))][order(-summary_score)] + 2.0 * n_local_sets * weight^2.0 / sum(weight^2.0) + )][order(-summary_score)] selected_best_parameter_id <- unlist(mapply( function(x, n) (rep(x, times = n)), x = summary_score_table$param_id, - n = summary_score_table$n_select)) + n = summary_score_table$n_select + )) # Perform a local search. for (best_param_id in selected_best_parameter_id) { # Initialise iterator variable - iter_local_step <- 0 + iter_local_step <- 0L # Select initial configuration for local search selected_set <- parameter_table[param_id == best_param_id, ] @@ -126,7 +140,8 @@ local_random_set <- ..randomise_hyperparameter_set( parameter_table = selected_set, parameter_list = parameter_list, - local = TRUE) + local = TRUE + ) # Add configuration to list local_sets <- c(local_sets, list(local_random_set)) @@ -149,12 +164,14 @@ parameter_set = .SD, score_model = score_optimisation_model, acquisition_data = incumbent_set, - acquisition_function = acquisition_function)] + acquisition_function = acquisition_function + )] # Compute expected train time. local_sets[, "expected_train_time" := .compute_expected_train_time( parameter_set = .SD, - time_model = time_optimisation_model)] + time_model = time_optimisation_model + )] } @@ -172,7 +189,8 @@ if (!is_empty(random_sets)) { random_sets <- random_sets[ !parameter_table[param_id == incumbent_set$param_id], - on = .NATURAL] + on = .NATURAL + ] } # Select only parameter sets that can be evaluated within the allowed time. @@ -187,7 +205,7 @@ random_sets[parameter_table, "is_observed" := TRUE, on = .NATURAL] # Random sets that were not observed before. - if (any(!random_sets$is_observed) && n_random_sets > 0) { + if (!all(random_sets$is_observed) && n_random_sets > 0L) { # Select up to n_random_sets of random samples sets that were not # selected previously. selected_sets <- head(random_sets[is_observed == FALSE], n = n_random_sets) @@ -199,7 +217,7 @@ } # Random sets that were observed before. - if (any(random_sets$is_observed) && n_random_sets > 0) { + if (any(random_sets$is_observed) && n_random_sets > 0L) { # Select up to n_random_sets of random samples sets that were observed # selected previously. selected_sets <- head(random_sets[is_observed == TRUE], n = n_random_sets) @@ -214,12 +232,14 @@ # Concatenate challenger sets. challenger_sets <- data.table::rbindlist( random_challenger_sets, - use.names = TRUE) + use.names = TRUE + ) # Remove expected time from challenger sets. challenger_sets[, ":="( "expected_train_time" = NULL, - "is_observed" = NULL)] + "is_observed" = NULL + )] } else { challenger_sets <- NULL @@ -236,7 +256,8 @@ if (!is_empty(local_sets)) { local_sets <- local_sets[ !parameter_table[param_id == incumbent_set$param_id], - on = .NATURAL] + on = .NATURAL + ] } # Select only parameter sets that can be evaluated within the allowed time. @@ -251,12 +272,13 @@ local_sets[parameter_table, "is_observed" := TRUE, on = .NATURAL] # Local sets that were not observed before, with highest utility first. - if (any(!local_sets$is_observed)) { + if (!all(local_sets$is_observed)) { # Select up to n_local_sets of locally sampled sets that were not # selected previously. selected_sets <- head( local_sets[is_observed == FALSE][order(-utility)], - n = n_local_sets) + n = n_local_sets + ) # Add to challenger sets and reduce the number of challengers to select. local_challenger_sets <- list(selected_sets) @@ -265,12 +287,13 @@ } # Local sets that were observed before, with highest utility first. - if (any(local_sets$is_observed) && n_local_sets > 0) { + if (any(local_sets$is_observed) && n_local_sets > 0L) { # Select up to n_local_sets of locally samples sets that were observed # selected previously. selected_sets <- head( local_sets[is_observed == TRUE][order(-utility)], - n = n_local_sets) + n = n_local_sets + ) # Add to challenger sets and reduce the number of challengers to select. local_challenger_sets <- c(local_challenger_sets, list(selected_sets)) @@ -282,26 +305,30 @@ # Concatenate challenger sets. local_challenger_sets <- data.table::rbindlist( local_challenger_sets, - use.names = TRUE) + use.names = TRUE + ) # Remove expected improvement and time from challenger sets. local_challenger_sets[, ":="( "utility" = NULL, "expected_train_time" = NULL, - "is_observed" = NULL)] + "is_observed" = NULL + )] } # Remove incumbent and already selected challenger sets. if (!is_empty(random_sets)) { random_sets <- random_sets[ !parameter_table[param_id == incumbent_set$param_id], - on = .NATURAL] + on = .NATURAL + ] } - if (!is_empty(random_sets) && !is_empty(local_challenger_sets) > 0) { + if (!is_empty(random_sets) && !is_empty(local_challenger_sets) > 0L) { random_sets <- random_sets[ !local_challenger_sets, - on = .NATURAL] + on = .NATURAL + ] } # Select only parameter sets that can be evaluated within the allowed time. @@ -319,12 +346,13 @@ random_sets[parameter_table, "is_observed" := TRUE, on = .NATURAL] # Random sets that were not observed before, with highest utility first. - if (any(!random_sets$is_observed) && n_random_sets > 0) { + if (!all(random_sets$is_observed) && n_random_sets > 0L) { # Select up to n_random_sets of random samples sets that were not # selected previously. selected_sets <- head( random_sets[is_observed == FALSE][order(-utility)], - n = n_random_sets) + n = n_random_sets + ) # Add to challenger sets and reduce the number of challengers to select. random_challenger_sets <- list(selected_sets) @@ -333,12 +361,13 @@ } # Random sets that were observed before, with highest utility first. - if (any(random_sets$is_observed) && n_random_sets > 0) { + if (any(random_sets$is_observed) && n_random_sets > 0L) { # Select up to n_random_sets of random samples sets that were observed # selected previously. selected_sets <- head( random_sets[is_observed == TRUE][order(-utility)], - n = n_random_sets) + n = n_random_sets + ) # Add to challenger sets and reduce the number of challengers to select. random_challenger_sets <- c(random_challenger_sets, list(selected_sets)) @@ -350,19 +379,22 @@ # Concatenate challenger sets. random_challenger_sets <- data.table::rbindlist( random_challenger_sets, - use.names = TRUE) + use.names = TRUE + ) # Remove expected improvement and time from challenger sets. random_challenger_sets[, ":="( "utility" = NULL, "expected_train_time" = NULL, - "is_observed" = NULL)] + "is_observed" = NULL + )] } # Combine to challenger sets. challenger_sets <- data.table::rbindlist( list(local_challenger_sets, random_challenger_sets), - use.names = TRUE) + use.names = TRUE + ) } # Add parameter identifiers for known sets. @@ -371,10 +403,11 @@ challenger_sets <- challenger_sets[ parameter_table, "param_id" := i.param_id, - on = .NATURAL] + on = .NATURAL + ] # Fill out missing parameter ids. - if (any(is.na(challenger_sets$param_id))) { + if (anyNA(challenger_sets$param_id)) { # Find the largest existing parameter id. max_param_id <- max(parameter_table$param_id) @@ -395,19 +428,22 @@ hyperparameter_learner = "random_forest", score_table, parameter_table, - optimisation_function) { + optimisation_function +) { # Check that score_table contains optimisation scores. if (!"optimisation_score" %in% colnames(score_table)) { score_table <- .compute_hyperparameter_optimisation_score( score_table = score_table, - optimisation_function = optimisation_function) + optimisation_function = optimisation_function + ) } # Train model to predict process time. model <- ..hyperparameter_random_forest_time_learner( score_table = score_table, - parameter_table = parameter_table) + parameter_table = parameter_table + ) return(model) } @@ -416,14 +452,16 @@ ..hyperparameter_random_forest_time_learner <- function( score_table, - parameter_table) { + parameter_table +) { # Suppress NOTES due to non-standard evaluation in data.table time_taken <- NULL # Check if package is installed require_package( x = "ranger", - purpose = "to predict process time of hyperparameter sets") + purpose = "to predict process time of hyperparameter sets" + ) # Fill NA values with large, but finite values. Determine the maximum time. if (!all(is.na(score_table$time_taken))) { @@ -440,25 +478,28 @@ x = score_table, y = parameter_table, by = "param_id", - all = FALSE) + all = FALSE + ) # Replace NA entries with the minimum optimisation score. - joint_table[is.na(time_taken), time_taken := 10 * max_time_taken] + joint_table[is.na(time_taken), time_taken := 10.0 * max_time_taken] # Get parameter names. parameter_names <- setdiff( colnames(parameter_table), - c("param_id", "run_id", "optimisation_score", "time_taken")) + c("param_id", "run_id", "optimisation_score", "time_taken") + ) # Hyperparameters for the random forest. - n_tree <- 400 + n_tree <- 400L n_train <- nrow(joint_table) - sample_fraction <- max(c(0.3, min(c(1, 1 / (0.025 * n_train))))) + sample_fraction <- max(c(0.3, min(c(1.0, 1.0 / (0.025 * n_train))))) # Parse formula. formula <- stats::reformulate( termlabels = parameter_names, - response = "time_taken") + response = "time_taken" + ) # Train random forest. rf_model <- ranger::ranger(formula, @@ -466,7 +507,8 @@ num.trees = n_tree, num.threads = 1L, sample.fraction = sample_fraction, - verbose = FALSE) + verbose = FALSE + ) return(rf_model) } @@ -477,7 +519,8 @@ parameter_set, score_model, acquisition_data, - acquisition_function) { + acquisition_function +) { # Check that the score_model is trained, and return NA if not. if (!model_is_trained(score_model)) { return(rep_len(NA_real_, nrow(parameter_set))) @@ -496,7 +539,8 @@ utility_scores <- acquisition_fun( object = score_model, parameter_data = parameter_set, - acquisition_data = acquisition_data) + acquisition_data = acquisition_data + ) return(utility_scores) } @@ -506,7 +550,8 @@ acquisition_improvement_probability <- function( object, parameter_data, - acquisition_data) { + acquisition_data +) { # The definition of probability of improvement is found in Shahriari, B., # Swersky, K., Wang, Z., Adams, R. P. & de Freitas, N. Taking the Human Out of # the Loop: A Review of Bayesian Optimization. Proc. IEEE 104, 148–175 (2016) @@ -519,7 +564,8 @@ acquisition_improvement_probability <- function( prediction_table <- .predict( object = object, data = parameter_data, - type = "sd") + type = "sd" + ) # Compute the probability of improvement. alpha <- stats::pnorm((prediction_table$mu - tau) / prediction_table$sigma) @@ -532,7 +578,8 @@ acquisition_improvement_probability <- function( acquisition_improvement_empirical_probability <- function( object, parameter_data, - acquisition_data) { + acquisition_data +) { # The definition of probability of improvement is found in Shahriari, B., # Swersky, K., Wang, Z., Adams, R. P. & de Freitas, N. Taking the Human Out of # the Loop: A Review of Bayesian Optimization. Proc. IEEE 104, 148–175 (2016) @@ -552,16 +599,19 @@ acquisition_improvement_empirical_probability <- function( prediction_table <- .predict( object = object, data = parameter_data, - type = "raw") + type = "raw" + ) # Drop parameter id. This should leave only raw data. prediction_table[, "param_id" := NULL] # Compute utility. - alpha <- apply(prediction_table, - MARGIN = 1, + alpha <- apply( + prediction_table, + MARGIN = 1L, .acquisition_improvement_empirical_probability, - tau = tau) + tau = tau + ) } else { # Compute the stochastic probability of improvement. @@ -571,7 +621,8 @@ acquisition_improvement_empirical_probability <- function( prediction_table <- .predict( object = object, data = parameter_data, - type = "sd") + type = "sd" + ) # Stochastic values alpha <- stats::pnorm((prediction_table$mu - tau) / prediction_table$sigma) @@ -585,7 +636,8 @@ acquisition_improvement_empirical_probability <- function( acquisition_expected_improvement <- function( object, parameter_data, - acquisition_data) { + acquisition_data +) { # The definition of expected improvement is found in Shahriari, B., Swersky, # K., Wang, Z., Adams, R. P. & de Freitas, N. Taking the Human Out of the # Loop: A Review of Bayesian Optimization. Proc. IEEE 104, 148–175 (2016). @@ -598,7 +650,8 @@ acquisition_expected_improvement <- function( prediction_table <- .predict( object = object, data = parameter_data, - type = "sd") + type = "sd" + ) # Compute a z-score. z <- (prediction_table$mu - tau) / prediction_table$sigma @@ -615,7 +668,8 @@ acquisition_expected_improvement <- function( acquisition_upper_confidence_bound <- function( object, parameter_data, - acquisition_data) { + acquisition_data +) { # The definition of upper confidence bound is adapted from Srinivas, N., # Krause, A., Kakade, S. M. & Seeger, M. W. Information-Theoretic Regret # Bounds for Gaussian Process Optimization in the Bandit Setting. IEEE @@ -629,10 +683,11 @@ acquisition_upper_confidence_bound <- function( prediction_table <- .predict( object = object, data = parameter_data, - type = "sd") + type = "sd" + ) # Compute the beta parameter. - beta <- 2.0 / 5.0 * log(5.0 / 3.0 * n_parameters * (acquisition_data$t + 1)^2 * pi^2) + beta <- 2.0 / 5.0 * log(5.0 / 3.0 * n_parameters * (acquisition_data$t + 1.0)^2.0 * pi^2.0) # Compute alpha alpha <- prediction_table$mu + beta * prediction_table$sigma @@ -645,14 +700,15 @@ acquisition_upper_confidence_bound <- function( acquisition_bayes_upper_confidence_bound <- function( object, parameter_data, - acquisition_data) { + acquisition_data +) { # The definition of the Bayesian upper confidence bound is adapted from # Kaufmann, E., Cappé, O. & Garivier, A. On Bayesian upper confidence bounds # for bandit problems. in Artificial intelligence and statistics 592–600 # (2012). # Compute the quantile we are interested in. - q <- 1.0 - 1.0 / (acquisition_data$t + 1) + q <- 1.0 - 1.0 / (acquisition_data$t + 1.0) if ("percentile" %in% get_prediction_type(object)) { # Compute empiric alpha. @@ -660,7 +716,8 @@ acquisition_bayes_upper_confidence_bound <- function( object = object, data = parameter_data, type = "percentile", - percentile = q)$percentile + percentile = q + )$percentile } else { # Predict the mean and standard deviation for the parameter sets in @@ -668,13 +725,15 @@ acquisition_bayes_upper_confidence_bound <- function( prediction_table <- .predict( object = object, data = parameter_data, - type = "sd") + type = "sd" + ) # Stochastic alpha. alpha <- stats::qnorm( q, mean = prediction_table$mu, - sd = prediction_table$sigma) + sd = prediction_table$sigma + ) } return(alpha) @@ -684,7 +743,8 @@ acquisition_bayes_upper_confidence_bound <- function( .compute_expected_train_time <- function( parameter_set, - time_model) { + time_model +) { # If no time model is present, return NA. if (is.null(time_model)) return(NA_real_) @@ -695,13 +755,15 @@ acquisition_bayes_upper_confidence_bound <- function( # Check if package is installed require_package( x = "ranger", - purpose = "to predict process time of hyperparameter sets") + purpose = "to predict process time of hyperparameter sets" + ) predictions <- predict(time_model, data = parameter_set, type = "response", num.threads = 1L, - verbose = FALSE) + verbose = FALSE + ) return(predictions$predictions) } @@ -714,7 +776,8 @@ acquisition_bayes_upper_confidence_bound <- function( "improvement_empirical_probability", "expected_improvement", "upper_confidence_bound", - "bayes_upper_confidence_bound")) + "bayes_upper_confidence_bound" + )) } @@ -724,7 +787,8 @@ acquisition_bayes_upper_confidence_bound <- function( .get_available_ranger_hyperparameter_learners(), .get_available_lagp_hyperparameter_learners(), .get_available_bart_hyperparameter_learners(), - .get_available_random_search_hyperparameter_learners())) + .get_available_random_search_hyperparameter_learners() + )) } @@ -734,5 +798,6 @@ acquisition_bayes_upper_confidence_bound <- function( "single_shot", "successive_halving", "stochastic_reject", - "none")) + "none" + )) } diff --git a/R/HyperparameterOptimisationUtilities.R b/R/HyperparameterOptimisationUtilities.R index 561b0134..dff3fb4c 100644 --- a/R/HyperparameterOptimisationUtilities.R +++ b/R/HyperparameterOptimisationUtilities.R @@ -1,9 +1,10 @@ ..create_initial_hyperparameter_set <- function( parameter_list, grid_initialisation_method, - n_random_sets = 200L) { + n_random_sets = 200L +) { - if (length(parameter_list) == 0) return(NULL) + if (length(parameter_list) == 0L) return(NULL) if (!.any_randomised_hyperparameters(parameter_list = parameter_list)) { # All variables have been fixed. No optimisation is required. @@ -11,7 +12,8 @@ # Get values for each parameter. value_list <- lapply( parameter_list, - function(list_entry) (list_entry$init_config)) + function(list_entry) (list_entry$init_config) + ) # Convert to a data table. parameter_table <- data.table::as.data.table(value_list) @@ -27,9 +29,11 @@ function(ii, parameter_list) { return(..randomise_hyperparameter_set( parameter_list = parameter_list, - local = FALSE)) + local = FALSE + )) }, - parameter_list = parameter_list) + parameter_list = parameter_list + ) # Combine list into a single data table. parameter_table <- data.table::rbindlist(random_list, use.names = TRUE) @@ -45,13 +49,15 @@ # Get initial values for each parameter. value_list <- lapply( parameter_list, - function(list_entry) (list_entry$init_config)) + function(list_entry) (list_entry$init_config) + ) # Generate a table with all permutations of the grid points. parameter_table <- expand.grid( value_list, stringsAsFactors = FALSE, - KEEP.OUT.ATTRS = FALSE) + KEEP.OUT.ATTRS = FALSE + ) parameter_table <- data.table::as.data.table(parameter_table) # Allow only unique parameter sets. @@ -66,7 +72,8 @@ selected_row_id <- sample( x = seq_len(nrow(parameter_table)), size = min(c(nrow(parameter_table), n_random_sets)), - replace = FALSE) + replace = FALSE + ) parameter_table <- parameter_table[selected_row_id, ] } @@ -83,11 +90,13 @@ ..randomise_hyperparameter_set <- function( parameter_table = NULL, parameter_list, - local = TRUE) { + local = TRUE +) { if (local && is_empty(parameter_table)) { ..error_reached_unreachable_code( - "..randomise_hyperparameter_set: no values for local search.") + "..randomise_hyperparameter_set: no values for local search." + ) } if (local) { @@ -104,10 +113,12 @@ # randomly update. random_parameters <- sapply( parameter_list, - function(list_entry) (list_entry$randomise)) + function(list_entry) (list_entry$randomise) + ) selected_parameter <- fam_sample( names(parameter_list)[random_parameters], - size = 1) + size = 1L + ) # Get current value of the selected hyperparameter from the table. current_parameter_value <- parameter_table[[selected_parameter]] @@ -117,7 +128,7 @@ parameter_range <- parameter_list[[selected_parameter]]$range if (parameter_type %in% c("integer", "numeric")) { - if (length(parameter_range) == 2) { + if (length(parameter_range) == 2L) { # Check that the range is not 0. if (max(parameter_range) != min(parameter_range)) { # Convert to float in [0,1] range @@ -129,12 +140,12 @@ while (!rand_valid) { # Draw 20 random numbers from a normal distribution with # mean = hp_val_float and sd = 0.2 - hp_rand <- stats::rnorm(20, mean = hp_val_float, sd = 0.1) + hp_rand <- stats::rnorm(20L, mean = hp_val_float, sd = 0.1) rand_valid <- any(hp_rand >= 0.0 & hp_rand <= 1.0) } # Select new value in [0,1] and convert to original range - new_hp_val_float <- hp_rand[hp_rand >= 0 & hp_rand <= 1.0][1] + new_hp_val_float <- hp_rand[hp_rand >= 0.0 & hp_rand <= 1.0][1L] new_hp_val_float <- new_hp_val_float * (max(parameter_range) - min(parameter_range)) + min(parameter_range) @@ -145,7 +156,7 @@ } else { # Treat a range such as c(0,1,3) as if only these values can be selected. - new_hp_val_float <- fam_sample(parameter_range, size = 1) + new_hp_val_float <- fam_sample(parameter_range, size = 1L) } # Set new value as integer or numeric float @@ -162,15 +173,16 @@ # Randomly select one option updated_list[[selected_parameter]] <- factor( - fam_sample(available_parameter_values, size = 1), - levels = parameter_range) + fam_sample(available_parameter_values, size = 1L), + levels = parameter_range + ) } else if (parameter_type %in% c("logical")) { # Find range of available options available_parameter_values <- parameter_range[parameter_range != current_parameter_value] # Randomly select one option - updated_list[[selected_parameter]] <- fam_sample(available_parameter_values, size = 1) + updated_list[[selected_parameter]] <- fam_sample(available_parameter_values, size = 1L) } else { ..error_reached_unreachable_code("randomise_hyperparameter_set_unknown_type") @@ -182,12 +194,14 @@ # Generate an updated list from parameter_list for randomisation updated_list <- lapply( parameter_list, - function(list_entry) (list_entry$init_config[1])) + function(list_entry) (list_entry$init_config[1L]) + ) # Select hyperparameters to be randomised random_parameters <- sapply( parameter_list, - function(list_entry) (list_entry$randomise)) + function(list_entry) (list_entry$randomise) + ) random_parameters <- names(parameter_list)[random_parameters] # Iterate over hyperparameters @@ -198,17 +212,17 @@ parameter_distribution <- parameter_list[[selected_parameter]]$rand_distr if (parameter_type %in% c("integer", "numeric")) { - if (length(parameter_range) == 2) { + if (length(parameter_range) == 2L) { if (is.null(parameter_distribution)) { # Select new value in [0,1] and convert to original range - hp_rand <- stats::runif(1) + hp_rand <- stats::runif(1L) new_hp_val_float <- hp_rand * (max(parameter_range) - min(parameter_range)) + min(parameter_range) } else if (parameter_distribution == "log") { # Select new value in [0,1] and convert to log transform of original # range - hp_log_rand <- stats::runif(1) * + hp_log_rand <- stats::runif(1L) * (log(max(parameter_range)) - log(min(parameter_range))) + log(min(parameter_range)) # Transform back from log transformation: note this emphasises @@ -218,7 +232,7 @@ } else { # Treat a range such as c(0,1,3) as if only these values can be # selected. - new_hp_val_float <- fam_sample(parameter_range, size = 1) + new_hp_val_float <- fam_sample(parameter_range, size = 1L) } # Set new value as integer or numeric float @@ -231,11 +245,12 @@ } else if (parameter_type %in% c("factor")) { # Randomly select one option updated_list[[selected_parameter]] <- factor( - fam_sample(parameter_range, size = 1), - levels = parameter_range) + fam_sample(parameter_range, size = 1L), + levels = parameter_range + ) } else if (parameter_type %in% c("logical")) { - updated_list[[selected_parameter]] <- fam_sample(parameter_range, size = 1) + updated_list[[selected_parameter]] <- fam_sample(parameter_range, size = 1L) } } } @@ -253,7 +268,8 @@ score_table = NULL, parameter_table = NULL, optimisation_model = NULL, - n_max_bootstraps = NULL) { + n_max_bootstraps = NULL +) { # Creates a run table from the run identifiers and parameter identifiers. # Suppress NOTES due to non-standard evaluation in data.table @@ -266,14 +282,16 @@ # Compute optimisation score based on the presented scores. optimisation_score_table <- .compute_hyperparameter_optimisation_score( score_table = score_table, - optimisation_function = optimisation_model@optimisation_function) + optimisation_function = optimisation_model@optimisation_function + ) # Find data related to the most promising set of hyperparameters. incumbent_set <- get_best_hyperparameter_set( score_table = optimisation_score_table, parameter_table = parameter_table, optimisation_model = optimisation_model, - n_max_bootstraps = n_max_bootstraps) + n_max_bootstraps = n_max_bootstraps + ) # Select fitting hyperparameters. parameter_ids <- optimisation_score_table[time_taken <= incumbent_set$max_time]$param_id @@ -281,7 +299,8 @@ if (is.null(parameter_ids)) { ..error_reached_unreachable_code( - "..create_hyperparameter_run_table: parameter_ids cannot be NULL.") + "..create_hyperparameter_run_table: parameter_ids cannot be NULL." + ) } # Create a run table consisting of parameter and run identifiers. @@ -289,7 +308,8 @@ param_id = parameter_ids, run_id = run_ids, KEEP.OUT.ATTRS = FALSE, - stringsAsFactors = FALSE)) + stringsAsFactors = FALSE + )) return(run_table) } @@ -300,7 +320,8 @@ process_clock, time_limit = NULL, message_indent = 0L, - verbose = FALSE) { + verbose = FALSE +) { # Check that there is time-limit to obey. if (is.null(time_limit)) return(TRUE) @@ -316,9 +337,11 @@ "Hyperparameter optimisation: Optimisation stopped because the ", "optimisation process exceeded the allotted time: ", "time spent: ", optimisation_time, " mins; ", - "time allotted: ", time_limit, " mins."), + "time allotted: ", time_limit, " mins." + ), indent = message_indent, - verbose = verbose) + verbose = verbose + ) return(FALSE) } @@ -327,114 +350,93 @@ .compute_hyperparameter_variable_importance <- function( cl = NULL, - determine_vimp = TRUE, object, data, bootstraps, verbose, message_indent, - ...) { + ... +) { - if (object@fs_method %in% .get_available_random_vimp_methods() || - object@fs_method %in% .get_available_none_vimp_methods() || - object@fs_method %in% .get_available_signature_only_vimp_methods() || - object@fs_method %in% .get_available_no_features_vimp_methods()) { + if ( + object@vimp_method %in% .get_available_random_vimp_methods() || + object@vimp_method %in% .get_available_none_vimp_methods() || + object@vimp_method %in% .get_available_signature_only_vimp_methods() || + object@vimp_method %in% .get_available_no_features_vimp_methods() + ) { return(NULL) - } - - # Check if the code is called downstream from summon_familiar. - is_main_process <- !inherits(tryCatch(get_file_paths(), error = identity), "error") - - if (determine_vimp || !is_main_process) { - # Variable importance has to be computed for the bootstraps if expressly - # requested using determine_vimp or if the code is called outside of - # summon_familiar. - - # Set up variable importance object. - vimp_object <- promote_vimp_method(methods::new("familiarVimpMethod", - outcome_type = object@outcome_type, - vimp_method = object@fs_method, - outcome_info = object@outcome_info, - feature_info = object@feature_info, - required_features = object@required_features, - run_table = object@run_table)) - - if (is_main_process) { - # Load hyperparameters. - vimp_object <- run_hyperparameter_optimisation( - vimp_method = object@fs_method, - data_id = tail(object@run_table, n = 1)$data_id, - verbose = FALSE) - - # Select a suitable sets of hyperparameters. - vimp_object <- .find_hyperparameters_for_run( - run = list("run_table" = object@run_table), - hpo_list = vimp_object, - allow_random_selection = TRUE, - as_list = FALSE) - - } else { - # Optimise hyperparameters. - vimp_object <- optimise_hyperparameters( - object = vimp_object, - data = data, - cl = cl, - determine_vimp = determine_vimp, - verbose = verbose, - message_indent = message_indent + 1L, - ...) - } - + + } else if (is(object@vimp_table, "vimpTable") || rlang::is_bare_list(object@vimp_table)) { + # Use existing vimp_tables. + vimp_table <- lapply( + bootstraps, + function(x, vimp_table) (vimp_table), + vimp_table = object@vimp_table + ) + + } else { + logger_message( paste0( "Computing variable importance for ", - length(bootstraps), " bootstraps."), + length(bootstraps), " bootstraps." + ), indent = message_indent + 1L, - verbose = verbose) - - # Iterate over data. - vimp_list <- fam_lapply( + verbose = verbose + ) + + # Spawn task to obtain variable importance tables. + vimp_task <- methods::new( + "familiarTaskVimp", + project_id = object@project_id, + vimp_method = object@vimp_method, + file = NA_character_ + ) + + vimp_table <- fam_lapply( cl = cl, assign = "all", X = bootstraps, FUN = ..compute_hyperparameter_variable_importance, - object = vimp_object, + vimp_task = vimp_task, + vimp_aggregation_method = object@vimp_aggregation_method, + vimp_rank_threshold = object@vimp_rank_threshold, data = data, + feature_info = object@feature_info, progress_bar = verbose, - chopchop = TRUE) + chopchop = TRUE + ) } - return(vimp_list) + return(vimp_table) } ..compute_hyperparameter_variable_importance <- function( train_samples, - object, - data) { - + vimp_task, + data, + vimp_aggregation_method, + vimp_rank_threshold, + feature_info +) { # Select bootstrap data. data <- select_data_from_samples( data = data, - samples = train_samples) - - # Select a familiarVimpMethod object if multiple are present. - if (rlang::is_bare_list(object)) { - object <- object[[sample(x = seq_along(object), size = 1L)]] - } - - # Compute variable importance. - vimp_table <- .vimp( - object = object, - data = data) - - # Form clusters. - vimp_table <- recluster_vimp_table(vimp_table) - - # Compute variable importance. - vimp_table <- get_vimp_table(vimp_table) + samples = train_samples + ) + # Execute the task to compute variable importance table for the current + # bootstrap. + vimp_table <- .perform_task( + object = vimp_task, + feature_info_list = feature_info, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + data = data + ) + return(vimp_table) } @@ -447,12 +449,13 @@ parameter_table, bootstraps, data, - rank_table_list, + vimp_table_list, metric_objects, iteration_id, time_optimisation_model = NULL, overhead_time = NULL, - verbose = FALSE) { + verbose = FALSE +) { # Suppress NOTES due to non-standard evaluation in data.table param_id <- NULL @@ -460,30 +463,36 @@ # Check that the run table is not empty. This may occur if, for instance, the # initial search turned up nothing. if (is_empty(run_table)) return(NULL) - + # Prepare training and validation samples for the separate runs. training_list <- lapply( run_table$run_id, function(ii, training_list) (training_list[[ii]]), - training_list = bootstraps$train_list) + training_list = bootstraps$train_list + ) validation_list <- lapply( run_table$run_id, function(ii, validation_list) (validation_list[[ii]]), - validation_list = bootstraps$valid_list) + validation_list = bootstraps$valid_list + ) # Generate parameter sets. parameter_list <- lapply( run_table$param_id, function(ii, parameter_table) (parameter_table[param_id == ii, ]), - parameter_table = parameter_table) + parameter_table = parameter_table + ) - # Generate variable importance sets (if any) - rank_table_list <- lapply( + # Replicate variable importance table objects. + if (is(vimp_table_list, "vimpTable")) vimp_table_list <- list(vimp_table_list) + + vimp_table_list <- lapply( run_table$run_id, - function(ii, rank_table_list) (rank_table_list[[ii]]), - rank_table_list = rank_table_list) - + function(ii, vimp_table_list) (vimp_table_list[[ii]]), + vimp_table_list = vimp_table_list + ) + if (is.null(time_optimisation_model)) { # Create a scoring table, with accompanying information. score_results <- fam_mapply_lb( @@ -493,20 +502,23 @@ run_id = run_table$run_id, training_samples = training_list, validation_samples = validation_list, - rank_table = rank_table_list, + vimp_table = vimp_table_list, parameter_table = parameter_list, progress_bar = verbose, MEASURE.TIME = TRUE, MoreArgs = list( "object" = object, "data" = data, - "metric_objects" = metric_objects)) + "metric_objects" = metric_objects + ) + ) } else { # Predict expected process time for each parameter set. process_time <- sapply(parameter_list, .compute_expected_train_time, - time_model = time_optimisation_model) + time_model = time_optimisation_model + ) # Create a scoring table, with accompanying information. score_results <- fam_mapply( @@ -516,7 +528,7 @@ run_id = run_table$run_id, training_samples = training_list, validation_samples = validation_list, - rank_table = rank_table_list, + vimp_table = vimp_table_list, parameter_table = parameter_list, progress_bar = verbose, process_time = process_time, @@ -526,17 +538,21 @@ MoreArgs = list( "object" = object, "data" = data, - "metric_objects" = metric_objects)) + "metric_objects" = metric_objects + ) + ) } # Aggregate the results, and the score table aggregated_results <- list("results" = data.table::rbindlist( lapply(score_results$results, function(x) (x$score_table)), - use.names = TRUE)) + use.names = TRUE + )) # Add in process times to the results. aggregated_results$results[, "time_taken" := rep( - score_results$process_time, each = 2 * length(metric_objects))] + score_results$process_time, each = 2L * length(metric_objects) + )] # Add in iteration id. aggregated_results$results[, "iteration_id" := iteration_id] @@ -544,7 +560,8 @@ # Aggregate errors. aggregated_results$error <- unlist(lapply( score_results$results, - function(x) (x$error))) + function(x) (x$error) + )) # Return aggregated results. return(aggregated_results) @@ -559,37 +576,44 @@ training_samples, validation_samples, parameter_table, - rank_table, + vimp_table, metric_objects, - signature_features = NULL) { + signature_features = NULL +) { if (!is(object, "familiarModel")) { ..error_reached_unreachable_code(paste0( "..compute_hyperparameter_model_performance: object is ", - "not a familiarModel object.")) + "not a familiarModel object." + )) } # Find parameter id and run id for the current run parameter_list <- as.list(parameter_table[, -c("param_id")]) - param_id <- parameter_table$param_id[1] + param_id <- parameter_table$param_id[1L] # Select training (in-bag) and validation (out-of-bag) data for current run, data_training <- select_data_from_samples( data = data, - samples = training_samples) + samples = training_samples + ) data_validation <- select_data_from_samples( data = data, - samples = validation_samples) - + samples = validation_samples + ) + # Update the familiar model (for variable importance) object@hyperparameters <- parameter_list + # Attach variable importance table to object. + object@vimp_table <- vimp_table + # Set signature. - object <- set_signature( + object <- set_model_features( object = object, - rank_table = rank_table, - minimise_footprint = TRUE) + minimise_footprint = TRUE + ) # Train model with the set of hyperparameters. object <- .train( @@ -597,11 +621,18 @@ data = data_training, get_additional_info = FALSE, trim_model = FALSE, - approximate = TRUE) + approximate = TRUE + ) # Generate scores. score_table <- mapply( - function(data, data_set, object, metric_objects, settings) { + function( + data, + data_set, + object, + metric_objects, + settings + ) { # Get metric names. metric_names <- sapply(metric_objects, function(metric_object) metric_object@metric) @@ -617,33 +648,38 @@ prediction_table <- .predict( object = object, data = data, - time = time_max) + time = time_max + ) # Compute metric scores. metrics_values <- sapply( metric_objects, compute_metric_score, - data = prediction_table) + data = prediction_table + ) # Compute objective scores. metrics_objective_score <- mapply( compute_objective_score, metric = metric_objects, value = metrics_values, - SIMPLIFY = TRUE) + SIMPLIFY = TRUE + ) # Return as data.table. return(data.table::data.table( "metric" = metric_names, "data_set" = data_set, "value" = metrics_values, - "objective_score" = metrics_objective_score)) + "objective_score" = metrics_objective_score + )) }, data = list(data_training, data_validation), data_set = c("training", "validation"), MoreArgs = list( "object" = object, - "metric_objects" = metric_objects), + "metric_objects" = metric_objects + ), SIMPLIFY = FALSE ) @@ -653,23 +689,27 @@ # Add parameter id and run id. score_table[, ":="( "param_id" = param_id, - "run_id" = run_id)] + "run_id" = run_id + )] # Set the column order. data.table::setcolorder( x = score_table, - neworder = c("param_id", "run_id")) + neworder = c("param_id", "run_id") + ) return(list( "score_table" = score_table, - "error" = object@messages$error)) + "error" = object@messages$error + )) } .compute_hyperparameter_optimisation_score <- function( score_table, - optimisation_function) { + optimisation_function +) { # Suppress NOTES due to non-standard evaluation in data.table .NATURAL <- NULL @@ -678,12 +718,14 @@ # Compute optimisation score. optimisation_score_table <- .compute_metric_optimisation_score( score_table = score_table, - optimisation_function = optimisation_function) + optimisation_function = optimisation_function + ) # Reinsert time_taken. optimisation_score_table <- optimisation_score_table[ unique(score_table[, c("param_id", "run_id", "time_taken")]), - on = .NATURAL] + on = .NATURAL + ] return(optimisation_score_table) } @@ -693,7 +735,8 @@ .compute_hyperparameter_summary_score <- function( score_table, parameter_table, - optimisation_model) { + optimisation_model +) { # Suppress NOTES due to non-standard evaluation in data.table optimisation_score <- time_taken <- .NATURAL <- mu <- sigma <- NULL summary_score <- score_estimate <- NULL @@ -711,7 +754,8 @@ if (!"optimisation_score" %in% colnames(score_table)) { score_table <- .compute_hyperparameter_optimisation_score( score_table = score_table, - optimisation_function = optimisation_function) + optimisation_function = optimisation_function + ) } # Make sure to return both the summary score, as well as the mean optimisation @@ -720,7 +764,8 @@ # predictions of the optimisation score -- not the summary score. In addition, # compute time_taken. if (optimisation_function %in% c( - "validation", "max_validation", "balanced", "stronger_balance")) { + "validation", "max_validation", "balanced", "stronger_balance" + )) { # Here we just use the mean score. data <- score_table[, list( "summary_score" = mean(optimisation_score, na.rm = TRUE), @@ -747,7 +792,8 @@ } else if (optimisation_function %in% c( "model_estimate", "model_estimate_minus_sd", - "model_balanced_estimate", "model_balanced_estimate_minus_sd")) { + "model_balanced_estimate", "model_balanced_estimate_minus_sd" + )) { # Model based summary scores. The main difference with other optimisation # functions is that a hyperparameter model is used to both infer the summary # scores and the score estimate. @@ -757,13 +803,15 @@ optimisation_model <- .train( object = optimisation_model, data = score_table, - parameter_data = parameter_table) + parameter_data = parameter_table + ) } # Get parameter data that is used in the score table. parameter_data <- parameter_table[ unique(score_table[, mget("param_id")]), - on = .NATURAL] + on = .NATURAL + ] # Model was successfully trained. prediction_table <- .predict( @@ -771,14 +819,17 @@ data = parameter_data, type = ifelse( optimisation_function %in% c("model_estimate", "model_balanced_estimate"), - "default", "sd")) + "default", "sd" + ) + ) # Check the prediction table has returned sensible information. if (any(is.finite(prediction_table$mu))) { # Prepare the score estimate and time taken. - data <- score_table[, list( - "time_taken" = stats::median(time_taken)), - by = "param_id"] + data <- score_table[ + , list("time_taken" = stats::median(time_taken)), + by = "param_id" + ] # Fold the prediction table into data. data <- merge( @@ -786,7 +837,8 @@ y = prediction_table, all.x = TRUE, all.y = FALSE, - by = "param_id") + by = "param_id" + ) if (optimisation_function %in% c("model_estimate", "model_balanced_estimate")) { # Copy mu as score estimate. @@ -796,10 +848,12 @@ data.table::setnames( x = data, old = "mu", - new = "summary_score") + new = "summary_score" + ) } else if (optimisation_function %in% c( - "model_estimate_minus_sd", "model_balanced_estimate_minus_sd")) { + "model_estimate_minus_sd", "model_balanced_estimate_minus_sd" + )) { # Compute summary score. data[, "summary_score" := mu - sigma] @@ -807,23 +861,27 @@ data.table::setnames( x = data, old = "mu", - new = "score_estimate") + new = "score_estimate" + ) } else { ..error_reached_unreachable_code(paste0( ".compute_hyperparameter_summary_score: encountered ", - "unknown optimisation function: ", optimisation_function)) + "unknown optimisation function: ", optimisation_function + )) } # Check that any predictions make sense at all. - if (all(!is.finite(score_table$optimisation_score))) { + if (!any(is.finite(score_table$optimisation_score))) { data[, ":="( summary_score = NA_real_, - score_estimate = NA_real_)] + score_estimate = NA_real_ + )] } } else if (optimisation_function %in% c( - "model_estimate", "model_balanced_estimate")) { + "model_estimate", "model_balanced_estimate" + )) { # In absence of suitable data, use the model-less equivalent of # model_estimate or model_balanced_estimate, namely "validation". data <- score_table[, list( @@ -833,7 +891,8 @@ ), by = "param_id"] } else if (optimisation_function %in% c( - "model_estimate_minus_sd", "model_balanced_estimate_minus_sd")) { + "model_estimate_minus_sd", "model_balanced_estimate_minus_sd" + )) { # In absence of suitable data, use the model-less equivalent of # model_estimate_minus_sd or model_balanced_estimate_minus_sd, # namely "validation_minus_sd". @@ -846,13 +905,15 @@ } else { ..error_reached_unreachable_code(paste0( ".compute_hyperparameter_summary_score: encountered unknown ", - "optimisation function: ", optimisation_function)) + "optimisation function: ", optimisation_function + )) } } else { ..error_reached_unreachable_code(paste0( ".compute_hyperparameter_summary_score: encountered an unknown ", - "optimisation function")) + "optimisation function" + )) } # Format data by selecting only relevant columns. This also orders the data. @@ -872,7 +933,7 @@ # The default behaviour is when multiple subsamples exist, and the standard # deviation can be computed. - if (length(x) > 1) { + if (length(x) > 1L) { return(mean(x, na.rm = TRUE) - stats::sd(x, na.rm = TRUE)) } @@ -889,7 +950,8 @@ get_best_hyperparameter_set <- function( optimisation_model, n_max_bootstraps, n = 1L, - parameter_id_set = NULL) { + parameter_id_set = NULL +) { # The best set has several interesting values that can be computed and used # for acquisition functions, information for the user etc. @@ -900,7 +962,8 @@ get_best_hyperparameter_set <- function( data <- .compute_hyperparameter_summary_score( score_table = score_table, parameter_table = parameter_table, - optimisation_model = optimisation_model) + optimisation_model = optimisation_model + ) # Select only the parameter sets of interest. This happens during the run-off # between the incumbent and challenger hyperparameter sets. @@ -917,7 +980,7 @@ get_best_hyperparameter_set <- function( t <- max(unique(score_table[, mget(c("param_id", "run_id"))])[, list("n" = .N), by = "param_id"]$n) # Compute the maximum allowed time. - max_time <- (5.0 - 4.0 * t / n_max_bootstraps) * data$time_taken[1] + max_time <- (5.0 - 4.0 * t / n_max_bootstraps) * data$time_taken[1L] # Check that the maximum time is not trivially small (i.e. less than 10 # seconds). @@ -942,14 +1005,16 @@ get_best_hyperparameter_set <- function( # Compute mean validation score as a summary score, as well as mean validation # scores of the raw metric values. additional_scores <- .compute_hyperparameter_additional_scores( - score_table = score_table[param_id %in% data$param_id]) + score_table = score_table[param_id %in% data$param_id] + ) # Merge additional scores with summary data and sort again to prevent any # merge issues. data <- merge( x = data, y = additional_scores, - by = "param_id") + by = "param_id" + ) data <- data[order(-summary_score)] # Find metric columns @@ -966,7 +1031,8 @@ get_best_hyperparameter_set <- function( "score_estimate" = score_estimate, "validation_score" = data$validation_score, "metric_score" = data[, mget(c(metric_columns))], - "n" = n_max_bootstraps)) + "n" = n_max_bootstraps + )) } else { return(list( @@ -976,7 +1042,8 @@ get_best_hyperparameter_set <- function( "max_time" = max_time, "summary_score" = summary_score, "score_estimate" = score_estimate, - "n" = n_max_bootstraps)) + "n" = n_max_bootstraps + )) } } @@ -990,11 +1057,14 @@ get_best_hyperparameter_set <- function( # hyperparameter optimisation. mean_validation_scores <- .compute_hyperparameter_optimisation_score( score_table = score_table, - optimisation_function = "validation") + optimisation_function = "validation" + ) - mean_validation_scores <- mean_validation_scores[, list( - "validation_score" = mean(optimisation_score, na.rm = TRUE) - ), by = c("param_id")] + mean_validation_scores <- mean_validation_scores[ + , + list("validation_score" = mean(optimisation_score, na.rm = TRUE)), + by = c("param_id") + ] # Compute mean metric values. mean_metric_scores <- score_table[ @@ -1005,12 +1075,14 @@ get_best_hyperparameter_set <- function( mean_metric_scores <- data.table::dcast( mean_metric_scores, param_id ~ metric, - value.var = "average_metric_value") + value.var = "average_metric_value" + ) return(merge( x = mean_validation_scores, y = mean_metric_scores, - by = "param_id")) + by = "param_id" + )) } @@ -1018,7 +1090,8 @@ get_best_hyperparameter_set <- function( ..parse_optimisation_summary_to_string <- function( parameter_set, parameter_table, - parameter_list) { + parameter_list +) { # Suppress NOTES due to non-standard evaluation in data.table param_id <- NULL @@ -1030,14 +1103,17 @@ get_best_hyperparameter_set <- function( message_str, paste0( "summary score: ", - sprintf("%.4f", parameter_set$summary_score[1]))) + sprintf("%.4f", parameter_set$summary_score[1L]) + ) + ) # Add validation optimisation score. message_str <- c( message_str, paste0( "validation optimisation score: ", - sprintf("%.4f", parameter_set$validation_score[1])) + sprintf("%.4f", parameter_set$validation_score[1L]) + ) ) @@ -1047,7 +1123,8 @@ get_best_hyperparameter_set <- function( message_str, paste0( metric, ": ", - sprintf("%.4f", parameter_set$metric_score[[metric]][1])) + sprintf("%.4f", parameter_set$metric_score[[metric]][1L]) + ) ) } @@ -1058,7 +1135,7 @@ get_best_hyperparameter_set <- function( if (parameter_list[[current_parameter]]$randomise == TRUE) { # Determine the value of the parameter for the set identified by the id # variable. - optimal_value <- parameter_table[param_id == parameter_set$param_id, ][[current_parameter]][1] + optimal_value <- parameter_table[param_id == parameter_set$param_id, ][[current_parameter]][1L] # Append to string. message_str <- c( @@ -1076,19 +1153,22 @@ get_best_hyperparameter_set <- function( ..update_hyperparameter_optimisation_stopping_criteria <- function( set_data, stop_data = NULL, - tolerance = 1E-2) { + tolerance = 1E-2 +) { # Store the validation score of the incumbent set. Note that the latest score # is always appended. validation_scores <- c( stop_data$score, - set_data$validation_score) + set_data$validation_score + ) # Store the parameter id of the incumbent set. Note that the most recent # hyperparameter set identifier is always appended. incumbent_parameter_id <- c( stop_data$parameter_id, - set_data$param_id) + set_data$param_id + ) # Read the convergence counters. Can be NULL initially. convergence_counter_score <- stop_data$convergence_counter_score @@ -1100,7 +1180,7 @@ get_best_hyperparameter_set <- function( # Update convergence counter for parameter identifiers if there is no change # in the incumbent parameter set. Skip on the first run-through. - if (length(incumbent_parameter_id) >= 2) { + if (length(incumbent_parameter_id) >= 2L) { if (all(tail(incumbent_parameter_id, n = 3L) == set_data$param_id)) { # Update the convergence counter. convergence_counter_parameter_id <- convergence_counter_parameter_id + 1L @@ -1112,10 +1192,11 @@ get_best_hyperparameter_set <- function( # Assess convergence of the summary scores. This is skipped on the first # run-through. - if (length(validation_scores) >= 2) { + if (length(validation_scores) >= 2L) { # Compute absolute deviation from the mean. max_abs_deviation <- max(abs( - tail(validation_scores, n = 3L) - mean(tail(validation_scores, n = 3L)))) + tail(validation_scores, n = 3L) - mean(tail(validation_scores, n = 3L)) + )) if (is.na(max_abs_deviation)) { convergence_counter_score <- 0L @@ -1131,7 +1212,7 @@ get_best_hyperparameter_set <- function( no_naive_improvement_counter <- stop_data$no_naive_improvement_counter if (is.null(no_naive_improvement_counter)) no_naive_improvement_counter <- 0L - if (set_data$validation_score <= 0) { + if (set_data$validation_score <= 0.0) { # The best known model does not predict better than a naive_model. no_naive_improvement_counter <- no_naive_improvement_counter + 1L } else { @@ -1145,7 +1226,8 @@ get_best_hyperparameter_set <- function( "parameter_id" = incumbent_parameter_id, "convergence_counter_score" = convergence_counter_score, "convergence_counter_parameter_id" = convergence_counter_parameter_id, - "no_naive_improvement_counter" = no_naive_improvement_counter)) + "no_naive_improvement_counter" = no_naive_improvement_counter + )) } @@ -1156,7 +1238,8 @@ get_best_hyperparameter_set <- function( score_table, n_max_bootstraps, n_intensify_step_bootstraps, - exploration_method) { + exploration_method +) { # Suppress NOTES due to non-standard evaluation in data.table param_id <- sampled <- run_id <- to_sample <- n <- NULL @@ -1167,7 +1250,8 @@ get_best_hyperparameter_set <- function( # Make a copy of the score table and keep only relevant parameter and run # identifiers. score_table <- unique(data.table::copy( - score_table[param_id %in% parameter_ids, c("param_id", "run_id")])) + score_table[param_id %in% parameter_ids, c("param_id", "run_id")] + )) # Add a sampled column that marks those elements that have been previously # sampled. @@ -1178,7 +1262,8 @@ get_best_hyperparameter_set <- function( param_id = parameter_ids, run_id = seq_len(n_max_bootstraps), KEEP.OUT.ATTRS = FALSE, - stringsAsFactors = FALSE)) + stringsAsFactors = FALSE + )) # Mark those runs that have not been sampled yet. These have an NA-value for # the sampled column. @@ -1186,7 +1271,8 @@ get_best_hyperparameter_set <- function( x = run_table, y = score_table, by = c("param_id", "run_id"), - all.x = TRUE) + all.x = TRUE + ) run_table[is.na(sampled), "sampled" := FALSE] # Add a to_sample column to mark new samples to be made. @@ -1197,8 +1283,8 @@ get_best_hyperparameter_set <- function( # Identify run identifiers. fully_sampled_runs <- sampled_runs[n == length(parameter_ids)]$run_id - partially_sampled_runs <- sampled_runs[n > 0 & n < length(parameter_ids)]$run_id - unsampled_runs <- setdiff(seq_len(n_max_bootstraps), sampled_runs[n > 0]$run_id) + partially_sampled_runs <- sampled_runs[n > 0L & n < length(parameter_ids)]$run_id + unsampled_runs <- setdiff(seq_len(n_max_bootstraps), sampled_runs[n > 0L]$run_id) # Check that there are any runs to be sampled. if (length(fully_sampled_runs) == n_max_bootstraps) return(NULL) @@ -1212,12 +1298,12 @@ get_best_hyperparameter_set <- function( } else if (exploration_method == "single_shot") { n_new_runs <- 1L } else { - n_new_runs <- max(c(1L, floor(n_intensify_step_bootstraps / 3))) + n_new_runs <- max(c(1L, as.integer(floor(n_intensify_step_bootstraps / 3.0)))) } # An exception should be made if there are no partially sampled runs. Then up # to n_intensify_step_bootstraps should be sampled. - if (length(partially_sampled_runs) == 0) n_new_runs <- n_intensify_step_bootstraps + if (length(partially_sampled_runs) == 0L) n_new_runs <- n_intensify_step_bootstraps # Iterate over the parameter identifiers and identify what runs should be # sampled. @@ -1226,30 +1312,36 @@ get_best_hyperparameter_set <- function( # hyperparameter set. current_partially_sampled_runs <- setdiff( partially_sampled_runs, - run_table[sampled == TRUE & param_id == parameter_id, ]$run_id) + run_table[sampled == TRUE & param_id == parameter_id, ]$run_id + ) # Select runs to be sampled from among those that have been sampled by other # hyperparameter sets. - if (length(current_partially_sampled_runs) > 0) { + if (length(current_partially_sampled_runs) > 0L) { run_table[ run_id %in% head(current_partially_sampled_runs, n = n_intensify_step_bootstraps) & param_id == parameter_id, - "to_sample" := TRUE] + "to_sample" := TRUE + ] } # Add completely new runs if there is room. - if (length(current_partially_sampled_runs) < n_intensify_step_bootstraps && - length(unsampled_runs) > 0) { + if ( + length(current_partially_sampled_runs) < n_intensify_step_bootstraps && + length(unsampled_runs) > 0L + ) { # Determine the number of new runs that should be added. n_current_new_runs <- min(c( n_new_runs, - n_intensify_step_bootstraps - length(current_partially_sampled_runs))) + n_intensify_step_bootstraps - length(current_partially_sampled_runs) + )) # Select up to current_new_runs to sample. run_table[ run_id %in% head(unsampled_runs, n = n_current_new_runs) & param_id == parameter_id, - "to_sample" := TRUE] + "to_sample" := TRUE + ] } } @@ -1269,7 +1361,8 @@ get_best_hyperparameter_set <- function( parameter_id_incumbent, parameter_id_challenger, exploration_method = "successive_halving", - intensify_stop_p_value) { + intensify_stop_p_value +) { # Suppress NOTES due to non-standard evaluation in data.table param_id <- p_value <- summary_score <- NULL @@ -1279,7 +1372,8 @@ get_best_hyperparameter_set <- function( data <- .compute_hyperparameter_summary_score( score_table = score_table, parameter_table = parameter_table, - optimisation_model = optimisation_model) + optimisation_model = optimisation_model + ) # Select only data concerning the incumbent and challenger sets data <- data[param_id %in% c(parameter_id_incumbent, parameter_id_challenger)] @@ -1289,7 +1383,7 @@ get_best_hyperparameter_set <- function( # Remove the worst half of performers. For simplicity we increase the number # of selectable hyperparameters by one to account for the challenger. - n_selectable <- floor((length(parameter_id_challenger)) / 2) + n_selectable <- as.integer(floor((length(parameter_id_challenger)) / 2.0)) # Select the new incumbent, which may be identical to the old incumbent. param_id_incumbent_new <- head(data, n = 1L)$param_id @@ -1304,7 +1398,8 @@ get_best_hyperparameter_set <- function( if (!"optimisation_score" %in% colnames(score_table)) { data <- .compute_hyperparameter_optimisation_score( score_table = score_table[param_id %in% c(parameter_id_incumbent, parameter_id_challenger)], - optimisation_function = optimisation_model@optimisation_function) + optimisation_function = optimisation_model@optimisation_function + ) } else { data <- data.table::copy(score_table) @@ -1314,7 +1409,8 @@ get_best_hyperparameter_set <- function( summary_data <- .compute_hyperparameter_summary_score( score_table = data, parameter_table = parameter_table, - optimisation_model = optimisation_model) + optimisation_model = optimisation_model + ) # Select only data concerning the incumbent and challenger sets summary_data <- summary_data[param_id %in% c(parameter_id_incumbent, parameter_id_challenger)] @@ -1328,15 +1424,18 @@ get_best_hyperparameter_set <- function( # Select the preliminary set of challengers. param_id_challenger_new <- setdiff( union(parameter_id_incumbent, parameter_id_challenger), - param_id_incumbent_new) + param_id_incumbent_new + ) # Compare optimisation scores and compute p-values. p_value_table <- data[ param_id %in% param_id_challenger_new, ..compare_hyperparameter_optimisation_scores( challenger_score_table = .SD, - incumbent_score_table = data[param_id == param_id_incumbent_new]), - by = c("param_id")] + incumbent_score_table = data[param_id == param_id_incumbent_new] + ), + by = c("param_id") + ] # Select parameter identifiers with p-values above the thresholds. param_id_challenger_new <- p_value_table[p_value > intensify_stop_p_value, ]$param_id @@ -1351,32 +1450,34 @@ get_best_hyperparameter_set <- function( } else { ..error_reached_unreachable_code(paste0( ".compare_hyperparameter_sets: encountered unknown exploration method: ", - exploration_method)) + exploration_method + )) } # Update param_id_challenger_new by removing the incumbent set. param_id_challenger_new <- setdiff( union(param_id_incumbent_new, param_id_challenger_new), - param_id_incumbent_new) + param_id_incumbent_new + ) return(list( "parameter_id_incumbent" = param_id_incumbent_new, - "parameter_id_challenger" = param_id_challenger_new)) + "parameter_id_challenger" = param_id_challenger_new + )) } ..compare_hyperparameter_optimisation_scores <- function( challenger_score_table, - incumbent_score_table) { + incumbent_score_table +) { # Suppress NOTES due to non-standard evaluation in data.table run_id <- optimisation_score <- NULL # Find matching bootstrap ids - run_id_match <- intersect( - challenger_score_table$run_id, - incumbent_score_table$run_id) + run_id_match <- intersect(challenger_score_table$run_id, incumbent_score_table$run_id) # Select rows that match. Note that optimisation score is updated locally to # avoid update by reference on protected slices of the score table in @@ -1404,7 +1505,8 @@ get_best_hyperparameter_set <- function( # Iterate over hyperparameters. parameter_list <- lapply( parameter_list, - ..encode_categorical_hyperparameters) + ..encode_categorical_hyperparameters + ) return(parameter_list) } @@ -1421,7 +1523,7 @@ get_best_hyperparameter_set <- function( if (x$randomise) { # Assign default range + initial value as levels, in case the hyperparameter # is randomised. - x$init_config <- factor(x$init_config, levels = c(union(x$range, x$init_config))) + x$init_config <- factor(x$init_config, levels = union(x$range, x$init_config)) } else { # Assign only the selected level as factor. x$init_config <- factor(x$init_config, levels = x$init_config) @@ -1434,47 +1536,48 @@ get_best_hyperparameter_set <- function( .set_signature_size <- function( object, - rank_table_list, - suggested_range = NULL) { - - if (is.null(suggested_range)) suggested_range <- c(1, Inf) - - # Update minimum signature size in object. - object@hyperparameters$sign_size <- min(suggested_range) + vimp_table_list, + suggested_range = NULL +) { + if (is.null(suggested_range)) suggested_range <- c(1L, Inf) # Some variable importance methods fail to produce a list (e.g. none, # signature_only, random). We create a single element list in that case. - if (is_empty(rank_table_list)) rank_table_list <- list(NULL) + if (is(vimp_table_list, "vimpTable")) vimp_table_list <- list(vimp_table_list) + if (is_empty(vimp_table_list)) vimp_table_list <- list(NULL) - # Determine the lower range of the signature. + # Update minimum signature size in object. + object@hyperparameters$sign_size <- min(suggested_range) + + # Determine the lower range of the signature. This includes any signature + # features that may exist. signature_list <- lapply( - rank_table_list, - function(rank_table, object) { - get_signature( - object = object, - rank_table = rank_table) + vimp_table_list, + function(vimp_table, object) { + object@vimp_table <- vimp_table + return(get_signature_features(object)) }, - object = object) - - # Find the minimum number of - min_signature_size <- min(sapply(signature_list, length)) - + object = object + ) + + # Determine minimum signature size. + min_signature_size <- min(lengths(signature_list)) + # Update maximum signature size in the list. object@hyperparameters$sign_size <- max(suggested_range) - # Determine the lower range of the signature. signature_list <- lapply( - rank_table_list, - function(rank_table, object) { - get_signature( - object = object, - rank_table = rank_table) + vimp_table_list, + function(vimp_table, object) { + object@vimp_table <- vimp_table + return(get_signature_features(object)) }, - object = object) - - # Update maximum signature size in the list. - max_signature_size <- max(sapply(signature_list, length)) - + object = object + ) + + # Determine maximum signature size. + max_signature_size <- max(lengths(signature_list)) + # Add minimum and maximum signature size, if necessary. if (any(suggested_range < min_signature_size)) { suggested_range <- c(suggested_range, min_signature_size) @@ -1486,8 +1589,8 @@ get_best_hyperparameter_set <- function( # Limit range to unique values within the range. suggested_range <- suggested_range[ - suggested_range >= min_signature_size & - suggested_range <= max_signature_size] + suggested_range >= min_signature_size & suggested_range <= max_signature_size + ] suggested_range <- unique(suggested_range) diff --git a/R/HyperparameterS4BayesianAdditiveRegressionTrees.R b/R/HyperparameterS4BayesianAdditiveRegressionTrees.R index c84e69c6..7978cfd2 100644 --- a/R/HyperparameterS4BayesianAdditiveRegressionTrees.R +++ b/R/HyperparameterS4BayesianAdditiveRegressionTrees.R @@ -5,10 +5,13 @@ setClass("familiarHyperparameterLearnerBART", contains = "familiarHyperparameterLearner", slots = list( "encoding_reference_table" = "ANY", - "hyperparameter_order" = "character"), + "hyperparameter_order" = "character" + ), prototype = list( "encoding_reference_table" = NULL, - "hyperparameter_order" = character())) + "hyperparameter_order" = character() + ) +) @@ -55,7 +58,8 @@ setMethod( "..train", signature( object = "familiarHyperparameterLearnerBART", - data = "data.table"), + data = "data.table" + ), function(object, data, ...) { # Check if the training data is ok. if (has_bad_training_data(object = object, data = data)) { @@ -70,7 +74,8 @@ setMethod( data = data[, mget(object@target_hyperparameters)], object = NULL, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Get the hyperparameter names from the encoded data.table. hyperparameter_names <- colnames(encoded_data$encoded_data) @@ -81,7 +86,7 @@ setMethod( hyperparameter_names <- hyperparameter_names[!invariant_columns] # Check that are any non-invariant hyperparameters. - if (length(hyperparameter_names) == 0) { + if (length(hyperparameter_names) == 0L) { return(callNextMethod()) } @@ -93,8 +98,9 @@ setMethod( quiet(model <- BART::wbart( x.train = data.frame(encoded_data$encoded_data[, mget(hyperparameter_names)]), y.train = y, - ntree = 100, - ndpost = 50)) + ntree = 100L, + ndpost = 50L + )) # Add model object@model <- model @@ -119,31 +125,30 @@ setMethod( "..predict", signature( object = "familiarHyperparameterLearnerBART", - data = "data.table"), + data = "data.table" + ), function( object, data, type = "default", percentile = NULL, - ...) { + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } + if (!model_is_trained(object)) return(callNextMethod()) # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } + if (is_empty(data)) return(callNextMethod()) # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( + prediction_table <- .get_placeholder_hyperparameter_prediction_table( object = object, data = data, - type = type) + type = type + ) # Encode categorical variables. x_encoded <- encode_categorical_variables( @@ -157,28 +162,32 @@ setMethod( # any columns that were invariant during training. quiet(predicted_scores <- predict( object = object@model, - data.frame(x_encoded[, mget(object@hyperparameter_order)]))) + data.frame(x_encoded[, mget(object@hyperparameter_order)]) + )) # Compute mean and standard deviation. - score_mean <- apply(predicted_scores, MARGIN = 2, mean) - score_sd <- apply(predicted_scores, MARGIN = 2, stats::sd) + score_mean <- apply(predicted_scores, MARGIN = 2L, mean) + score_sd <- apply(predicted_scores, MARGIN = 2L, stats::sd) # Separate by type if (type == "default") { prediction_table[, "mu" := score_mean] } else if (type == "sd") { - prediction_table[, ":="("mu" = score_mean, - "sigma" = score_sd)] + prediction_table[, ":="( + "mu" = score_mean, + "sigma" = score_sd + )] } else if (type == "percentile") { # Compute the requested percentile. score_percentile <- apply( predicted_scores, - MARGIN = 2, + MARGIN = 2L, stats::quantile, probs = percentile, - names = FALSE) + names = FALSE + ) prediction_table[, "percentile" := score_percentile] @@ -194,7 +203,8 @@ setMethod( # Set colnames. data.table::setnames( x = raw_data, - new = paste0("raw_", seq_len(ncol(raw_data)))) + new = paste0("raw_", seq_len(ncol(raw_data))) + ) # Combine with the placeholder prediction table. prediction_table <- cbind(prediction_table, raw_data) @@ -202,7 +212,8 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "..predict,familiarHyperparameterLearnerBART,data.table: ", - "Encountered an unknown prediction type: ", type)) + "Encountered an unknown prediction type: ", type + )) } return(prediction_table) diff --git a/R/HyperparameterS4GaussianProcess.R b/R/HyperparameterS4GaussianProcess.R index d2fa3baa..eefeb12c 100644 --- a/R/HyperparameterS4GaussianProcess.R +++ b/R/HyperparameterS4GaussianProcess.R @@ -52,7 +52,8 @@ setMethod( "..train", signature( object = "familiarHyperparameterLearnerLAGP", - data = "data.table"), + data = "data.table" + ), function(object, data, ...) { # Check if the training data is ok. if (has_bad_training_data(object = object, data = data)) { @@ -67,7 +68,8 @@ setMethod( data = data[, mget(object@target_hyperparameters)], object = NULL, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Get optimisation score as response. y <- data$optimisation_score @@ -77,7 +79,8 @@ setMethod( # information at this point. object@model <- list( "X" = as.matrix(encoded_data$encoded_data), - "Z" = y) + "Z" = y + ) # Set reference table for encoding. object@encoding_reference_table <- encoded_data$reference_table @@ -96,26 +99,24 @@ setMethod( "..predict", signature( object = "familiarHyperparameterLearnerLAGP", - data = "data.table"), + data = "data.table" + ), function(object, data, type = "default", ...) { # Check that required packages are loaded and installed. require_package(object, "predict") # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } + if (!model_is_trained(object)) return(callNextMethod()) # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } + if (is_empty(data)) return(callNextMethod()) # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( + prediction_table <- .get_placeholder_hyperparameter_prediction_table( object = object, data = data, - type = type) + type = type + ) # Encode categorical variables. x_encoded <- encode_categorical_variables( @@ -128,14 +129,15 @@ setMethod( # Update the end-size parameter, if the number of instances is # smaller than the default of 51. Note that we already capture # end_size of 7 or smaller using has_bad_training_data. - end_size <- ifelse(nrow(object@model$X) < 51, nrow(object@model$X) - 1, 50) + end_size <- ifelse(nrow(object@model$X) < 51L, nrow(object@model$X) - 1L, 50L) # Infer scores for the hyperparameters. quiet(predicted_scores <- laGP::aGP( X = object@model$X, Z = object@model$Z, XX = as.matrix(x_encoded), - end = end_size)) + end = end_size + )) # Compute mean and standard deviation. score_mean <- predicted_scores$mean @@ -145,16 +147,20 @@ setMethod( if (type == "default") { prediction_table[, "mu" := score_mean] } else if (type == "sd") { - prediction_table[, ":="("mu" = score_mean, - "sigma" = score_sd)] + prediction_table[, ":="( + "mu" = score_mean, + "sigma" = score_sd + )] } else if (type %in% c("percentile", "raw")) { ..error_reached_unreachable_code(paste0( "..predict,familiarHyperparameterLearnerLAGP,data.table: ", - "Encountered a prediction type that is not supported by the model: ", type)) + "Encountered a prediction type that is not supported by the model: ", type + )) } else { ..error_reached_unreachable_code(paste0( "..predict,familiarHyperparameterLearnerLAGP,data.table: ", - "Encountered an unknown prediction type: ", type)) + "Encountered an unknown prediction type: ", type + )) } return(prediction_table) @@ -168,17 +174,14 @@ setMethod( "has_bad_training_data", signature( object = "familiarHyperparameterLearnerLAGP", - data = "data.table"), + data = "data.table" + ), function(object, data, ...) { # Perform the general check first. - if (callNextMethod()) { - return(TRUE) - } + if (callNextMethod()) return(TRUE) # For Gaussian process at least eight instances should be present. - if (nrow(data) < 8) { - return(TRUE) - } + if (nrow(data) < 8L) return(TRUE) return(FALSE) } diff --git a/R/HyperparameterS4Ranger.R b/R/HyperparameterS4Ranger.R index 032f43c9..ac16cc5f 100644 --- a/R/HyperparameterS4Ranger.R +++ b/R/HyperparameterS4Ranger.R @@ -49,7 +49,8 @@ setMethod( "..train", signature( object = "familiarHyperparameterLearnerRanger", - data = "data.table"), + data = "data.table" + ), function(object, data, ...) { # Check if the training data is ok. if (has_bad_training_data(object = object, data = data)) { @@ -62,12 +63,13 @@ setMethod( # Parse formula. formula <- stats::reformulate( termlabels = object@target_hyperparameters, - response = "optimisation_score") + response = "optimisation_score" + ) # Set hyperparameters of the random forest. - n_tree <- 400 + n_tree <- 400L n_train <- nrow(data) - sample_fraction <- max(c(0.3, min(c(1, 1 / (0.025 * n_train))))) + sample_fraction <- max(c(0.3, min(c(1.0, 1.0 / (0.025 * n_train))))) # Train a conventional random forest model <- ranger::ranger(formula, @@ -75,7 +77,8 @@ setMethod( num.trees = n_tree, sample.fraction = sample_fraction, num.threads = 1L, - verbose = FALSE) + verbose = FALSE + ) # Add model object@model <- model @@ -93,26 +96,24 @@ setMethod( setMethod( "..predict", signature( object = "familiarHyperparameterLearnerRanger", - data = "data.table"), + data = "data.table" + ), function(object, data, type = "default", percentile = NULL, ...) { # Check that required packages are loaded and installed. require_package(object, "predict") # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } + if (!model_is_trained(object)) return(callNextMethod()) # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } + if (is_empty(data)) return(callNextMethod()) # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( + prediction_table <- .get_placeholder_hyperparameter_prediction_table( object = object, data = data, - type = type) + type = type + ) # Make predictions. predicted_scores <- predict( @@ -124,8 +125,8 @@ setMethod( )$predictions # Compute mean and standard deviation. - score_mean <- apply(predicted_scores, MARGIN = 1, mean) - score_sd <- apply(predicted_scores, MARGIN = 1, stats::sd) + score_mean <- apply(predicted_scores, MARGIN = 1L, mean) + score_sd <- apply(predicted_scores, MARGIN = 1L, stats::sd) # Separate by type if (type == "default") { @@ -134,15 +135,18 @@ setMethod( } else if (type == "sd") { prediction_table[, ":="( "mu" = score_mean, - "sigma" = score_sd)] + "sigma" = score_sd + )] } else if (type == "percentile") { # Compute the requested percentile. score_percentile <- apply( predicted_scores, - MARGIN = 1, stats::quantile, + MARGIN = 1L, + stats::quantile, probs = percentile, - names = FALSE) + names = FALSE + ) prediction_table[, "percentile" := score_percentile] @@ -156,7 +160,8 @@ setMethod( # Set colnames. data.table::setnames( x = raw_data, - new = paste0("raw_", seq_len(ncol(raw_data)))) + new = paste0("raw_", seq_len(ncol(raw_data))) + ) # Combine with the placeholder prediction table. prediction_table <- cbind(prediction_table, raw_data) @@ -164,7 +169,8 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "..predict,familiarHyperparameterLearnerRanger,data.table: ", - "Encountered an unknown prediction type: ", type)) + "Encountered an unknown prediction type: ", type + )) } return(prediction_table) diff --git a/R/Imputation.R b/R/Imputation.R index f312c913..6ee9b1f1 100644 --- a/R/Imputation.R +++ b/R/Imputation.R @@ -5,7 +5,8 @@ NULL .get_available_imputation_methods <- function() { return(c( .get_available_simple_imputation_methods(), - .get_available_lasso_imputation_methods())) + .get_available_lasso_imputation_methods() + )) } .get_available_simple_imputation_methods <- function() { @@ -22,33 +23,41 @@ setClass( slots = list( "method" = "character", "type" = "character", - "required_features" = "ANY"), + "required_features" = "ANY" + ), prototype = list( "method" = NA_character_, "type" = NA_character_, - "required_features" = NULL)) + "required_features" = NULL + ) +) setClass( "featureInfoParametersImputationNone", contains = "featureInfoParametersImputation", slots = list("reason" = "ANY"), - prototype = list("reason" = NULL)) + prototype = list("reason" = NULL) +) setClass( "featureInfoParametersImputationSimple", contains = "featureInfoParametersImputation", slots = list("model" = "ANY"), - prototype = list("model" = NULL)) + prototype = list("model" = NULL) +) setClass( "featureInfoParametersImputationLasso", contains = "featureInfoParametersImputation", slots = list( "simple" = "ANY", - "model" = "ANY"), + "model" = "ANY" + ), prototype = list( "simple" = NULL, - "model" = NULL)) + "model" = NULL + ) +) setClass( "featureInfoParametersImputationContainer", @@ -56,11 +65,14 @@ setClass( slots = list( "type" = "character", "required_features" = "ANY", - "model" = "ANY"), + "model" = "ANY" + ), prototype = list( "type" = NA_character_, "required_features" = NULL, - "model" = NULL)) + "model" = NULL + ) +) @@ -68,7 +80,8 @@ create_imputation_parameter_skeleton <- function( feature_info_list, feature_names = NULL, imputation_method, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Creates a skeleton for the provided imputation method. # Determine feature names from the feature info list, if provided. @@ -77,7 +90,8 @@ create_imputation_parameter_skeleton <- function( # Select only features that appear in the feature info list. feature_names <- intersect( names(feature_info_list), - feature_names) + feature_names + ) # Skip step if no feature info objects are updated. if (is_empty(feature_names)) return(feature_info_list) @@ -86,14 +100,16 @@ create_imputation_parameter_skeleton <- function( .check_parameter_value_is_valid( x = imputation_method, var_name = "imputation_method", - values = .get_available_imputation_methods()) + values = .get_available_imputation_methods() + ) # Update familiar info objects with a feature normalisation skeleton. updated_feature_info <- fam_lapply( X = feature_info_list[feature_names], FUN = .create_imputation_parameter_skeleton, method = imputation_method, - .override_existing = .override_existing) + .override_existing = .override_existing + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -109,11 +125,14 @@ create_imputation_parameter_skeleton <- function( .create_imputation_parameter_skeleton <- function( feature_info, method, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Check if imputation data was already completed, and does not require being # determined anew. - if (feature_info_complete(feature_info@imputation_parameters) - && !.override_existing) { + if ( + feature_info_complete(feature_info@imputation_parameters) + && !.override_existing + ) { return(feature_info) } @@ -122,7 +141,8 @@ create_imputation_parameter_skeleton <- function( feature_name = feature_info@name, feature_type = feature_info@feature_type, available = is_available(feature_info), - method = method) + method = method + ) # Update imputation_parameters slot. feature_info@imputation_parameters <- object @@ -136,7 +156,8 @@ create_imputation_parameter_skeleton <- function( feature_name, feature_type = "numeric", available = TRUE, - method) { + method +) { # This is the lowest level function for creating imputation parameter # skeletons. @@ -144,17 +165,20 @@ create_imputation_parameter_skeleton <- function( if (!available || method == "none") { object <- methods::new( "featureInfoParametersImputationNone", - reason = "feature was omitted prior to transformation") + reason = "feature was omitted prior to transformation" + ) } else if (method %in% .get_available_simple_imputation_methods()) { object <- methods::new( "featureInfoParametersImputationSimple", - "method" = method) + "method" = method + ) } else if (method %in% .get_available_lasso_imputation_methods()) { object <- methods::new( "featureInfoParametersImputationLasso", - "method" = method) + "method" = method + ) } else if (method == "container") { object <- methods::new("featureInfoParametersImputationContainer") @@ -162,7 +186,8 @@ create_imputation_parameter_skeleton <- function( } else { ..error_reached_unreachable_code(paste0( "..create_imputation_parameter_skeleton: encountered an unknown imputation method: ", - paste_s(method))) + paste_s(method) + )) } # Set the name and type of the object. @@ -181,7 +206,8 @@ add_imputation_info <- function( cl = NULL, feature_info_list, data, - verbose = FALSE) { + verbose = FALSE +) { # Determine normalisation parameters and add them to the feature_info_list. # Find feature columns. @@ -191,7 +217,8 @@ add_imputation_info <- function( if (!(setequal(feature_names, get_available_features(feature_info_list = feature_info_list)))) { ..error_reached_unreachable_code(paste0( "add_imputation_info: features in data and the feature info list ", - "are expect to be the same, but were not.")) + "are expect to be the same, but were not." + )) } # Iterate over features and train univariate imputation. @@ -202,7 +229,8 @@ add_imputation_info <- function( mask_data = data@data[, mget(feature_names)], MoreArgs = list("data" = data), progress_bar = verbose, - chopchop = TRUE) + chopchop = TRUE + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -214,16 +242,18 @@ add_imputation_info <- function( imputed_data <- .impute_features( data = data, feature_info_list = feature_info_list, - initial_imputation = TRUE) + initial_imputation = TRUE + ) # Check if there are any features that lack imputation (are of the # featureInfoParametersImputationNone class). These are subsequently skipped # to avoid having to rely on potentially missing data to infer other features. feature_names <- unname(feature_names[!sapply( feature_info_list[feature_names], - function(x) (is(x@imputation_parameters, "featureInfoParametersImputationNone")))]) + function(x) (is(x@imputation_parameters, "featureInfoParametersImputationNone")) + )]) - if (length(feature_names) > 0) { + if (length(feature_names) > 0L) { # Iterate over features again to train multivariate imputation models. updated_feature_info <- fam_mapply( cl = cl, @@ -232,7 +262,8 @@ add_imputation_info <- function( mask_data = data@data[, mget(feature_names)], MoreArgs = list("data" = imputed_data), progress_bar = verbose, - chopchop = TRUE) + chopchop = TRUE + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -249,13 +280,15 @@ add_imputation_info <- function( .add_imputation_info <- function( feature_info, data, - mask_data) { + mask_data +) { # Pass to underlying function that adds the feature info. object <- add_feature_info_parameters( object = feature_info@imputation_parameters, data = data, - mask_data = mask_data) + mask_data = mask_data + ) # Update normalisation_parameters slot. feature_info@imputation_parameters <- object @@ -271,7 +304,8 @@ add_imputation_info <- function( feature_info_list, initial_imputation, mask_data = NULL, - verbose = FALSE) { + verbose = FALSE +) { # Check if data is empty if (is_empty(data)) return(data) @@ -285,6 +319,15 @@ add_imputation_info <- function( # Use data variable for masking uncensored data. if (is.null(mask_data)) mask_data <- data + # Check if any features have missing values, otherwise we can just skip + # imputation. + has_missing_values <- sapply( + X = mask_data@data[, mget(feature_names)], + FUN = function(x) (return(sum(!is_valid_data(x)))) + ) > 0L + + if (!any(has_missing_values)) return(data) + # Impute data. imputation_list <- fam_mapply( cl = cl, @@ -293,9 +336,11 @@ add_imputation_info <- function( mask_data = mask_data@data[, mget(feature_names)], MoreArgs = list( "data" = data, - "initial_imputation" = initial_imputation), + "initial_imputation" = initial_imputation + ), progress_bar = verbose, - chopchop = TRUE) + chopchop = TRUE + ) # Update name of data in columns. names(imputation_list) <- feature_names @@ -303,7 +348,8 @@ add_imputation_info <- function( # Update with replacement in the data object. data <- update_with_replacement( data = data, - replacement_list = imputation_list) + replacement_list = imputation_list + ) return(data) } @@ -314,12 +360,14 @@ add_imputation_info <- function( feature_info, data, mask_data, - initial_imputation) { + initial_imputation +) { # Find uncensored data. uncensored_data <- .mask_data_to_mask( mask_data = mask_data, - type = feature_info@imputation_parameters@type) + type = feature_info@imputation_parameters@type + ) # Return data as is, if there is no censored data. if (all(uncensored_data)) { @@ -331,7 +379,8 @@ add_imputation_info <- function( object = feature_info@imputation_parameters, data = data, mask_data = mask_data, - initial_imputation = initial_imputation) + initial_imputation = initial_imputation + ) return(y) } @@ -362,12 +411,14 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersImputation", - data = "ANY"), + data = "ANY" + ), function( object, data, mask_data, - ...) { + ... + ) { # Check if all required parameters have been set. if (feature_info_complete(object)) return(object) @@ -378,7 +429,8 @@ setMethod( object <- ..create_imputation_parameter_skeleton( feature_name = object@name, feature_type = object@type, - method = "none") + method = "none" + ) object@reason <- "insufficient data to infer imputation parameters" @@ -388,7 +440,8 @@ setMethod( # Find uncensored data. mask_data <- .mask_data_to_mask( mask_data = mask_data, - type = object@type) + type = object@type + ) # If there are no uncensored data, we cannot determine imputation # parameters. @@ -397,7 +450,8 @@ setMethod( object <- ..create_imputation_parameter_skeleton( feature_name = object@name, feature_type = object@type, - method = "none") + method = "none" + ) object@reason <- "insufficient data to infer imputation parameters" @@ -415,12 +469,14 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersImputationSimple", - data = "dataObject"), + data = "dataObject" + ), function( object, data, mask_data, - ...) { + ... + ) { # Check if all required parameters have been set. if (feature_info_complete(object)) return(object) @@ -435,10 +491,11 @@ setMethod( # Find uncensored data. mask_data <- .mask_data_to_mask( mask_data = mask_data, - type = object@type) + type = object@type + ) # Select data. - y <- data@data[mask_data, mget(object@name)][[1]] + y <- data@data[mask_data, mget(object@name)][[1L]] # Select value. if (object@type == "numeric") { @@ -470,12 +527,14 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersImputationLasso", - data = "dataObject"), + data = "dataObject" + ), function( object, data, mask_data, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table name <- NULL @@ -498,19 +557,21 @@ setMethod( object@simple <- ..create_imputation_parameter_skeleton( feature_name = object@name, feature_type = object@type, - method = "simple") + method = "simple" + ) # Determine parameters. object@simple <- add_feature_info_parameters( object = object@simple, data = data, - mask_data = mask_data) + mask_data = mask_data + ) return(object) } # Determine if more than one feature is present. - if (get_n_features(data) == 1) { + if (get_n_features(data) == 1L) { # Switch to simple univariate inference only, in case only one feature is # present. return(object@simple) @@ -519,7 +580,8 @@ setMethod( # Find uncensored data. mask_data <- .mask_data_to_mask( mask_data = mask_data, - type = object@type) + type = object@type + ) # Select finite data. distribution <- ifelse(object@type == "numeric", "gaussian", "multinomial") @@ -527,7 +589,8 @@ setMethod( # Check that the glmnet package is installed. require_package( x = "glmnet", - purpose = "to impute data using lasso regression") + purpose = "to impute data using lasso regression" + ) # Select known data as response variable. y <- data@data[[object@name]][mask_data] @@ -541,7 +604,8 @@ setMethod( data = x, object = NULL, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Extract data table with contrasts. x <- encoded_data$encoded_data @@ -554,11 +618,13 @@ setMethod( x = as.matrix(x@data[mask_data, mget(get_feature_columns(x))]), y = y, family = distribution, - alpha = 1, + alpha = 1L, standardize = FALSE, - nfolds = min(sum(mask_data), 20), - parallel = FALSE), - error = identity)) + nfolds = min(sum(mask_data), 20L), + parallel = FALSE + ), + error = identity + )) if (inherits(lasso_model, "error")) return(object@simple) @@ -572,22 +638,24 @@ setMethod( # Read coefficient lists coef_list <- tryCatch( coef(lasso_model, s = "lambda.1se"), - error = identity) + error = identity + ) if (inherits(coef_list, "error")) return(object@simple) # Parse into matrix and retrieve row names coef_mat <- sapply(coef_list, as.matrix) - rownames(coef_mat) <- dimnames(coef_list[[1]])[[1]] + rownames(coef_mat) <- dimnames(coef_list[[1L]])[[1L]] # Calculate score - score <- apply(abs(coef_mat), 1, max) + score <- apply(abs(coef_mat), 1L, max) } else { # Read coefficient lists coef_list <- tryCatch( coef(lasso_model, s = "lambda.1se"), - error = identity) + error = identity + ) if (inherits(coef_list, "error")) return(object@simple) @@ -595,13 +663,14 @@ setMethod( coef_mat <- as.matrix(coef_list) # Calculate score - score <- abs(coef_mat)[, 1] + score <- abs(coef_mat)[, 1L] } # Parse score to data.table vimp_table <- data.table::data.table( "score" = score, - "name" = names(score)) + "name" = names(score) + ) # Throw out the intercept and elements with 0.0 coefficients vimp_table <- vimp_table[name != "(Intercept)" & score != 0.0] @@ -612,7 +681,8 @@ setMethod( vimp_table = vimp_table, encoding_table = encoded_data$reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) # Find the original names vimp_table <- get_vimp_table(vimp_object, "decoded") @@ -632,14 +702,18 @@ setMethod( data = x, object = NULL, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Extract data table with contrasts. - x <- encoded_data$encoded_data@data[mask_data, mget(get_feature_columns(encoded_data$encoded_data))] + x <- encoded_data$encoded_data@data[ + mask_data, + mget(get_feature_columns(encoded_data$encoded_data)) + ] # Check the number of columns in train_data. glmnet wants at least two # columns. - if (ncol(x) == 1) x[, "bogus__variable__" := 0.0] + if (ncol(x) == 1L) x[, "bogus__variable__" := 0.0] # Force x locally, otherwise an error may occur. x <- as.matrix(x) @@ -651,8 +725,10 @@ setMethod( y = y, family = distribution, lambda = lasso_model$lambda.1se, - standardize = FALSE), - error = identity)) + standardize = FALSE + ), + error = identity + )) if (inherits(coef_list, "error")) return(object@simple) @@ -677,13 +753,14 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersImputationNone", - data = "dataObject"), + data = "dataObject" + ), function( object, data, mask_data, - ...) { - + ... + ) { return(data@data[[object@name]]) } ) @@ -694,17 +771,20 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersImputationSimple", - data = "dataObject"), + data = "dataObject" + ), function( object, data, mask_data, - ...) { + ... + ) { # Find uncensored data. mask_data <- .mask_data_to_mask( mask_data = mask_data, - type = object@type) + type = object@type + ) # Return data as is, if there is no censored data. if (all(mask_data)) return(data@data[[object@name]]) @@ -726,13 +806,15 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersImputationLasso", - data = "dataObject"), + data = "dataObject" + ), function( object, data, mask_data, initial_imputation, - ...) { + ... + ) { # For initial imputation use univariate imputer. if (initial_imputation) { @@ -740,13 +822,15 @@ setMethod( object = object@simple, data = data, mask_data = mask_data, - initial_imputation = initial_imputation)) + initial_imputation = initial_imputation + )) } # Find uncensored data. mask_data <- .mask_data_to_mask( mask_data = mask_data, - type = object@type) + type = object@type + ) # Return data as is, if there is no censored data. if (all(mask_data)) return(data@data[[object@name]]) @@ -757,13 +841,15 @@ setMethod( object = object@simple, data = data, mask_data = mask_data, - initial_imputation = initial_imputation)) + initial_imputation = initial_imputation + )) } # Check that the glmnet package is installed. require_package( x = "glmnet", - purpose = "to impute data using lasso regression") + purpose = "to impute data using lasso regression" + ) # Get intended data. y <- data@data[[object@name]] @@ -776,13 +862,17 @@ setMethod( data = x, object = NULL, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Extract data table with contrasts. - x <- encoded_data$encoded_data@data[!mask_data, mget(get_feature_columns(encoded_data$encoded_data))] + x <- encoded_data$encoded_data@data[ + !mask_data, + mget(get_feature_columns(encoded_data$encoded_data)) + ] # Check if the validation data has two or more columns - if (ncol(x) == 1) x[, "bogus__variable__" := 0.0] + if (ncol(x) == 1L) x[, "bogus__variable__" := 0.0] # Force x locally, otherwise an error may occur. x <- as.matrix(x) @@ -794,7 +884,8 @@ setMethod( y[!mask_data] <- drop(predict( object = object@model, newx = x, - type = response_type)) + type = response_type + )) return(y) } @@ -807,18 +898,21 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersImputationContainer", - data = "dataObject"), + data = "dataObject" + ), function( object, data, mask_data, initial_imputation, - ...) { + ... + ) { # Find uncensored data. uncensored_data <- .mask_data_to_mask( mask_data = mask_data, - type = object@type) + type = object@type + ) # Return data as is, if there is no censored data. if (all(uncensored_data)) return(data@data[[object@name]]) @@ -844,16 +938,19 @@ setMethod( apply_feature_info_parameters, data = censored_data, mask_data = mask_data[!uncensored_data], - initial_imputation = initial_imputation) + initial_imputation = initial_imputation + ) # Set as data.table. imputed_values <- data.table::as.data.table(imputed_values) # Aggregate by row. - imputed_values <- imputed_values[, list( - "value" = aggregation_function(do.call(c, .SD))), + imputed_values <- imputed_values[ + , + list("value" = aggregation_function(do.call(c, .SD))), .SDcols = colnames(imputed_values), - by = seq_len(nrow(imputed_values))] + by = seq_len(nrow(imputed_values)) + ] # Replace censored values in y. y[!uncensored_data] <- imputed_values$value @@ -883,7 +980,8 @@ setMethod( ..collect_and_aggregate_imputation_info <- function( feature_info_list, feature_name, - feature_type) { + feature_type +) { # Aggregate transformation parameters. This function exists so that it can be # tested as part of a unit test. @@ -891,7 +989,8 @@ setMethod( container_object <- ..create_imputation_parameter_skeleton( feature_name = feature_name, feature_type = feature_type, - method = "container") + method = "container" + ) # Extract and store imputation objects. container_object@model <- lapply( @@ -902,20 +1001,24 @@ setMethod( if (is(x@imputation_parameters, "featureInfoParametersImputationNone")) return(NULL) return(x@imputation_parameters) - }) + } + ) if (is_empty(container_object@model)) { container_object@model <- list( ..create_imputation_parameter_skeleton( feature_name = feature_name, feature_type = feature_type, - method = "none")) + method = "none" + ) + ) } # Set required parameters. container_object@required_features <- unique(unlist(lapply( container_object@model, - function(x) (x@required_features)))) + function(x) (x@required_features) + ))) # Mark as complete. container_object@complete <- TRUE diff --git a/R/Iterations.R b/R/Iterations.R index b146999c..88cf60a7 100644 --- a/R/Iterations.R +++ b/R/Iterations.R @@ -1,6 +1,6 @@ #' Internal function for creating or retrieving iteration data #' -#' @param file_paths Set of paths to relevant files and directories. +#' @param file_paths Path to directory where iteration files are stored. #' @param data Data set as loaded using the `.load_data` function. #' @param experiment_setup data.table with subsampler information at different #' levels of the experimental design. @@ -27,16 +27,19 @@ experiment_setup, settings, message_indent = 0L, - verbose = TRUE) { + verbose = TRUE +) { # Get project iterations and project id if (.experimental_design_is_file( file_dir = file_paths$iterations_dir, - experimental_design = settings$data$exp_design)) { + experimental_design = settings$data$exp_design + )) { # Load list from user-provided file. iteration_list <- .load_iterations( file_dir = file_paths$iterations_dir, - iteration_file = settings$data$exp_design) + iteration_file = settings$data$exp_design + ) # Extract iterations, project id and experiment setup from the file. new_iteration_list <- iteration_list$iteration_list @@ -56,7 +59,8 @@ override_external_validation = TRUE, iteration_list = iteration_list$iteration_list, message_indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Save to file and without generating new project id project_id <- .save_iterations( @@ -65,7 +69,8 @@ project_id = iteration_list$project_id, experiment_setup = experiment_setup, message_indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else { # Create training and validation data iterations @@ -74,7 +79,8 @@ experiment_setup = experiment_setup, settings = settings, message_indent = message_indent, - verbose = verbose) + verbose = verbose + ) # Save to file and generate project id project_id <- .save_iterations( @@ -82,25 +88,29 @@ iteration_list = new_iteration_list, experiment_setup = experiment_setup, message_indent = message_indent, - verbose = verbose) + verbose = verbose + ) } } return(list( "iter_list" = new_iteration_list, "project_id" = project_id, - "experiment_setup" = experiment_setup)) + "experiment_setup" = experiment_setup + )) } .get_iteration_file_name <- function( file_paths, - project_id) { + project_id +) { return(file.path( file_paths$iterations_dir, - paste0(project_id, "_iterations.RDS"))) + paste0(project_id, "_iterations.RDS") + )) } @@ -134,20 +144,21 @@ iter_files <- list.files( path = file_dir, pattern = "_iterations.RDS", - full.names = FALSE) + full.names = FALSE + ) # If no files match the iteration files, return a FALSE - if (length(iter_files) == 0) { + if (length(iter_files) == 0L) { return(list("iteration_file_exists" = FALSE)) } # Extract date strings from file name file_table <- data.table::data.table("file_name" = iter_files) - file_table[, "file_prefix_num" := strsplit(x = file_name, split = "_", fixed = TRUE)[[1]][1], by = file_name] + file_table[, "file_prefix_num" := strsplit(x = file_name, split = "_", fixed = TRUE)[[1L]][1L], by = file_name] file_table <- file_table[!is.na(file_prefix_num), ] # If no date strings were found (i.e. backup files), return a FALSE - if (nrow(file_table) == 0) { + if (nrow(file_table) == 0L) { return(list("iteration_file_exists" = FALSE)) } @@ -155,15 +166,16 @@ file_table[, "file_prefix_num" := as.numeric(file_prefix_num)] # From list of iteration files present in the data. - select_file <- file_table[file_prefix_num == max(file_prefix_num), ]$file_name[1] - project_id <- file_table[file_prefix_num == max(file_prefix_num), ]$file_prefix_num[1] + select_file <- file_table[file_prefix_num == max(file_prefix_num), ]$file_name[1L] + project_id <- file_table[file_prefix_num == max(file_prefix_num), ]$file_prefix_num[1L] # Ask whether a new file should be used input_answer <- "dummy" while (!tolower(input_answer) %in% c("y", "n")) { input_answer <- readline(prompt = paste0( "Latest iteration file found is: ", select_file, - ". Do you wish to create a new iterations file [y/n]?: ")) + ". Do you wish to create a new iterations file [y/n]?: " + )) if (!tolower(input_answer) %in% c("y", "n")) { message("Only y (yes) or n (no) are valid entries. Please retry.") @@ -184,19 +196,21 @@ return(list( "iteration_file_exists" = TRUE, "iteration_list" = iteration_list, - "project_id" = project_id)) + "project_id" = project_id + )) } else { return(list( "iteration_file_exists" = TRUE, "iteration_list" = iteration_list$iteration_list, - "project_id" = project_id)) + "project_id" = project_id + )) } } } else { # From user-provided iteration file select_file <- basename(iteration_file) - project_id <- as.numeric(strsplit(x = select_file, split = "_", fixed = TRUE)[[1]][1]) + project_id <- as.numeric(strsplit(x = select_file, split = "_", fixed = TRUE)[[1L]][1L]) # Attempt to load the user-provided iteration file. if (file.exists(iteration_file)) { @@ -208,21 +222,23 @@ iteration_list <- readRDS(file = file.path(file_dir, select_file)) } else { - stop(paste0("External iteration file could not be found: ", iteration_file)) + ..error(paste0("External iteration file could not be found: ", iteration_file)) } if (is.null(iteration_list$experiment_setup)) { - stop(paste0( + ..error(paste0( "The provided external iteration file lacks an experiment setup table ", "and cannot be used. The most likely cause is that the iteration file ", - "was generated with familiar version < 0.0.0.41.")) + "was generated with familiar version < 0.0.0.41." + )) } return(list( "iteration_file_exists" = TRUE, "iteration_list" = iteration_list$iteration_list, "project_id" = project_id, - "experiment_setup" = iteration_list$experiment_setup)) + "experiment_setup" = iteration_list$experiment_setup + )) } } @@ -234,7 +250,8 @@ override_external_validation = FALSE, iteration_list = NULL, message_indent = 0L, - verbose = TRUE) { + verbose = TRUE +) { # Suppress NOTES due to non-standard evaluation in data.table main_data_id <- batch_id <- NULL @@ -245,6 +262,13 @@ id_columns <- get_id_columns(id_depth = "series") batch_id_column <- get_id_columns(id_depth = "batch") + # Start random stream + if (is.null(settings$data$iteration_seed)) { + rstream_object <- NULL + } else { + rstream_object <- .start_random_number_stream(seed = settings$data$iteration_seed) + } + # Generate new iterations ---------------------------------------------------- if (is.null(iteration_list)) { @@ -253,7 +277,8 @@ logger_message( "Creating iterations: Starting creation of iterations.", indent = message_indent, - verbose = verbose) + verbose = verbose + ) while (length(iteration_list) < length(main_data_ids)) { for (curr_main_data_id in main_data_ids) { @@ -264,17 +289,20 @@ if (!is.null(iteration_list[[as.character(curr_main_data_id)]])) next # Check if the required reference data exists - curr_ref_data_id <- subset_table$ref_data_id[1] - curr_pert_method <- subset_table$perturb_method[1] - if (is.null(iteration_list[[as.character(curr_ref_data_id)]]) && - curr_pert_method != "main") { + curr_ref_data_id <- subset_table$ref_data_id[1L] + curr_pert_method <- subset_table$perturb_method[1L] + if ( + is.null(iteration_list[[as.character(curr_ref_data_id)]]) && + curr_pert_method != "main" + ) { next } # Determine number of reference iterations ref_run_list <- .get_run_list( iteration_list = iteration_list, - data_id = curr_ref_data_id) + data_id = curr_ref_data_id + ) # Create an empty run list run_list <- list() @@ -285,7 +313,7 @@ ## New main data ----------------------------------------------------- # Determine if external validation is required - external_validation_required <- subset_table$external_validation[1] + external_validation_required <- subset_table$external_validation[1L] # In case of external validation, find cohorts matching the # train_cohorts. @@ -295,7 +323,8 @@ if (is.null(settings$data$train_cohorts) && external_validation_required) { logger_stop(paste0( "Creating iterations: Training cohorts were not provided, ", - "but are required for external validation.")) + "but are required for external validation." + )) } else if (is.null(settings$data$train_cohorts)) { # Assume that all data is used for training when external validation @@ -327,7 +356,7 @@ } else { # Extract validation cohorts from data validation_cohorts <- all_cohorts[!all_cohorts %in% train_cohorts] - if (length(validation_cohorts) == 0) { + if (length(validation_cohorts) == 0L) { logger_warning("Creating iterations: No validation cohorts could be found.") } } @@ -342,11 +371,11 @@ valid_samples <- list() # Add training cohort subjects to train_samples - train_samples[[1]] <- unique(data[batch_id %in% train_cohorts, mget(id_columns)]) + train_samples[[1L]] <- unique(data[batch_id %in% train_cohorts, mget(id_columns)]) # Add validation cohort subjects to valid_samples (if present) - if (length(validation_cohorts) > 0) { - valid_samples[[1]] <- unique(data[batch_id %in% validation_cohorts, mget(id_columns)]) + if (length(validation_cohorts) > 0L) { + valid_samples[[1L]] <- unique(data[batch_id %in% validation_cohorts, mget(id_columns)]) } # Generate a run list for the "main" data perturbation @@ -355,11 +384,14 @@ train_samples = train_samples, valid_samples = valid_samples, can_pre_process = TRUE, - perturbation = curr_pert_method) + perturbation = curr_pert_method + ) # Clean variables - rm(external_validation_required, train_cohorts, train_samples, - validation_cohorts, valid_samples) + rm( + external_validation_required, train_cohorts, train_samples, + validation_cohorts, valid_samples + ) } # Check if the current perturbation method is "imbalance part" @@ -373,9 +405,12 @@ partition <- .create_balanced_partitions( sample_identifiers = .get_sample_identifiers( run = run, - train_or_validate = "train"), + train_or_validate = "train" + ), settings = settings, - data = data) + data = data, + rstream_object = rstream_object + ) # Append runs to the run list run_list <- c( @@ -386,7 +421,9 @@ train_samples = partition, valid_samples = list(), can_pre_process = TRUE, - perturbation = curr_pert_method)) + perturbation = curr_pert_method + ) + ) } # Clean variables @@ -399,7 +436,7 @@ ## New bootstrap data ------------------------------------------------ # Determine number of bootstrap iterations - n_iter <- subset_table$perturb_n_rep[1] + n_iter <- subset_table$perturb_n_rep[1L] # Iterate over runs of the reference data for (run in ref_run_list) { @@ -408,11 +445,14 @@ bt_iter_list <- .create_bootstraps( sample_identifiers = .get_sample_identifiers( run = run, - train_or_validate = "train"), + train_or_validate = "train" + ), n_iter = n_iter, settings = settings, - data = data) - + data = data, + rstream_object = rstream_object + ) + # Append runs to the run list run_list <- c( run_list, @@ -422,7 +462,9 @@ train_samples = bt_iter_list$train_list, valid_samples = bt_iter_list$valid_list, can_pre_process = curr_pert_method == "full_bootstrap", - perturbation = curr_pert_method)) + perturbation = curr_pert_method + ) + ) } # Clean variables @@ -434,8 +476,8 @@ ## New cross-validation data ----------------------------------------- # Determine number of cross-validation repetitions and folds - n_rep <- subset_table$perturb_n_rep[1] - n_folds <- subset_table$perturb_n_folds[1] + n_rep <- subset_table$perturb_n_rep[1L] + n_folds <- subset_table$perturb_n_folds[1L] # Iterate over runs of the reference data for (run in ref_run_list) { @@ -443,11 +485,14 @@ cv_iter_list <- .create_repeated_cv( sample_identifiers = .get_sample_identifiers( run = run, - train_or_validate = "train"), + train_or_validate = "train" + ), n_rep = n_rep, n_folds = n_folds, settings = settings, - data = data) + data = data, + rstream_object = rstream_object + ) # Append runs to the run list run_list <- c( @@ -458,7 +503,9 @@ train_samples = cv_iter_list$train_list, valid_samples = cv_iter_list$valid_list, can_pre_process = TRUE, - perturbation = curr_pert_method)) + perturbation = curr_pert_method + ) + ) } # Clean variables @@ -474,13 +521,16 @@ # Find the available samples. sample_identifiers <- .get_sample_identifiers( run = run, - train_or_validate = "train") + train_or_validate = "train" + ) # Create leave-one-out cross-validation. cv_iter_list <- .create_loocv( sample_identifiers = sample_identifiers, settings = settings, - data = data) + data = data, + rstream_object = rstream_object + ) # Append runs to the run list run_list <- c( @@ -491,7 +541,9 @@ train_samples = cv_iter_list$train_list, valid_samples = cv_iter_list$valid_list, can_pre_process = TRUE, - perturbation = curr_pert_method)) + perturbation = curr_pert_method + ) + ) } # Clean variables @@ -501,7 +553,8 @@ # Add to iteration list iteration_list[[as.character(curr_main_data_id)]] <- list( "run" = run_list, - "main_data_id" = curr_main_data_id) + "main_data_id" = curr_main_data_id + ) # Clean variables rm(run_list, ref_run_list, curr_main_data_id) @@ -511,7 +564,8 @@ logger_message( "Creating iterations: Finished creation of iterations.", indent = message_indent, - verbose = verbose) + verbose = verbose + ) } else if (override_external_validation) { if (is.null(iteration_list)) stop("iteration_list should be provided.") @@ -519,7 +573,7 @@ # Update external validation # Determine if external validation is required and skip otherwise - external_validation_required <- experiment_setup[main_data_id == 1, ]$external_validation[1] + external_validation_required <- experiment_setup[main_data_id == 1L, ]$external_validation[1L] if (external_validation_required) { # In case of external validation, find cohorts matching the train_cohorts all_cohorts <- unique(data[[batch_id_column]]) @@ -530,7 +584,8 @@ validation_cohorts <- settings$data$valid_cohorts if (!all(validation_cohorts %in% all_cohorts)) { ..warning_missing_cohorts( - x = validation_cohorts[!validation_cohorts %in% all_cohorts]) + x = validation_cohorts[!validation_cohorts %in% all_cohorts] + ) } } else { @@ -548,18 +603,19 @@ # Extract validation cohorts from data validation_cohorts <- all_cohorts[!all_cohorts %in% train_cohorts] - if (length(validation_cohorts) == 0) { + if (length(validation_cohorts) == 0L) { logger_warning("Creating iterations: No validation cohorts could be found.") } } # Update validation subjects to iter list - iteration_list[[as.character(1)]]$run[[as.character(1)]]$valid_samples <- unique( - data[batch_id %in% validation_cohorts, mget(id_columns)]) + iteration_list[[as.character(1L)]]$run[[as.character(1L)]]$valid_samples <- unique( + data[batch_id %in% validation_cohorts, mget(id_columns)] + ) } else { # Remove external validation subject - iteration_list[[as.character(1)]]$run[[as.character(1)]]$valid_samples <- NULL + iteration_list[[as.character(1L)]]$run[[as.character(1L)]]$valid_samples <- NULL } } @@ -574,7 +630,8 @@ project_id = NULL, experiment_setup, message_indent = 0L, - verbose = TRUE) { + verbose = TRUE +) { # Check if an existing project identifier is provided, otherwise generate a # new one. if (is.null(project_id)) { @@ -585,18 +642,21 @@ logger_message( paste0("Creating iterations: New project id is: \'", project_id, "\'."), indent = message_indent, - verbose = verbose) + verbose = verbose + ) } # Set file name file_name <- .get_iteration_file_name( file_paths = file_paths, - project_id = project_id) + project_id = project_id + ) # Attach both iteration list and experiment setup. save_iteration_list <- list( "iteration_list" = iteration_list, - "experiment_setup" = experiment_setup) + "experiment_setup" = experiment_setup + ) # Save both files to the folder saveRDS(save_iteration_list, file = file_name) @@ -611,10 +671,11 @@ train_samples, valid_samples, can_pre_process, - perturbation) { + perturbation +) { # Start an empty run list run_list <- list() - + for (ii in seq_len(length(train_samples))) { # Create new run table run_table <- data.table::data.table( @@ -622,7 +683,8 @@ "run_id" = ii, "can_pre_process" = can_pre_process, "perturbation" = perturbation, - "perturb_level" = 1) + "perturb_level" = 1L + ) # Add run_table to the list. run_list[[as.character(ii)]]$run_table <- run_table @@ -646,11 +708,12 @@ .add_iteration_to_run <- function( run, data_id = NULL, - run_id_offset = 0, + run_id_offset = 0L, train_samples, valid_samples, can_pre_process, - perturbation) { + perturbation +) { # Determine the number of runs n_iter <- length(train_samples) @@ -659,10 +722,10 @@ # If data_id is not provided, the run_list will be treated a custom run, and # will receive a data_id of -1 - if (is.null(data_id)) data_id <- -1 - + if (is.null(data_id)) data_id <- -1L + # Find the current perturbation level based on the input run - curr_perturb_level <- max(run$run_table$perturb_level) + 1 + curr_perturb_level <- max(run$run_table$perturb_level) + 1L for (ii in seq_len(n_iter)) { # Update run_id @@ -676,8 +739,10 @@ "run_id" = run_id, "can_pre_process" = can_pre_process, "perturbation" = perturbation, - "perturb_level" = curr_perturb_level)) - + "perturb_level" = curr_perturb_level + ) + ) + # Add run_table to the list. run_list[[as.character(run_id)]]$run_table <- run_table @@ -705,7 +770,8 @@ settings = NULL, outcome_type = NULL, stratify = TRUE, - rstream_object = NULL) { + rstream_object = NULL +) { # This function wraps the .create_cv function # Initiate lists for training and validation data @@ -713,7 +779,7 @@ valid_list <- list() # Iterate over iterations - for (ii in 1:n_rep) { + for (ii in 1L:n_rep) { # Create cross-validation subsets. cv_iter_list <- .create_cv( sample_identifiers = sample_identifiers, @@ -722,7 +788,8 @@ outcome_type = outcome_type, data = data, stratify = stratify, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Add new subsets to the list. train_list <- c(train_list, cv_iter_list$train_list) @@ -731,7 +798,8 @@ return(list( "train_list" = train_list, - "valid_list" = valid_list)) + "valid_list" = valid_list + )) } @@ -740,7 +808,8 @@ sample_identifiers = NULL, settings = NULL, outcome_type = NULL, - rstream_object = NULL) { + rstream_object = NULL +) { # Determine the number of samples. if (is.null(sample_identifiers)) { # Obtain id columns @@ -764,7 +833,8 @@ settings = settings, outcome_type = outcome_type, stratify = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) return(loocv_iter_list) } @@ -779,7 +849,8 @@ outcome_type = NULL, stratify = TRUE, return_fold_id = FALSE, - rstream_object = NULL) { + rstream_object = NULL +) { # Cross-validation # Suppress NOTES due to non-standard evaluation in data.table @@ -793,7 +864,7 @@ if (is.null(outcome_type)) outcome_type <- settings$data$outcome_type # Check stratification for continuous data - if (outcome_type %in% c("continuous", "count")) stratify <- FALSE + if (outcome_type %in% c("continuous")) stratify <- FALSE # Do not stratify absent data if (is_empty(data)) stratify <- FALSE @@ -804,7 +875,7 @@ sample_identifiers <- unique(data[, mget(id_columns)]) } - if (outcome_type %in% c("count", "continuous")) { + if (outcome_type %in% c("continuous")) { # Select data based on sample id - note that even if duplicate # sample_identifiers exist, only unique sample_identifiers are maintained - # this is intentional. @@ -812,7 +883,8 @@ x = unique(data[, mget(id_columns)]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) } else if (outcome_type == "survival") { # For stratifying survival data we require the event status. @@ -821,12 +893,14 @@ x = unique(data[, mget(c(id_columns, "outcome_event"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) data.table::setnames( x = subset_table, old = "outcome_event", - new = "outcome") + new = "outcome" + ) # Transcode event status subset_table[, "outcome" := factor(outcome)] @@ -841,7 +915,8 @@ x = unique(data[, mget(c(id_columns, "outcome"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) # Transcode classes subset_table$outcome <- addNA(subset_table$outcome, ifany = TRUE) @@ -858,23 +933,27 @@ # Determine the number of samples. n_samples <- data.table::uniqueN(subset_table, by = sample_id_columns) - if (n_folds < 2) { - stop("The number of cross-validation folds should be at least 2.") + if (n_folds < 2L) { + ..error("The number of cross-validation folds should be at least 2.") } # Check if the number of folds exceeds the number of data points if (n_folds > n_samples) { - stop(paste0( - "The number of cross-validation folds (", - n_folds, - ") exceeds the number of available data points (", - n_samples, - ").")) + ..error( + paste0( + "The number of cross-validation folds (", + n_folds, + ") exceeds the number of available data points (", + n_samples, + ")." + ), + error_Class = "input_argument_error" + ) } else if (stratify) { # Determine levels in stratified data - if (n_folds > n_samples - data.table::uniqueN(subset_table$outcome) + 1) { - warning("Cannot perform stratified cross-validation as the number of folds is too high.") + if (n_folds > n_samples - data.table::uniqueN(subset_table$outcome) + 1L) { + ..warning("Cannot perform stratified cross-validation as the number of folds is too high.") stratify <- FALSE } @@ -908,7 +987,8 @@ level_frequency <- subset_table[ fold_id == 0L, list("n" = .N > 0L), - by = c(id_columns, "outcome")] + by = c(id_columns, "outcome") + ] level_frequency <- level_frequency[, list("n" = sum(n)), by = c("outcome")][order(n)] # Determine which outcome levels occur in the same number or fewer samples @@ -921,29 +1001,32 @@ level_frequency[ subset_table[fold_id == -1L], "assign_to_training" := FALSE, - on = .NATURAL] + on = .NATURAL + ] # Break from loop if no samples need to be selected. if (all(level_frequency$assign_to_training == FALSE)) break # Select the first outcome at risk. This is the minority outcome class on # the first iteration. - outcome_level_training <- level_frequency[assign_to_training == TRUE]$outcome[1] + outcome_level_training <- level_frequency[assign_to_training == TRUE]$outcome[1L] # Randomly select one sample with the given outcome. sample_training <- fam_sample( subset_table[fold_id == 0L & outcome == outcome_level_training], size = 1L, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Pre-assign the selected sample. subset_table[ sample_training, "fold_id" := -1L, - on = .NATURAL] + on = .NATURAL + ] # Update n_samples and n_folds - n_samples <- n_samples - 1 + n_samples <- n_samples - 1L # Check that if n_folds is now larger than n_samples (e.g. LOOCV), that # n_folds is equalised again so that there is always one validation @@ -957,50 +1040,54 @@ if (!stratify) { # Iterate over the folds. - for (ii in 1:n_folds) { + for (ii in 1L:n_folds) { # Choose subject id for current fold current_train_id <- fam_sample( x = subset_table[fold_id == 0L], size = fold_size, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Join subset-table based on selected samples, and set the fold id. - subset_table[ - current_train_id, - "fold_id" := ii, - on = .NATURAL] + subset_table[current_train_id, "fold_id" := ii, on = .NATURAL] } # Update remaining samples by random assignment to a fold. - unassigned_data <- unique(subset_table[ - fold_id == 0, mget(sample_id_columns)], - by = sample_id_columns) + unassigned_data <- unique( + subset_table[fold_id == 0L, mget(sample_id_columns)], + by = sample_id_columns + ) - if (nrow(unassigned_data) > 0) { + if (nrow(unassigned_data) > 0L) { # Randomly assign fold identifier. unassigned_data[, "fold_id" := sample.int( n_folds, size = nrow(unassigned_data), - replace = FALSE)] + replace = FALSE + )] # Merge back the series identifier back into unassigned_data, and keep the # updated fold identifier. unassigned_data <- merge( x = unassigned_data, - y = subset_table[fold_id == 0, mget(id_columns)], + y = subset_table[fold_id == 0L, mget(id_columns)], by = sample_id_columns, - all = FALSE) + all = FALSE + ) # Add unassigned samples to the subset table. - subset_table <- data.table::rbindlist(list( - subset_table[fold_id != 0, mget(c("fold_id", id_columns))], - unassigned_data), - use.names = TRUE) + subset_table <- data.table::rbindlist( + list( + subset_table[fold_id != 0L, mget(c("fold_id", id_columns))], + unassigned_data + ), + use.names = TRUE + ) } # Assign training and validation folds - for (ii in 1:n_folds) { + for (ii in 1L:n_folds) { train_id <- subset_table[fold_id != ii, mget(id_columns)] valid_id <- subset_table[fold_id == ii, mget(id_columns)] @@ -1013,7 +1100,8 @@ level_frequency <- subset_table[ fold_id == 0L, list("n" = .N %/% n_folds), - by = "outcome"] + by = "outcome" + ] # Iterate over folds for (ii in seq_len(n_folds)) { @@ -1024,7 +1112,7 @@ available_data <- subset_table[fold_id == 0L] # Check that any data are available. - if (nrow(available_data) == 0) next() + if (nrow(available_data) == 0L) next # Determine the frequency of outcome levels for each sample. available_data <- available_data[, list("n" = .N), by = c(sample_id_columns, "outcome")] @@ -1033,7 +1121,8 @@ sample_order <- fam_sample( x = available_data, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Set sample_order_id. This will be used to order available_data. sample_order[, "sample_order_id" := .I] @@ -1052,63 +1141,65 @@ safe_to_add <- all(fold_level_frequency[ current_sample, list("n" = n - i.n), - on = "outcome"]$n >= 0) + on = "outcome" + ]$n >= 0L) if (!safe_to_add) next # If the check passes, we need to add the sample to the fold, and update # level_frequency_fold. - fold_level_frequency[ - current_sample, - "n" := n - i.n, - on = "outcome"] + fold_level_frequency[current_sample, "n" := n - i.n, on = "outcome"] # Add to fold. current_sample <- unique(current_sample[, mget(sample_id_columns)]) - subset_table[ - current_sample, - "fold_id" := ii, - on = .NATURAL] + subset_table[current_sample, "fold_id" := ii, on = .NATURAL] # Skip further samples if no more samples need to be added to the fold. - if (all(fold_level_frequency$n == 0)) break + if (all(fold_level_frequency$n == 0L)) break } } # Determine if all data was assigned. unassigned_data <- unique( - subset_table[fold_id == 0, mget(sample_id_columns)], - by = sample_id_columns) + subset_table[fold_id == 0L, mget(sample_id_columns)], + by = sample_id_columns + ) - if (nrow(unassigned_data) > 0) { + if (nrow(unassigned_data) > 0L) { # Randomly order unassigned data. unassigned_data <- fam_sample(unassigned_data, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Assign fold id. unassigned_data[, "fold_id" := rep_len( x = seq_len(n_folds), - length.out = nrow(unassigned_data))] + length.out = nrow(unassigned_data) + )] # Merge back the series identifier back into unassigned_data, and keep the # updated fold identifier. unassigned_data <- merge( x = unassigned_data, - y = subset_table[fold_id == 0, mget(id_columns)], + y = subset_table[fold_id == 0L, mget(id_columns)], by = sample_id_columns, - all = FALSE) + all = FALSE + ) # Add unassigned samples to the subset table. - subset_table <- data.table::rbindlist(list( - subset_table[fold_id != 0, mget(c(id_columns, "fold_id"))], - unassigned_data), - use.names = TRUE) + subset_table <- data.table::rbindlist( + list( + subset_table[fold_id != 0L, mget(c(id_columns, "fold_id"))], + unassigned_data + ), + use.names = TRUE + ) } # Assign to training and validation sets. Note that any unassigned samples # are assigned to the training folds. - for (ii in 1:n_folds) { + for (ii in 1L:n_folds) { train_list[[ii]] <- subset_table[fold_id != ii, mget(id_columns)] valid_list[[ii]] <- subset_table[fold_id == ii, mget(id_columns)] } @@ -1124,7 +1215,8 @@ } else { return(list( "train_list" = train_list, - "valid_list" = valid_list)) + "valid_list" = valid_list + )) } } @@ -1137,7 +1229,8 @@ settings = NULL, outcome_type = NULL, stratify = TRUE, - rstream_object = NULL) { + rstream_object = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table outcome <- outcome_present <- .NATURAL <- NULL keep <- sample_order_id <- cumulative_n <- i.n <- n <- NULL @@ -1155,12 +1248,12 @@ } # Check stratification for continuous data - if (outcome_type %in% c("continuous", "count")) stratify <- FALSE + if (outcome_type %in% c("continuous")) stratify <- FALSE # Check stratification for absent data if (is_empty(data)) stratify <- FALSE - if (outcome_type %in% c("continuous", "count")) { + if (outcome_type %in% c("continuous")) { # Select data based on sample id - note that even if duplicate # sample_identifiers exist, only unique sample_identifiers are maintained - # this is intentional. @@ -1168,7 +1261,8 @@ x = unique(data[, mget(c(id_columns, "outcome"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) } else if (outcome_type == "survival") { # For stratifying survival data we require the event status. Event status @@ -1177,12 +1271,14 @@ x = unique(data[, mget(c(id_columns, "outcome_event"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) data.table::setnames( x = subset_table, old = "outcome_event", - new = "outcome") + new = "outcome" + ) # Transcode event status subset_table[, "outcome" := factor(outcome)] @@ -1196,7 +1292,8 @@ x = unique(data[, mget(c(id_columns, "outcome"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) # Transcode classes subset_table$outcome <- addNA(subset_table$outcome, ifany = TRUE) @@ -1213,14 +1310,15 @@ train_list <- valid_list <- list() # Iterate over iterations - ii <- jj <- 1 - while (ii <= n_iter && jj <= 2 * n_iter) { + ii <- jj <- 1L + while (ii <= n_iter && jj <= 2L * n_iter) { if (!stratify) { # Sample training data with replacement train_id <- fam_sample( x = subset_table, replace = TRUE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Merge train_id with subset_table. train_id <- merge( @@ -1228,20 +1326,23 @@ y = subset_table, by = sample_id_columns, all = FALSE, - allow.cartesian = TRUE) + allow.cartesian = TRUE + ) # Check that any rare outcome classes are actually present in the training # data. This prevents issues with modelling and model evaluation later on. if (outcome_type %in% c("binomial", "multinomial", "survival")) { # Check if all outcome data are presents. missing_levels <- setdiff( - levels(subset_table$outcome), unique(train_id$outcome)) + levels(subset_table$outcome), unique(train_id$outcome) + ) - if (length(missing_levels) > 0) { + if (length(missing_levels) > 0L) { # Integrate outcome levels in a table to keep track. missing_level_data <- data.table::data.table( "outcome" = levels(subset_table$outcome), - "outcome_present" = TRUE) + "outcome_present" = TRUE + ) # Flag outcome levels as not present if they are missing. missing_level_data[outcome %in% missing_levels, "outcome_present" := FALSE] @@ -1250,13 +1351,14 @@ # contains an outcome of the level. while (any(missing_level_data$outcome_present == FALSE)) { # Select the missing outcome level. - missing_level <- missing_level_data[outcome_present == FALSE]$outcome[1] + missing_level <- missing_level_data[outcome_present == FALSE]$outcome[1L] # Select an additional sample that contains the missing level. additional_data <- fam_sample( subset_table[outcome == missing_level], size = 1L, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Select the data corresponding to the sample. additional_data <- merge( @@ -1264,18 +1366,21 @@ y = subset_table, by = sample_id_columns, all = FALSE, - allow.cartesian = TRUE) + allow.cartesian = TRUE + ) # Flag any missing levels that are now included in the data as # present. missing_level_data[ additional_data[, "outcome"], "outcome_present" := TRUE, - on = .NATURAL] + on = .NATURAL + ] # Update train_id. train_id <- data.table::rbindlist( - list(train_id, additional_data)) + list(train_id, additional_data) + ) } } } @@ -1286,11 +1391,12 @@ # Determine the out-of-bag data. valid_id <- data.table::fsetdiff( x = subset_table[, mget(id_columns)], - y = train_id) + y = train_id + ) # Check for empty out-of-bag sets and re-run experiment if this happens. - if (nrow(valid_id) == 0) { - jj <- jj + 1 + if (nrow(valid_id) == 0L) { + jj <- jj + 1L next } @@ -1343,12 +1449,13 @@ # Iterate over majority classes. for (current_class in class_order) { # Skip if the number of required samples for the outcome class is 0. - if (level_frequency[outcome == current_class]$n == 0) next + if (level_frequency[outcome == current_class]$n == 0L) next # Select only data where the current class is present. partition_data <- available_data[ unique(available_data[outcome == current_class, mget(sample_id_columns)]), - on = .NATURAL] + on = .NATURAL + ] # Determine the frequency of outcome levels for each sample. partition_data <- partition_data[, list("n" = .N), by = c(sample_id_columns, "outcome")] @@ -1371,7 +1478,8 @@ x = partition_data, size = level_frequency[outcome == current_class]$n, replace = TRUE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Set sample_order_id. This will be used to order partition_data. sample_order[, "sample_order_id" := .I] @@ -1401,29 +1509,35 @@ # this dataset then select the sample identifier columns. partition_train_list <- c( partition_train_list, - list(unique( - partition_data[ - keep == TRUE, - mget(c(sample_id_columns, "sample_order_id")) - ])[, mget(sample_id_columns)])) + list( + unique( + partition_data[ + keep == TRUE, + mget(c(sample_id_columns, "sample_order_id")) + ] + )[, mget(sample_id_columns)] + ) + ) # Update partition level frequency level_frequency[ partition_data[ keep == TRUE, list("n" = sum(n)), - by = "outcome"], + by = "outcome" + ], "n" := n - i.n, - on = "outcome"] + on = "outcome" + ] # Determine if the outcome level was filled to the required level. - if (level_frequency[outcome == current_class]$n == 0) next + if (level_frequency[outcome == current_class]$n == 0L) next # Select remaining data to complete partition_data <- partition_data[keep == FALSE] # Check that any data actually has been selected. - if (nrow(partition_data) == 0) next + if (nrow(partition_data) == 0L) next # Remove any samples that would exceed the required total instances for # each level. First mark the instances that do not exceed the required @@ -1431,14 +1545,15 @@ partition_data[ level_frequency, "keep" := n <= i.n, - on = "outcome"] + on = "outcome" + ] # Then mark the corresponding samples, and only keep those. partition_data[, "keep" := all(keep), by = c(sample_id_columns, "sample_order_id")] partition_data <- partition_data[keep == TRUE, ] # Check that any data actually has been selected. - if (nrow(partition_data) == 0) next + if (nrow(partition_data) == 0L) next # Iterate over the remaining samples. For each sample we check whether # it can be added to the partition. @@ -1448,7 +1563,7 @@ current_sample, list("n" = n - i.n), on = "outcome" - ]$n >= 0) + ]$n >= 0L) # Skip to next sample, if the current sample cannot be added due to # constraints. @@ -1456,18 +1571,16 @@ # If the check passes, we need to add the sample to the fold, and the # update level frequency. - level_frequency[ - current_sample, - "n" := n - i.n, - on = "outcome"] + level_frequency[current_sample, "n" := n - i.n, on = "outcome"] # Add the selected sample to the list. partition_train_list <- c( partition_train_list, - list(unique(current_sample[, mget(sample_id_columns)]))) + list(unique(current_sample[, mget(sample_id_columns)])) + ) # Skip further samples if no more samples need to be added to the fold. - if (any(level_frequency$n == 0)) break + if (any(level_frequency$n == 0L)) break } # Mark all samples that lack the current outcome as available; or rather @@ -1484,7 +1597,8 @@ y = subset_table, by = sample_id_columns, all = FALSE, - allow.cartesian = TRUE) + allow.cartesian = TRUE + ) # Select only relevant columns. train_id <- train_id[, mget(id_columns)] @@ -1492,11 +1606,12 @@ # Determine the out-of-bag data. valid_id <- data.table::fsetdiff( x = subset_table[, mget(id_columns)], - y = train_id) + y = train_id + ) # Check for empty out-of-bag sets and re-run sampling if this happens. - if (nrow(valid_id) == 0) { - jj <- jj + 1 + if (nrow(valid_id) == 0L) { + jj <- jj + 1L next } @@ -1506,19 +1621,24 @@ } # Update iterators - ii <- ii + 1 - jj <- jj + 1 + ii <- ii + 1L + jj <- jj + 1L } - if (ii != n_iter + 1) { - stop(paste0( - "Could not form ", n_iter, " bootstraps with out-of-bag data. ", - "The data set may be too small.")) + if (ii != n_iter + 1L) { + ..error( + paste0( + "Could not form ", n_iter, " bootstraps with out-of-bag data. ", + "The data set may be too small." + ), + error_Class = "dataset_error" + ) } return(list( "train_list" = train_list, - "valid_list" = valid_list)) + "valid_list" = valid_list + )) } @@ -1530,7 +1650,8 @@ outcome_type = NULL, imbalance_method = NULL, imbalance_n_partitions = NULL, - rstream_object = NULL) { + rstream_object = NULL +) { # Methods to address class imbalance # Suppress NOTES due to non-standard evaluation in data.table @@ -1545,7 +1666,8 @@ if (!outcome_type %in% c("binomial", "multinomial")) { logger_stop(paste0( "Creating iterations: Imbalance partitions (ip) are only available ", - "for binomial and multinomial outcomes.")) + "for binomial and multinomial outcomes." + )) } # Obtain id columns @@ -1565,7 +1687,8 @@ x = unique(data[, mget(c(id_columns, "outcome"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) # Transcode classes subset_table$outcome <- addNA(subset_table$outcome, ifany = TRUE) @@ -1584,9 +1707,10 @@ n_large <- max(level_frequency$n) if (n_small / (n_large + n_small) > 0.3) { - warning(paste0( + ..warning(paste0( "Imbalance partitions are not required as data ", - "are not severely imbalanced.")) + "are not severely imbalanced." + )) } # Set up the basic partition by selecting all data that are required for the @@ -1600,7 +1724,8 @@ subset_table[ subset_table[outcome %in% minority_class, mget(sample_id_columns)], "partition" := "base", - on = .NATURAL] + on = .NATURAL + ] # Determine the number of partitions while allowing the majority class to # be up to 10% bigger. This should leave sufficient margin for a slight @@ -1611,15 +1736,16 @@ # Determine the number of partitions. if (imbalance_method == "random_undersampling") { # Set randomisation flag. - randomise <- n_partitions > 1 + randomise <- n_partitions > 1L - if (n_partitions > 1) { + if (n_partitions > 1L) { # Use setting provided by the user. n_partitions <- imbalance_n_partitions + } else if (n_partitions != imbalance_n_partitions) { # In case the number of unique partitions is 1, and the user-provided # setting is not 1, create only one partition and warn the user. - warning("Only one unique partition can be created.") + ..warning("Only one unique partition can be created.") } } else { # Set randomise to FALSE. @@ -1633,26 +1759,32 @@ subset_table[ partition == "base", list("n" = .N), - by = "outcome"], + by = "outcome" + ], "n" := n - i.n, - on = "outcome"] - level_frequency[n < 0, "n" := 0L] + on = "outcome" + ] + level_frequency[n < 0L, "n" := 0L] # Throw an error if no further partitions can be formed aside from the base. # This basically means that the minority class is too small. - if (all(level_frequency$n == 0L) && any(is.na(subset_table$partition))) { - stop(paste0( - "The minority class may contain too few instances (", n_small, - ") to allow for balanced partitioning. ", - "This error occurs when all samples containing the minority class ", - "also completely fill out the allowed space for majority classes. ", - "Thus, no other samples that contain a non-minority class could be ", - "selected. We would recommend to either increase the data available, ", - "or remove all instances of the minority class.")) + if (all(level_frequency$n == 0L) && anyNA(subset_table$partition)) { + ..error( + paste0( + "The minority class may contain too few instances (", n_small, + ") to allow for balanced partitioning. ", + "This error occurs when all samples containing the minority class ", + "also completely fill out the allowed space for majority classes. ", + "Thus, no other samples that contain a non-minority class could be ", + "selected. We would recommend to either increase the data available, ", + "or remove all instances of the minority class." + ), + error_class = "dataset_error" + ) } # Initialise iterator. - ii <- 0 + ii <- 0L while (TRUE) { # Update the iterator @@ -1679,12 +1811,14 @@ # Check that any data are available, or that we can create a meaningful # partition using additional data. - if (nrow(available_data) == 0 || - all(partition_level_frequency$n == 0) || - length(majority_class) == 0) { + if ( + nrow(available_data) == 0L || + all(partition_level_frequency$n == 0L) || + length(majority_class) == 0L + ) { # If no data are available in the first iteration, copy the dataset that # was based on the minority class(es), and break from the loop. - if (ii <- 1) { + if (ii == 1L) { train_list[[ii]] <- subset_table[partition == "base", mget(id_columns)] } @@ -1692,8 +1826,7 @@ } # Break if all data have been assigned. - if (imbalance_method == "full_undersampling" && - all(!is.na(subset_table$partition))) { + if (imbalance_method == "full_undersampling" && !anyNA(subset_table$partition)) { break } @@ -1702,7 +1835,8 @@ # Select only data where the current class is present. partition_data <- available_data[ unique(available_data[outcome == current_class, mget(sample_id_columns)]), - on = .NATURAL] + on = .NATURAL + ] # Randomly order samples. # @@ -1721,7 +1855,8 @@ sample_order <- fam_sample( x = partition_data, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Set sample_order_id. This will be used to order partition_data. sample_order[, "sample_order_id" := .I] @@ -1730,7 +1865,8 @@ # For full partitioning. unassigned_partition_data <- partition_data[is.na(partition)] assigned_partition_data <- data.table::fsetdiff( - partition_data, unassigned_partition_data) + partition_data, unassigned_partition_data + ) # Initial sample order offset. sample_order_offset <- 0L @@ -1738,12 +1874,13 @@ # Initialise datasets. assigned_sample_order <- unassigned_sample_order <- NULL - if (nrow(unassigned_partition_data) > 0) { + if (nrow(unassigned_partition_data) > 0L) { # Order available data randomly. unassigned_sample_order <- fam_sample( x = unassigned_partition_data, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Set sample_order_id. This will be used to order available_data. unassigned_sample_order[, "sample_order_id" := .I] @@ -1752,12 +1889,13 @@ sample_order_offset <- nrow(unassigned_sample_order) } - if (nrow(assigned_partition_data) > 0) { + if (nrow(assigned_partition_data) > 0L) { # Order available data randomly. assigned_sample_order <- fam_sample( x = assigned_partition_data, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Set sample_order_id. This will be used to order available_data. assigned_sample_order[, "sample_order_id" := .I + sample_order_offset] @@ -1765,7 +1903,8 @@ # Determine sample order. sample_order <- data.table::rbindlist( - list(unassigned_sample_order, assigned_sample_order)) + list(unassigned_sample_order, assigned_sample_order) + ) } # Merge with available_data @@ -1778,7 +1917,8 @@ # Determine the frequency of outcome levels for each sample. partition_data <- partition_data[ , list("n" = .N), - by = c(sample_id_columns, "outcome", "sample_order_id")] + by = c(sample_id_columns, "outcome", "sample_order_id") + ] # From here on we select the samples and add them to the partition. This # proceeds according to the following steps: @@ -1807,13 +1947,14 @@ partition_data[ partition_level_frequency, "keep" := n <= i.n, - on = "outcome"] + on = "outcome" + ] # Then mark the corresponding samples, and only keep those. partition_data[, "keep" := all(keep), by = c(sample_id_columns, "sample_order_id")] partition_data <- partition_data[keep == TRUE] - if (nrow(partition_data) == 0) { + if (nrow(partition_data) == 0L) { # At this point none of the samples with the current class have been # assigned. If partition_data is empty, that means that the samples # with this class were skipped, perhaps because samples selected from @@ -1831,7 +1972,8 @@ partition_data[ partition_level_frequency, "keep" := cumulative_n <= i.n, - on = "outcome"] + on = "outcome" + ] # Mark the corresponding samples. partition_data[, "keep" := all(keep), by = c(sample_id_columns, "sample_order_id")] @@ -1840,25 +1982,28 @@ subset_table[ partition_data[keep == TRUE, mget(sample_id_columns)], "partition" := as.character(ii), - on = .NATURAL] + on = .NATURAL + ] # Update partition level frequency partition_level_frequency[ partition_data[ keep == TRUE, list("n" = sum(n)), - by = "outcome"], + by = "outcome" + ], "n" := n - i.n, - on = "outcome"] + on = "outcome" + ] # Determine if the outcome level was filled to the required level. - if (partition_level_frequency[outcome == current_class]$n == 0) next + if (partition_level_frequency[outcome == current_class]$n == 0L) next # Select remaining data to complete partition_data <- partition_data[keep == FALSE] # Check that any data actually has been selected. - if (nrow(partition_data) == 0) next + if (nrow(partition_data) == 0L) next # Remove any samples that would exceed the required total instances for # each level. First mark the instances that do not exceed the required @@ -1866,14 +2011,15 @@ partition_data[ partition_level_frequency, "keep" := n <= i.n, - on = "outcome"] + on = "outcome" + ] # Then mark the corresponding samples, and only keep those. partition_data[, "keep" := all(keep), by = c(sample_id_columns, "sample_order_id")] partition_data <- partition_data[keep == TRUE, ] # Check that any data actually has been selected. - if (nrow(partition_data) == 0) next() + if (nrow(partition_data) == 0L) next # Iterate over the remaining samples. For each sample we check whether # it can be added to the partition. @@ -1882,11 +2028,12 @@ safe_to_add <- all(partition_level_frequency[ current_sample, list("n" = n - i.n), - on = "outcome"]$n >= 0) + on = "outcome" + ]$n >= 0L) # Skip to next sample, if the current sample cannot be added due to # constraints. - if (!safe_to_add) next() + if (!safe_to_add) next # If the check passes, we need to add the sample to the fold, and # update level_frequency_fold. @@ -1897,41 +2044,46 @@ subset_table[ unique(current_sample[, mget(sample_id_columns)]), "partition" := as.character(ii), - on = .NATURAL] + on = .NATURAL + ] # Skip further samples if no more samples need to be added to the fold. - if (all(partition_level_frequency$n == 0)) break + if (all(partition_level_frequency$n == 0L)) break } } # Select samples. train_list[[ii]] <- subset_table[ partition %in% c("base", as.character(ii)), - mget(id_columns)] + mget(id_columns) + ] # Check that any unassigned samples are not completely covered by # no_class_assigned. if (!is.null(no_class_assigned) && imbalance_method == "full_undersampling") { - if (any(is.na(subset_table$partition))) { + if (anyNA(subset_table$partition)) { if (all(subset_table[is.na(partition)]$outcome %in% no_class_assigned)) { # Determine the number of samples that cannot be assigned. n_samples_not_assigned <- data.table::uniqueN( - subset_table[is.na(partition), mget(sample_id_columns)]) + subset_table[is.na(partition), mget(sample_id_columns)] + ) # Throw warning. logger_warning( paste0( n_samples_not_assigned, - ifelse(n_samples_not_assigned > 1, " samples", " sample"), - " could not be assigned during undersampling for balance correction.")) + ifelse(n_samples_not_assigned > 1L, " samples", " sample"), + " could not be assigned during undersampling for balance correction." + ) + ) break - } else if (ii > 1) { + } else if (ii > 1L) { # Check if the generated dataset is actually unique. flag_infinite_loop <- FALSE - for (jj in seq_len(ii - 1)) { + for (jj in seq_len(ii - 1L)) { if (data.table::fsetequal(train_list[[ii]], train_list[[jj]])) { # Remove non-unique dataset from train_list and break from the # loop. @@ -1945,13 +2097,15 @@ if (flag_infinite_loop) { # Determine the number of samples that cannot be assigned. n_samples_not_assigned <- data.table::uniqueN( - subset_table[is.na(partition), mget(sample_id_columns)]) + subset_table[is.na(partition), mget(sample_id_columns)] + ) # Throw warning. logger_warning(paste0( n_samples_not_assigned, - ifelse(n_samples_not_assigned > 1, " samples", " sample"), - " could not be assigned during undersampling for balance correction.")) + ifelse(n_samples_not_assigned > 1L, " samples", " sample"), + " could not be assigned during undersampling for balance correction." + )) break } @@ -1979,7 +2133,8 @@ outcome_type = NULL, stratify = TRUE, tolerance = 0.05, - rstream_object = NULL) { + rstream_object = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table outcome <- frequency <- n <- .NATURAL <- NULL i.frequency <- i.n <- order_id <- cum_n <- frequency_diff <- NULL @@ -1997,12 +2152,12 @@ } # Check stratification for continuous data - if (outcome_type %in% c("continuous", "count")) stratify <- FALSE + if (outcome_type %in% c("continuous")) stratify <- FALSE # Check stratification for absent data if (is_empty(data)) stratify <- FALSE - if (outcome_type %in% c("continuous", "count")) { + if (outcome_type %in% c("continuous")) { # Select data based on sample id - note that even if duplicate # sample_identifiers exist, only unique sample_identifiers are maintained - # this is intentional. @@ -2010,7 +2165,8 @@ x = unique(data[, mget(c(id_columns, "outcome"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) } else if (outcome_type == "survival") { # For stratifying survival data we require the event status. @@ -2019,12 +2175,14 @@ x = unique(data[, mget(c(id_columns, "outcome_event"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) data.table::setnames( x = subset_table, old = "outcome_event", - new = "outcome") + new = "outcome" + ) # Transcode event status subset_table[, "outcome" := factor(outcome)] @@ -2038,7 +2196,8 @@ x = unique(data[, mget(c(id_columns, "outcome"))]), y = sample_identifiers, by = id_columns, - all = FALSE) + all = FALSE + ) # Transcode classes subset_table$outcome <- addNA(subset_table$outcome, ifany = TRUE) @@ -2082,7 +2241,7 @@ # Pick initial samples. for (current_class in class_order) { # Check if any samples can be selected. - if (size_remaining == 0) break + if (size_remaining == 0L) break # Check if the class has already been selected. if (any(available_data[is_available == FALSE]$outcome == current_class)) next @@ -2091,14 +2250,17 @@ partition_data <- available_data[ unique(available_data[ outcome == current_class & is_available == TRUE, - mget(sample_id_columns)]), - on = .NATURAL] + mget(sample_id_columns) + ]), + on = .NATURAL + ] # Select a single sample from the potential datasets. train_id <- fam_sample(partition_data, size = 1L, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Mark as being selected. available_data[train_id, "is_available" := FALSE, on = .NATURAL] @@ -2108,7 +2270,7 @@ } } - if (!stratify && size_remaining > 0) { + if (!stratify && size_remaining > 0L) { # Unstratified assignment. # Select a samples from the remaining available samples. @@ -2116,7 +2278,8 @@ available_data[is_available == TRUE, mget(sample_id_columns)], size = size_remaining, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Mark as being selected. available_data[train_id, "is_available" := FALSE, on = .NATURAL] @@ -2124,7 +2287,7 @@ # Reduce size. size_remaining <- 0L - } else if (stratify && size_remaining > 0) { + } else if (stratify && size_remaining > 0L) { # Stratified assignment. This is more complex. First we attempt to # randomly assign samples, for which we check tolerance with the expected # stratification. Starting with the largest randomly selected sample set @@ -2136,26 +2299,28 @@ selected_frequency <- available_data[ is_available == FALSE, list("n" = .N), - by = "outcome"][order(n)] + by = "outcome" + ][order(n)] # Select samples that have not been selected previously. partition_data <- available_data[ - unique(available_data[ - is_available == TRUE, - mget(sample_id_columns)]), - on = .NATURAL] + unique(available_data[is_available == TRUE, mget(sample_id_columns)]), + on = .NATURAL + ] # Set null data. null_data <- data.table::data.table(expand.grid( "order_id" = seq_len(size_remaining), "outcome" = levels(subset_table$outcome), - "n" = 0L)) + "n" = 0L + )) # Randomly selected samples. random_data <- fam_sample(partition_data, size = size_remaining, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Add in indices. random_data[, "order_id" := .I] @@ -2170,7 +2335,8 @@ # Update missing levels. random_data <- data.table::rbindlist( list(random_data, null_data), - use.names = TRUE) + use.names = TRUE + ) random_data <- random_data[, list("n" = max(n)), by = c("order_id", sample_id_columns, "outcome")] random_data <- random_data[order(order_id)] @@ -2187,20 +2353,24 @@ random_data[ level_frequency, "frequency_diff" := abs(frequency - i.frequency), - on = "outcome"] + on = "outcome" + ] # Check where the random assignment was reasonably ok. - frequency_check <- random_data[, list( - "difference_ok" = all(frequency_diff <= tolerance)), - by = "order_id"] + frequency_check <- random_data[ + , + list("difference_ok" = all(frequency_diff <= tolerance)), + by = "order_id" + ] last_ok_sample <- tail(which(frequency_check$difference_ok), n = 1L) - if (length(last_ok_sample) > 0) { + if (length(last_ok_sample) > 0L) { # Mark data. available_data[ unique(random_data[order_id <= last_ok_sample, mget(sample_id_columns)]), "is_available" := FALSE, - on = .NATURAL] + on = .NATURAL + ] # Update remaining. size_remaining <- size_remaining - last_ok_sample @@ -2210,28 +2380,33 @@ selected_frequency <- available_data[ is_available == FALSE, list("n" = .N), - by = "outcome"][order(n)] + by = "outcome" + ][order(n)] selected_frequency[, "frequency" := n / sum(n)] selected_frequency[ level_frequency, "frequency_diff" := abs(frequency - i.frequency), - on = "outcome"] + on = "outcome" + ] # Static selection. - while (size_remaining > 0) { + while (size_remaining > 0L) { # Select available data. partition_data <- available_data[ unique(available_data[ is_available == TRUE, - mget(sample_id_columns)]), - on = .NATURAL] + mget(sample_id_columns) + ]), + on = .NATURAL + ] # Shuffle partition_data. partition_data <- fam_sample( partition_data, size = data.table::uniqueN(partition_data[, mget(sample_id_columns)]), replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Add in outcome data to the number of outcomes in random data partition_data <- available_data[partition_data, on = .NATURAL] @@ -2251,7 +2426,8 @@ new_frequency[ level_frequency, "frequency_diff" := abs(frequency - i.frequency), - on = "outcome"] + on = "outcome" + ] # Check difference of previously selected previous_diff <- sum(selected_frequency$frequency_diff) @@ -2278,7 +2454,8 @@ available_data[ current_sample[, mget(sample_id_columns)], "is_available" := FALSE, - on = .NATURAL] + on = .NATURAL + ] # Update remaining. size_remaining <- size_remaining - 1L @@ -2289,7 +2466,7 @@ # Use the new frequency as the selected frequency. selected_frequency <- data.table::copy(new_frequency) - if (size_remaining == 0) break + if (size_remaining == 0L) break } } @@ -2301,7 +2478,8 @@ partition_data, size = size_remaining, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Mark as being selected. available_data[train_id, "is_available" := FALSE, on = .NATURAL] @@ -2318,17 +2496,47 @@ # Determine the out-of-bag data. valid_id <- data.table::fsetdiff( x = subset_table[, mget(id_columns)], - y = train_id) + y = train_id + ) # Store to list train_list[[ii]] <- train_id valid_list[[ii]] <- valid_id # Update iterators - ii <- ii + 1 + ii <- ii + 1L } return(list( "train_list" = train_list, - "valid_list" = valid_list)) + "valid_list" = valid_list + )) +} + + + +.collect_run_tables <- function(iteration_list) { + run_tables <- list() + ii <- 1L + for (iteration in iteration_list) { + for (run in iteration$run) { + run_tables[[ii]] <- run$run_table + ii <- ii + 1L + } + } + + # Add names. + names(run_tables) <- sapply( + run_tables, + function(x) { + data_id <- tail(x, n = 1L)$data_id[[1L]] + run_id <- tail(x, n = 1L)$run_id[[1L]] + + return(paste0(data_id, ".", run_id)) + }, + simplify = TRUE, + USE.NAMES = FALSE + ) + + return(run_tables) } diff --git a/R/LearnerMain.R b/R/LearnerMain.R index 98418401..a1912b99 100644 --- a/R/LearnerMain.R +++ b/R/LearnerMain.R @@ -94,14 +94,16 @@ setMethod( data, learner, outcome_type, - names_only = FALSE) { + names_only = FALSE +) { # Get the outcome type from the data object, if available if (!is.null(data)) outcome_type <- data@outcome_type # Create familiarModel fam_model <- methods::new("familiarModel", learner = learner, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Set up the specific model fam_model <- promote_learner(fam_model) @@ -121,11 +123,13 @@ setMethod( .check_learner_outcome_type <- function( learner, outcome_type, - as_flag = FALSE) { + as_flag = FALSE +) { # Create familiarModel fam_model <- methods::new("familiarModel", learner = learner, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Set up the specific model fam_model <- promote_learner(fam_model) @@ -136,22 +140,30 @@ setMethod( if (as_flag) return(learner_available) # Check if the familiar model has been successfully promoted. - if (!is_subclass(class(fam_model)[1], "familiarModel")) { - stop(paste0( - learner, " is not a valid learner. ", - "Please check the vignette for available learners.")) + if (!is_subclass(class(fam_model)[1L], "familiarModel")) { + ..error( + paste0( + learner, " is not a valid learner. ", + "Please check the vignette for available learners." + ), + error_class = "input_argument_error" + ) } # Check if the learner is available. if (!learner_available) { - stop(paste0(learner, " is not available for \"", outcome_type, "\" outcomes.")) + ..error( + paste0(learner, " is not available for \"", outcome_type, "\" outcomes."), + error_class = "input_argument_error" + ) } # Check that the required package can be loaded. require_package( x = fam_model, purpose = paste0("to train models using the ", learner, " learner"), - message_type = "backend_error") + message_type = "backend_error" + ) } @@ -170,7 +182,8 @@ setMethod( #' @keywords internal .get_default_sign_size <- function( data, - restrict_samples = FALSE) { + restrict_samples = FALSE +) { # Suppress NOTES due to non-standard evaluation in data.table outcome_event <- NULL @@ -180,16 +193,17 @@ setMethod( # Determine the number of samples and features n_samples <- data.table::uniqueN( data@data, - by = get_id_columns(id_depth = "series")) + by = get_id_columns(id_depth = "series") + ) n_features <- get_n_features(data) # Determine the actual range of features dynamically. - if (restrict_samples && n_samples > 1) { - sign_size_range <- c(1, min(n_samples - 1, n_features)) - } else if (restrict_samples && n_samples <= 1) { - sign_size_range <- c(1, 1) + if (restrict_samples && n_samples > 1L) { + sign_size_range <- c(1L, min(n_samples - 1L, n_features)) + } else if (restrict_samples && n_samples <= 1L) { + sign_size_range <- c(1L, 1L) } else { - sign_size_range <- c(1, n_features) + sign_size_range <- c(1L, n_features) } if (outcome_type %in% c("binomial", "multinomial")) { @@ -197,18 +211,18 @@ setMethod( n_classes <- nlevels(data@data$outcome) # Determine the range - sign_size_default <- unique(c(1, 2, 5, 10, max(c(1.0, floor(n_samples / (n_classes * 7.5)))))) + sign_size_default <- unique(c(1L, 2L, 5L, 10L, max(c(1.0, floor(n_samples / (n_classes * 7.5)))))) } else if (outcome_type %in% c("survival")) { # Get the number of events - n_events <- nrow(data@data[outcome_event == 1, ]) + n_events <- nrow(data@data[outcome_event == 1L, ]) # Determine the range - sign_size_default <- unique(c(1, 2, 5, 10, max(c(1.0, floor(n_events / 15))))) + sign_size_default <- unique(c(1L, 2L, 5L, 10L, as.integer(max(c(1.0, floor(n_events / 15.0)))))) - } else if (outcome_type %in% c("count", "continuous")) { + } else if (outcome_type %in% c("continuous")) { # Determine the range - sign_size_default <- unique(c(1, 2, 5, 10, max(c(1.0, floor(n_samples / 15))))) + sign_size_default <- unique(c(1L, 2L, 5L, 10L, as.integer(max(c(1.0, floor(n_samples / 15.0)))))) } else { ..error_no_known_outcome_type(outcome_type) @@ -216,14 +230,16 @@ setMethod( # Limit default to those values that fall within the range. sign_size_default <- sign_size_default[ - sign_size_default >= sign_size_range[1] & - sign_size_default <= sign_size_range[2]] + sign_size_default >= sign_size_range[1L] & + sign_size_default <= sign_size_range[2L] + ] return(.set_hyperparameter( default = sign_size_default, type = "integer", range = sign_size_range, - valid_range = c(0, Inf), + valid_range = c(0L, Inf), randomise = TRUE, - distribution = "log")) + distribution = "log" + )) } diff --git a/R/LearnerRecalibration.R b/R/LearnerRecalibration.R index 9dc38f07..133780f0 100644 --- a/R/LearnerRecalibration.R +++ b/R/LearnerRecalibration.R @@ -1,7 +1,12 @@ -.set_recalibration <- function(object, data, time = NULL) { +.set_recalibration <- function( + object, + data, + time = NULL, + ... +) { # Suppress NOTES due to non-standard evaluation in data.table outcome <- predicted_outcome <- NULL - + # Initial empty calibration list calibration_model_list <- list() @@ -10,40 +15,46 @@ object = object, data = data, allow_recalibration = FALSE, - time = time) + time = time + ) + + if (!all_predictions_valid(model_predictions)) return(NULL) + + # Convert to data.table. + model_predictions <- .as_data_table(model_predictions) if (object@outcome_type %in% c("binomial", "multinomial")) { # Get class levels and class probability column names class_levels <- get_outcome_class_levels(x = object) - class_probability_columns <- get_class_probability_name(x = class_levels) # Build a logistic model on top of the predicted class probabilities for # each predicted class probability - for (ii in seq_along(class_probability_columns)) { - # Select current probability column - current_class_probability_column <- class_probability_columns[ii] - + for (ii in seq_along(class_levels)) { # Set positive class flag model_predictions[, "positive_class" := outcome == class_levels[ii]] # Parse formula model_formula <- stats::reformulate( - termlabels = current_class_probability_column, - response = "positive_class") + termlabels = class_levels[ii], + response = "positive_class" + ) # Remove NA from the data.table - model_predictions <- model_predictions[is.finite(get(current_class_probability_column)), ] + model_predictions <- model_predictions[is.finite(get(class_levels[ii])), ] # If the prediction data table returns no or just one (valid) entry, # calibration is not possible. - if (nrow(model_predictions) <= 1) return(NULL) + if (nrow(model_predictions) <= 1L) return(NULL) # Generate the calibration model. calibration_model <- tryCatch( - stats::glm(model_formula, + stats::glm( + model_formula, data = model_predictions, - family = stats::binomial(link = "logit")), - error = identity) + family = stats::binomial(link = "logit") + ), + error = identity + ) # Check if the calibration model was created. if (inherits(calibration_model, "error")) calibration_model <- NULL @@ -51,36 +62,41 @@ # Create calibration model calibration_model_list[[class_levels[ii]]] <- calibration_model } + } else if (object@outcome_type == "survival") { # Parse formula formula <- stats::reformulate( termlabels = "predicted_outcome", - response = quote(survival::Surv(outcome_time, outcome_event))) - + response = quote(survival::Surv(outcome_time, outcome_event)) + ) + # Remove NA from the table model_predictions <- model_predictions[is.finite(predicted_outcome)] # If the prediction data table returns no or just one (valid) entry, # calibration is not possible. - if (nrow(model_predictions) <= 1) return(NULL) + if (nrow(model_predictions) <= 1L) return(NULL) # Generate model - model_control <- survival::coxph.control(iter.max = 100) + model_control <- survival::coxph.control(iter.max = 100L) calibration_model <- tryCatch( - survival::coxph(formula, + survival::coxph( + formula, data = model_predictions, control = model_control, - y = FALSE), - error = identity) - + y = FALSE + ), + error = identity + ) + # Check if the model trained at all. if (inherits(calibration_model, "error")) return(NULL) # Check if the model fitter converged in time. - if (calibration_model$iter >= 100) return(NULL) + if (calibration_model$iter >= 100L) return(NULL) # Store calibration model. - calibration_model_list[[1]] <- calibration_model + calibration_model_list[[1L]] <- calibration_model } # Return list of calibration models @@ -89,64 +105,74 @@ -.apply_recalibration <- function(object, predictions) { +.apply_recalibration <- function(object, prediction_table, data) { # Suppress NOTES due to non-standard evaluation in data.table prob_sum <- NULL # Return predictions if calibration models are missing - if (is_empty(object@calibration_model)) return(predictions) + if (is_empty(object@calibration_model)) return(prediction_table) # Return predictions if it is empty - if (is_empty(predictions)) return(predictions) + if (is_empty(prediction_table)) return(prediction_table) + # Convert to data.table. + predictions <- .as_data_table(prediction_table) + if (object@outcome_type %in% c("binomial", "multinomial")) { - # Determine probability columns - class_probability_columns <- get_class_probability_name(x = object) class_levels <- get_outcome_class_levels(x = object) - - # Iterate over calibration models and reconstruct the outcome data table - for (ii in seq_along(class_probability_columns)) { - # Get name of current probability column - current_class_probability_column <- class_probability_columns[ii] + prediction_list <- list() + + # Iterate over the calibration model for each class and obtain the class + # probabilities. + for (ii in seq_along(class_levels)) { # Skip if no calibration model is provided. - if (is.null(object@calibration_model[[class_levels[ii]]])) next + if (is.null(object@calibration_model[[class_levels[ii]]])) { + prediction_list[[class_levels[ii]]] <- predictions[[class_levels[ii]]] + next + } # Predict calibrated probabilities using the calibration model for the # current column. - predicted_probability <- stats::predict.glm( + prediction_list[[class_levels[ii]]] <- stats::predict.glm( object = object@calibration_model[[class_levels[ii]]], newdata = predictions, - type = "response") - - # Replace column contents with predicted probabilities. - predictions[, (current_class_probability_column) := predicted_probability] + type = "response" + ) } - - # Normalise predicted probabilities to 1 - predictions[, "prob_sum" := rowSums(.SD, na.rm = TRUE), .SDcols = class_probability_columns] - predictions[, (class_probability_columns) := lapply(.SD, "/", prob_sum), .SDcols = class_probability_columns] - - # Drop sum of probabilities + + # Convert list of class probabilities to a data.table. + predictions <- data.table::as.data.table(prediction_list) + + # Normalise predicted probabilities to 1.0. + predictions[, "prob_sum" := rowSums(.SD, na.rm = TRUE), .SDcols = class_levels] + predictions[, (class_levels) := lapply(.SD, "/", prob_sum), .SDcols = class_levels] predictions[, "prob_sum" := NULL] - # Update predicted outcome with class with maximum predicted probability - max_prob_class <- factor( - x = class_levels[predictions[, max.col(.SD), .SDcols = class_probability_columns]], - levels = class_levels) - - predictions[, "predicted_class" := max_prob_class] + # Create new prediction table object. + prediction_table <- as_prediction_table( + x = predictions, + type = "classification", + data = data, + model_object = object + ) } else if (object@outcome_type == "survival") { # Predict cox PH relative risk predicted_outcome_value <- predict( - object = object@calibration_model[[1]], + object = object@calibration_model[[1L]], newdata = predictions, - type = "risk") - - # Replace in table - predictions[, "predicted_outcome" := predicted_outcome_value] + type = "risk" + ) + + # Create new prediction table object. + prediction_table <- as_prediction_table( + x = predicted_outcome_value, + type = "hazard_ratio", + data = data, + model_object = object + ) } - return(predictions) + return(prediction_table) } diff --git a/R/LearnerRiskStratification.R b/R/LearnerRiskStratification.R new file mode 100644 index 00000000..16bc0771 --- /dev/null +++ b/R/LearnerRiskStratification.R @@ -0,0 +1,368 @@ +#' @include PredictionTable.R + +.get_available_stratification_methods <- function() { + return(c("median", "fixed", "optimised", "mean", "mean_trim", "mean_winsor")) +} + + + +.find_survival_grouping_thresholds <- function(object, data) { + if (!object@outcome_type %in% c("survival")) { + ..error_reached_unreachable_code(paste0( + ".find_survival_grouping_thresholds: only available for ", + "survival outcome. Found: ", object@outcome_type + )) + } + + # Load settings to find survival thresholds + settings <- get_settings() + + # Set time_max + time_max <- settings$eval$time_max + + # Generate prediction table + prediction_table <- .predict( + object = object, + data = data, + allow_recalibration = TRUE, + time = time_max + ) + + # Check if any predictions are valid. + if (!any_predictions_valid(prediction_table)) return(NULL) + + # Remove data with missing predictions. + prediction_table <- remove_invalid_predictions(prediction_table) + km_info_list <- list() + + # Iterate over stratification methods + for (cut_off_method in settings$eval$strat_method) { + if (cut_off_method == "median") { + # Identify threshold + cutoff <- .find_quantile_threshold( + x = prediction_table, + quantiles = 0.5 + ) + + } else if (cut_off_method == "fixed") { + # Identify thresholds + cutoff <- .find_quantile_threshold( + x = prediction_table, + quantiles = settings$eval$strat_quant_threshold + ) + + } else if (cut_off_method == "optimised") { + # Identify threshold + cutoff <- .find_maxstat_threshold(x = prediction_table) + + } else if (cut_off_method %in% c("mean", "mean_winsor", "mean_trim")) { + # Identify threshold + cutoff <- .find_mean_threshold( + x = prediction_table, + method = cut_off_method + ) + + } else { + ..error_reached_unreachable_code(paste0( + ".find_survival_grouping_thresholds: encountered an unknown ", + "threshold type:", cut_off_method + )) + } + + # Find corresponding sizes of the generated groups + risk_group <- .apply_risk_threshold( + x = prediction_table, + cutoff = cutoff + ) + + group_size <- .get_risk_group_sizes(risk_group = risk_group) + + # Populate method_list + method_list <- list( + "method" = cut_off_method, + "cutoff" = cutoff, + "group_size" = group_size + ) + + # Attach method_list to the general km_info_list + km_info_list[[cut_off_method]] <- method_list + } + + # Add stratification methods + out_list <- list( + "stratification_method" = settings$eval$strat_method, + "parameters" = km_info_list, + "time_max" = time_max + ) + + return(out_list) +} + + +# .find_mean_threshold --------------------------------------------------------- +setGeneric(".find_mean_threshold", function(x, ...) standardGeneric(".find_mean_threshold")) + +setMethod( + ".find_mean_threshold", + signature(x = "predictionTableSurvival"), + function(x, method, ...) { + data_slot <- ifelse(.is_merged_prediction_table(x), "data", "prediction_data") + values <- slot(x, data_slot)$predicted_outcome + + if (method == "mean") { + return(mean(values)) + + } else if (method == "mean_trim") { + return(trim(values)) + + } else if (method == "mean_winsor") { + return(winsor(values)) + + } else { + ..error_reached_unreachable_code(paste0( + "The provided method for setting the mean risk stratification method was not recognised: ", + method + )) + } + } +) + + +# .find_quantile_threshold ----------------------------------------------------- +setGeneric(".find_quantile_threshold", function(x, ...) standardGeneric(".find_quantile_threshold")) + +setMethod( + ".find_quantile_threshold", + signature(x = "predictionTableSurvival"), + function(x, quantiles, ...) { + + # Order quantiles in ascending order. + quantiles <- quantiles[order(quantiles)] + + # Extract values + data_slot <- ifelse(.is_merged_prediction_table(x), "data", "prediction_data") + values <- slot(x, data_slot)$predicted_outcome + + # Return threshold values + return(stats::quantile( + x = values, + probs = quantiles, + names = FALSE, + na.rm = TRUE + )) + } +) + +setMethod( + ".find_quantile_threshold", + signature(x = "predictionTableSurvivalTime"), + function(x, quantiles, ...) { + # For time-like predictions, we should use the complements of the provided + # quantiles. + quantiles <- abs(1.0 - quantiles) + + # Pass to main method with updated quantiles. + return(callNextMethod(x = x, quantiles = quantiles)) + } +) + + +# .find_maxstat_threshold ------------------------------------------------------ +setGeneric(".find_maxstat_threshold", function(x, ...) standardGeneric(".find_maxstat_threshold")) + +setMethod( + ".find_maxstat_threshold", + signature(x = "predictionTableSurvival"), + function(x, ...) { + require_package( + x = "maxstat", + purpose = "to determine an optimal risk threshold" + ) + + # Convert prediction_table to a data.table. + x <- .as_data_table(x) + + # Check for invariant features. + if (stats::var(x$predicted_outcome) == 0.0) { + return(x$predicted_outcome[1L]) + } + + # Perform maxstat test + h <- tryCatch( + maxstat::maxstat.test( + survival::Surv(outcome_time, outcome_event) ~ predicted_outcome, + data = x, + smethod = "LogRank", + minprop = 0.10, + maxprop = 0.90 + ), + error = identity + ) + + # Check that maxstat.test did not produce an error. + if (inherits(h, "error")) { + return(mean(x$predicted_outcome, na.rm = TRUE)) + } + + # Check if at least 4 unique values are present for the smoothing spline + if (length(h$cuts) < 4L) { + return(unname(h$estimate)) + } + + # Smoothed scores + spline_fit <- tryCatch( + stats::smooth.spline(x = h$cuts, y = h$stats)$fit, + error = identity + ) + + # Capture error. + if (inherits(spline_fit, "error")) { + return(unname(h$estimate)) + } + + # Predict scores on a fine grid + x_sample_cuts <- seq( + from = min(h$cuts), + to = max(h$cuts), + length.out = 100L + ) + + test_scores <- stats::predict( + object = spline_fit, + x = x_sample_cuts + )$y + + return(x_sample_cuts[which.max(test_scores)]) + } +) + + +# .apply_risk_threshold -------------------------------------------------------- +setGeneric(".apply_risk_threshold", function(x, ...) standardGeneric(".apply_risk_threshold")) + +setMethod( + ".apply_risk_threshold", + signature(x = "predictionTableSurvival"), + function(x, cutoff, invert = FALSE) { + + # Convert to data table and get the predicted values. + x <- .as_data_table(x)$predicted_outcome + + # Initialise risk group + risk_group <- rep.int(1L, times = length(x)) + + # Iterate over cutoffs and define risk groups + for (current_cutoff in cutoff) { + # We assume that risk groups go from 1 (low risk) to k (high risk), with + # k-1 being the number of provided cutoff values. + if (invert) { + risk_group <- risk_group + as.numeric(x < current_cutoff) + } else { + risk_group <- risk_group + as.numeric(x >= current_cutoff) + } + } + + # Convert to factor + risk_group <- .assign_risk_group_names( + risk_group = risk_group, + cutoff = cutoff + ) + + # Replace non-finite predicted values by NA. + risk_group[!is.finite(x)] <- NA + + # Return risk groups + return(risk_group) + } +) + +setMethod( + ".apply_risk_threshold", + signature(x = "predictionTableSurvivalTime"), + function(x, cutoff, invert = TRUE) { + # For prediction of survival times, pass to + return( + callNextMethod( + x = x, + cutoff = cutoff, + invert = TRUE + ) + ) + } +) + + + +.get_risk_group_sizes <- function(risk_group) { + # Suppress NOTES due to non-standard evaluation in data.table + indicated_group <- NULL + + # Find group sizes + group_table <- data.table::data.table("indicated_group" = risk_group) + group_table <- group_table[, list("group_size" = .N), by = "indicated_group"][order(indicated_group)] + + # Get group sizes and set names + group_sizes <- group_table$group_size / length(risk_group) + names(group_sizes) <- group_table$indicated_group + + return(group_sizes) +} + + + + +.assign_risk_group_names <- function(risk_group, cutoff) { + # Determine the number of risk groups + n_groups <- length(cutoff) + 1L + + if (n_groups == 2L) { + # Stratification into low and high-risk groups + y <- factor( + x = risk_group, + levels = seq_len(n_groups), + labels = c("low", "high"), + ordered = TRUE + ) + + } else if (n_groups == 3L) { + # Stratification into low, moderate and high-risk groups + y <- factor( + x = risk_group, + levels = seq_len(n_groups), + labels = c("low", "moderate", "high"), + ordered = TRUE + ) + + } else { + # Assign numbers + y <- factor( + x = risk_group, + levels = seq_len(n_groups), + ordered = TRUE + ) + } + + return(y) +} + + + +get_mean_risk_group <- function(risk_group) { + # Determine the mean average risk group. This requires discretisation + # as rounding toward the nearest group would overinflate center groups. + group_names <- levels(risk_group) + n <- length(group_names) + + # Discretise bins floor((mu - 1) / ((n-1) / n)) + 1. See fixed bin size + # discretisation. + risk_group_num <- as.integer(floor(n * (mean(as.numeric(risk_group), na.rm = TRUE) - 1.0) / (n - 1.0))) + 1L + + # Check if the risk_group_num still falls within the range + risk_group_num <- ifelse(risk_group_num > n, n, risk_group_num) + + return(factor( + x = group_names[risk_group_num], + levels = group_names, + ordered = TRUE + )) +} diff --git a/R/LearnerS4Cox.R b/R/LearnerS4Cox.R index ab2fb7f8..1b3eb57c 100644 --- a/R/LearnerS4Cox.R +++ b/R/LearnerS4Cox.R @@ -75,7 +75,8 @@ setMethod( } else { ..error_reached_unreachable_code( - "get_prediction_type,familiarCoxPH: unknown type") + "get_prediction_type,familiarCoxPH: unknown type" + ) } } ) @@ -87,20 +88,23 @@ setMethod( "..train", signature( object = "familiarCoxPH", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Check if training data is ok. if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -113,7 +117,8 @@ setMethod( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Find feature columns in the data. feature_columns <- get_feature_columns(x = encoded_data$encoded_data) @@ -121,10 +126,11 @@ setMethod( # Parse formula formula <- stats::reformulate( termlabels = feature_columns, - response = quote(survival::Surv(outcome_time, outcome_event))) + response = quote(survival::Surv(outcome_time, outcome_event)) + ) # Generate model. - model_control <- survival::coxph.control(iter.max = 100) + model_control <- survival::coxph.control(iter.max = 100L) # Train the model model <- do.call_with_handlers( @@ -133,7 +139,9 @@ setMethod( formula, "data" = encoded_data$encoded_data@data, "control" = model_control, - "y" = FALSE)) + "y" = FALSE + ) + ) # Extract values. object <- ..update_warnings(object = object, model$warning) @@ -146,10 +154,11 @@ setMethod( } # Check if the model fitter converged in time. - if (model$iter >= 100) { + if (model$iter >= 100L) { return(callNextMethod(object = ..update_errors( object = object, - "Model fitter ran out of iterations and did not converge."))) + "Model fitter ran out of iterations and did not converge." + ))) } # Check if all coefficients could not be estimated. Sometimes models could @@ -158,10 +167,11 @@ setMethod( # selected during hyperparameter optimisation, especially in situations # where there is not a lot of signal. Checking for non-finite coefficients # is an easy way to figure out if the model is not properly trained. - if (any(!sapply(stats::coef(model), is.finite))) { + if (!all(sapply(stats::coef(model), is.finite))) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_failed_model_coefficient_estimation()))) + ..error_message_failed_model_coefficient_estimation() + ))) } # Add model @@ -184,7 +194,8 @@ setMethod( "..train_naive", signature( object = "familiarCoxPH", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Turn into a Naive model. object <- methods::new("familiarNaiveCoxModel", object) @@ -192,7 +203,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -203,100 +215,89 @@ setMethod( "..predict", signature( object = "familiarCoxPH", - data = "dataObject"), - function(object, data, type = "default", ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") - + + # Check if the model was trained. + if (!model_is_trained(object)) { + return(callNextMethod()) + } + + # Check if the data is empty. + if (is_empty(data)) { + return(callNextMethod()) + } + if (type == "default") { - # Default method -------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } + # default ---------------------------------------------------------------- # Encode data so that the features are the same as in the training. encoded_data <- encode_categorical_variables( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = encoded_data$encoded_data, - type = type) + drop_levels = FALSE + ) # Use the model for prediction. model_predictions <- predict( object = object@model, newdata = encoded_data$encoded_data@data, - type = "risk") - - # Update the prediction table. - prediction_table[, "predicted_outcome" := model_predictions] - + type = "risk" + ) + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "hazard_ratio", + data = data, + model_object = object + ) + return(prediction_table) - } else { - # User-specified method -------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(NULL) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(NULL) - } + } else if (type == "survival_probability") { + # survival probability --------------------------------------------------- + + # If time is unset, read the max time stored by the model. + if (is.null(time)) time <- object@settings$time_max + + return(.survival_probability_relative_risk( + object = object, + data = data, + time = time + )) + + } else if (!.is_available_prediction_type(type)) { + # user-specified --------------------------------------------------------- # Encode data so that the features are the same as in the training. encoded_data <- encode_categorical_variables( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) return(predict( object = object@model, newdata = encoded_data$encoded_data@data, type = type, - ...)) - } - } -) - - - -# ..predict_survival_probability ----------------------------------------------- -setMethod( - "..predict_survival_probability", - signature( - object = "familiarCoxPH", - data = "dataObject"), - function(object, data, time, ...) { - if (object@outcome_type != "survival") { - return(callNextMethod()) + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } - - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - return(.survival_probability_relative_risk( - object = object, - data = data, - time = time)) } ) @@ -317,7 +318,8 @@ setMethod( # Define p-values coefficient_z_values <- tryCatch( .compute_z_statistic(object), - error = identity) + error = identity + ) if (inherits(coefficient_z_values, "error")) { return(callNextMethod()) @@ -326,7 +328,7 @@ setMethod( # Remove any coefficients for the intercept. coefficient_z_values <- coefficient_z_values[names(coefficient_z_values) != "(Intercept)"] - if (length(coefficient_z_values) == 0) { + if (length(coefficient_z_values) == 0L) { return(callNextMethod()) } @@ -334,10 +336,12 @@ setMethod( vimp_object <- methods::new("vimpTable", vimp_table = data.table::data.table( "score" = abs(coefficient_z_values), - "name" = names(coefficient_z_values)), + "name" = names(coefficient_z_values) + ), encoding_table = object@encoding_reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } diff --git a/R/LearnerS4GLM.R b/R/LearnerS4GLM.R index 99af2e33..639a4a78 100644 --- a/R/LearnerS4GLM.R +++ b/R/LearnerS4GLM.R @@ -8,10 +8,12 @@ setClass("familiarGLM", contains = "familiarModel", slots = list( "encoding_reference_table" = "ANY", - "feature_order" = "character"), + "feature_order" = "character" + ), prototype = list( "encoding_reference_table" = NULL, - "feature_order" = character()) + "feature_order" = character() + ) ) # initialize ------------------------------------------------------------------- @@ -50,31 +52,37 @@ setMethod( # Check outcome type and learner. if ( outcome_type == "binomial" && - learner %in% c("glm", "glm_logistic", "glm_probit", "glm_cauchy", "glm_loglog")) { + learner %in% c("glm", "glm_logistic", "glm_probit", "glm_cauchy", "glm_loglog") + ) { return(TRUE) } else if ( outcome_type == "multinomial" && - learner %in% c("glm", "glm_multinomial")) { + learner %in% c("glm", "glm_multinomial") + ) { return(TRUE) } else if ( outcome_type == "continuous" && learner %in% c( "glm", "glm_log", "glm_gaussian", "glm_log_gaussian", - "glm_inv_gaussian", "glm_poisson", "glm_log_poisson")) { + "glm_inv_gaussian", "glm_poisson", "glm_log_poisson" + ) + ) { return(TRUE) } else if ( outcome_type == "survival" && - learner %in% c("glm")) { + learner %in% c("glm") + ) { return(TRUE) } else if ( outcome_type == "count" && - learner %in% c("glm", "glm_poisson", "glm_log_poisson")) { + learner %in% c("glm", "glm_poisson", "glm_log_poisson") + ) { ..deprecation_count() - return(TRUE) + return(FALSE) } return(FALSE) @@ -105,7 +113,8 @@ setMethod( # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size( data = data, - restrict_samples = TRUE) + restrict_samples = TRUE + ) # model family ------------------------------------------------------------- @@ -114,13 +123,15 @@ setMethod( x = object@learner, pattern = "glm", replacement = "", - fixed = TRUE) + fixed = TRUE + ) if (fam != "") { fam <- sub( x = fam, pattern = "_", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } # Determine the family or families. @@ -131,8 +142,6 @@ setMethod( family_default <- c("logistic", "probit", "loglog", "cauchy") } else if (outcome_type == "continuous") { family_default <- c("gaussian", "log_gaussian", "inv_gaussian", "poisson", "log_poisson") - } else if (outcome_type == "count") { - family_default <- c("poisson", "log_poisson") } else if (outcome_type == "multinomial") { family_default <- "multinomial" } else if (outcome_type == "survival") { @@ -146,8 +155,6 @@ setMethod( # according to the outcome type. if (outcome_type == "continuous") { family_default <- c("log_gaussian", "log_poisson") - } else if (outcome_type == "count") { - family_default <- "log_poisson" } } else { @@ -160,13 +167,15 @@ setMethod( default = family_default, type = "factor", range = family_default, - randomise = ifelse(length(family_default) > 1, TRUE, FALSE)) + randomise = length(family_default) > 1L + ) # sample weighting method -------------------------------------------------- # Class imbalances may lead to learning majority classes. This can be # partially mitigated by increasing weight of minority classes. param$sample_weighting <- .get_default_sample_weighting_method( - outcome_type = outcome_type) + outcome_type = outcome_type + ) # effective number of samples beta ----------------------------------------- # Specifies the beta parameter for effective number sample weighting method. @@ -174,8 +183,10 @@ setMethod( param$sample_weighting_beta <- .get_default_sample_weighting_beta( method = c( param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type = outcome_type) + user_list$sample_weighting + ), + outcome_type = outcome_type + ) return(param) } @@ -210,7 +221,8 @@ setMethod( "..train", signature( object = "familiarGLM", - data = "dataObject"), + data = "dataObject" + ), function(object, data, approximate = FALSE, ...) { # For survival outcomes, switch to familiarCoxPH. if (object@outcome_type == "survival") { @@ -220,21 +232,24 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } # Check if training data is ok. if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -247,7 +262,8 @@ setMethod( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Find feature columns in the data. feature_columns <- get_feature_columns(x = encoded_data$encoded_data) @@ -255,7 +271,8 @@ setMethod( # Parse formula formula <- stats::reformulate( termlabels = feature_columns, - response = quote(outcome)) + response = quote(outcome) + ) # Get family for glm, which determines how the response and predictors are # linked. @@ -266,23 +283,26 @@ setMethod( data = encoded_data$encoded_data, method = object@hyperparameters$sample_weighting, beta = ..compute_effective_number_of_samples_beta( - object@hyperparameters$sample_weighting_beta), - normalisation = "average_one") + object@hyperparameters$sample_weighting_beta + ), + normalisation = "average_one" + ) - if (object@outcome_type %in% c("binomial", "continuous", "count")) { + if (object@outcome_type %in% c("binomial", "continuous")) { # Faster implementation using fastglm. We keep the stats::glm # implementation in case fastglm disappears from CRAN at some point. version <- ifelse( require_package("fastglm", message_type = "silent"), "fastglm", - "stats") + "stats" + ) if (version == "fastglm") { outcome_data <- encoded_data$encoded_data@data$outcome if (object@outcome_type == "binomial") { # Convert levels to [0, 1] range. - outcome_data <- as.numeric(outcome_data) - 1 + outcome_data <- as.numeric(outcome_data) - 1.0 } # Add intercept. @@ -296,7 +316,9 @@ setMethod( "y" = matrix(outcome_data, ncol = 1L), "weights" = weights, "family" = family, - "method" = 3L)) + "method" = 3L + ) + ) } else { model <- do.call_with_handlers( @@ -307,7 +329,9 @@ setMethod( "family" = family, "model" = FALSE, "x" = FALSE, - "y" = FALSE)) + "y" = FALSE + ) + ) } } else if (object@outcome_type == "multinomial") { max_iterations <- ifelse(approximate, 100L, 500L) @@ -323,12 +347,15 @@ setMethod( "maxit" = max_iterations, "abstol" = absolute_tolerance, "reltol" = relative_tolerance, - "MaxNWts" = Inf)) + "MaxNWts" = Inf + ) + ) } else { ..error_reached_unreachable_code(paste0( "..train,familiarGLM: unknown outcome type: ", - object@outcome_type)) + object@outcome_type + )) } # Extract values. @@ -347,10 +374,11 @@ setMethod( # selected during hyperparameter optimisation, especially in situations # where there is not a lot of signal. Checking for non-finite coefficients # is an easy way to figure out if the model is not properly trained. - if (any(!sapply(stats::coef(model), is.finite))) { + if (!all(sapply(stats::coef(model), is.finite))) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_failed_model_coefficient_estimation()))) + ..error_message_failed_model_coefficient_estimation() + ))) } # Add model @@ -376,7 +404,8 @@ setMethod( "..train_naive", signature( object = "familiarGLM", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # For survival outcomes, switch to familiarCoxPH. if (object@outcome_type == "survival") { @@ -386,7 +415,8 @@ setMethod( return(..train_naive( object = object, data = data, - ...)) + ... + )) } # Turn into a Naive model. @@ -395,7 +425,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -406,75 +437,79 @@ setMethod( "..predict", signature( object = "familiarGLM", - data = "dataObject"), - function(object, data, type = "default", ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) { + return(callNextMethod()) + } + + # Check if the data is empty. + if (is_empty(data)) { + return(callNextMethod()) + } + + # Encode data so that the features are the same as in the training. + encoded_data <- encode_categorical_variables( + data = data, + object = object, + encoding_method = "dummy", + drop_levels = FALSE + ) + + if (inherits(object@model, "fastglm")) { + encoded_data$encoded_data@data[, "intercept__" := 1.0] + } + if (type == "default") { - # Default method --------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) - - # Add intercept variable, because by default, fastglm does not fit - # an intercept. - if (inherits(object@model, "fastglm")) { - encoded_data$encoded_data@data[, "intercept__" := 1.0] - } - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = encoded_data$encoded_data, - type = type) + # default ---------------------------------------------------------------- if (object@outcome_type == "binomial") { ## Binomial outcomes --------------------------------------------------- + class_levels <- get_outcome_class_levels(x = object) + prediction_list <- list() + if (inherits(object@model, "fastglm")) { # For fastglm::fastglm models. model_predictions <- suppressWarnings(predict( object = object@model, newdata = as.matrix( - encoded_data$encoded_data@data[, mget(c(object@feature_order, "intercept__"))]), - type = "response")) + encoded_data$encoded_data@data[, mget(c(object@feature_order, "intercept__"))] + ), + type = "response" + )) } else { # For stats::glm models. model_predictions <- suppressWarnings(predict( object = object@model, newdata = encoded_data$encoded_data@data, - type = "response")) + type = "response" + )) } - # Obtain class levels. - class_levels <- get_outcome_class_levels(x = object) - - # Add class probabilities (glm always gives probability for the - # second class). - class_probability_columns <- get_class_probability_name(x = object) - prediction_table[, (class_probability_columns[1]) := 1.0 - model_predictions] - prediction_table[, (class_probability_columns[2]) := model_predictions] - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply(prediction_table[, mget(class_probability_columns)], 1, which.max)] - class_predictions <- factor(class_predictions, levels = class_levels) - prediction_table[, "predicted_class" := class_predictions] + # Set as list so that the positive class can be directly inferred + # without throwing a warning. + prediction_list[[tail(class_levels, n = 1L)]] <- model_predictions + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) } else if (object@outcome_type == "multinomial") { ## Multinomial outcomes ------------------------------------------------ @@ -489,36 +524,29 @@ setMethod( } else { # For VGAM::vglm ..deprecation_vgam() - - model_predictions <- suppressWarnings( - VGAM::predictvglm( - object = object@model, - newdata = encoded_data$encoded_data@data, - type = "response" - ) - ) + return(callNextMethod()) } - # Obtain class levels. class_levels <- get_outcome_class_levels(x = object) - - # Add class probabilities. - class_probability_columns <- get_class_probability_name(x = object) - for (ii in seq_along(class_probability_columns)) { + prediction_list <- list() + for (ii in seq_along(class_levels)) { if (is.matrix(model_predictions)) { - prediction_table[, (class_probability_columns[ii]) := model_predictions[, ii]] + prediction_list[[class_levels[ii]]] <- model_predictions[, ii] } else { - prediction_table[, (class_probability_columns[ii]) := model_predictions[ii]] + prediction_list[[class_levels[ii]]] <- model_predictions[ii] } } - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply(prediction_table[, mget(class_probability_columns)], 1, which.max)] - class_predictions <- factor(class_predictions, levels = class_levels) - prediction_table[, "predicted_class" := class_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) - } else if (object@outcome_type %in% c("continuous", "count")) { - ## Count and continuous outcomes --------------------------------------- + } else if (object@outcome_type %in% c("continuous")) { + ## Continuous outcomes ------------------------------------------------- if (inherits(object@model, "fastglm")) { # For fastglm::fastglm models. @@ -526,8 +554,11 @@ setMethod( predict( object = object@model, newdata = as.matrix( - encoded_data$encoded_data@data[, mget(c(object@feature_order, "intercept__"))]), - type = "response")) + encoded_data$encoded_data@data[, mget(c(object@feature_order, "intercept__"))] + ), + type = "response" + ) + ) } else { # For stats::glm models. @@ -535,51 +566,40 @@ setMethod( predict( object = object@model, newdata = encoded_data$encoded_data@data, - type = "response")) + type = "response" + ) + ) } - # Add regression. - prediction_table[, "predicted_outcome" := model_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "regression", + data = data, + model_object = object + ) + } else { ..error_outcome_type_not_implemented(object@outcome_type) } return(prediction_table) - } else { - # User-specified method -------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) - - if (inherits(object@model, "fastglm")) { - encoded_data$encoded_data@data[, "intercept__" := 1.0] - } + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- - if (object@outcome_type %in% c("continuous", "count", "binomial")) { - ## Binomial, count and continuous outcomes ----------------------------- + if (object@outcome_type %in% c("continuous", "binomial")) { + ## Binomial and continuous outcomes ------------------------------------ if (inherits(object@model, "fastglm")) { return(predict( object = object@model, newdata = as.matrix( - encoded_data$encoded_data@data[, mget(c(object@feature_order, "intercept__"))]), + encoded_data$encoded_data@data[, mget(c(object@feature_order, "intercept__"))] + ), type = type, - ...)) + ... + )) } else { # Use the model for prediction. @@ -587,7 +607,8 @@ setMethod( object = object@model, newdata = encoded_data$encoded_data@data, type = type, - ...)) + ... + )) } } else if (object@outcome_type == "multinomial") { @@ -598,23 +619,20 @@ setMethod( return(predict(object@model, newdata = encoded_data$encoded_data@data[, mget(c(object@feature_order, "intercept__"))], type = type, - ...)) + ... + )) } else { # For VGAM::vglm ..deprecation_vgam() - - # Use the model for prediction. - return(VGAM::predictvglm( - object = object@model, - newdata = encoded_data$encoded_data@data, - type = type, - ...)) + return(callNextMethod()) } } else { ..error_outcome_type_not_implemented(object@outcome_type) } + } else { + ..error_no_predictions_possible(object, type) } } ) @@ -639,7 +657,8 @@ setMethod( # Compute z-values coefficient_z_values <- tryCatch( .compute_z_statistic(object, fix_all_missing = TRUE), - error = identity) + error = identity + ) if (inherits(coefficient_z_values, "error")) { return(callNextMethod()) @@ -647,13 +666,8 @@ setMethod( if (is(object@model, "vglm")) { ..deprecation_vgam() + return(callNextMethod()) - # Parse coefficient names. vglm adds :1 and :2 (and so on) to - # coefficient names. - coefficient_names <- strsplit(x = names(coefficient_z_values), split = ":", fixed = TRUE) - coefficient_names <- sapply(coefficient_names, function(coefficient_name) coefficient_name[1]) - names(coefficient_z_values) <- coefficient_names - } else if (inherits(object@model, "nnet")) { coefficient_names <- colnames(coefficient_z_values) coefficient_names <- rep(coefficient_names, each = nrow(coefficient_z_values)) @@ -663,16 +677,18 @@ setMethod( # Remove intercept from the coefficients. coefficient_z_values <- coefficient_z_values[ - !names(coefficient_z_values) %in% c("(Intercept)", "intercept__")] + !names(coefficient_z_values) %in% c("(Intercept)", "intercept__") + ] - if (length(coefficient_z_values) == 0) { + if (length(coefficient_z_values) == 0L) { return(callNextMethod()) } # Assign to variable importance table. vimp_table <- data.table::data.table( "score" = abs(coefficient_z_values), - "name" = names(coefficient_z_values)) + "name" = names(coefficient_z_values) + ) # Merge by name (vglm coefficients can occur multiple times for the same # feature). @@ -683,7 +699,8 @@ setMethod( vimp_table = vimp_table, encoding_table = object@encoding_reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } @@ -705,7 +722,8 @@ setMethod( # Check that the family hyperparameter exists. if (!is.character(family) && !is.factor(family)) { ..error_reached_unreachable_code( - "..get_distribution_family,familiarGLM: family hyperparameter was not set.") + "..get_distribution_family,familiarGLM: family hyperparameter was not set." + ) } # Load families for linear regression @@ -731,7 +749,8 @@ setMethod( family_fun <- "_placeholder_" } else { ..error_reached_unreachable_code(paste0( - "..get_distribution_family,familiarGLM: unknown family.", family)) + "..get_distribution_family,familiarGLM: unknown family.", family + )) } return(family_fun) @@ -750,14 +769,16 @@ setMethod( x = method, pattern = "glm", replacement = "", - fixed = TRUE) + fixed = TRUE + ) if (family_str != "") { family_str <- sub( x = family_str, pattern = "_", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } # Determine the family or families. @@ -768,8 +789,6 @@ setMethod( family_default <- c("logistic") } else if (object@outcome_type == "continuous") { family_default <- c("gaussian") - } else if (object@outcome_type == "count") { - family_default <- c("poisson") } else if (object@outcome_type == "multinomial") { family_default <- "multinomial" } else if (object@outcome_type == "survival") { @@ -783,8 +802,6 @@ setMethod( # according to the outcome type. if (object@outcome_type == "continuous") { family_default <- c("log_gaussian") - } else if (object@outcome_type == "count") { - family_default <- "log_poisson" } } else { @@ -859,26 +876,6 @@ setMethod( } else if (inherits(object@model, "vglm")) { ..deprecation_vgam() - - # Update model by removing the call. - object@model@call <- call("trimmed") - - # Add show. - object <- .capture_show(object) - - # Remove .Environment. - object@model@terms$terms <- .replace_environment(object@model@terms$terms) - object@model@misc$formula <- .replace_environment(object@model@misc$formula) - - # Remove elements that contain sample-specific values. - object@model@predictors <- matrix(0) - object@model@effects <- numeric(0) - object@model@qr$qr <- NULL - object@model@fitted.values <- matrix(0) - object@model@residuals <- matrix(0) - object@model@weights <- matrix(0) - object@model@x <- matrix(0) - object@model@y <- matrix(0) } # Set is_trimmed to TRUE. diff --git a/R/LearnerS4GLMnet.R b/R/LearnerS4GLMnet.R index a5da69f8..24cff90f 100644 --- a/R/LearnerS4GLMnet.R +++ b/R/LearnerS4GLMnet.R @@ -10,10 +10,12 @@ setClass( contains = "familiarModel", slots = list( "encoding_reference_table" = "ANY", - "feature_order" = "character"), + "feature_order" = "character" + ), prototype = list( "encoding_reference_table" = NULL, - "feature_order" = character()) + "feature_order" = character() + ) ) ## familiarGLMnetRidge --------------------------------------------------------- @@ -91,7 +93,9 @@ setMethod( outcome_type == "survival" && learner %in% c( "elastic_net", "elastic_net_cox", "lasso", "lasso_cox", - "ridge", "ridge_cox")) { + "ridge", "ridge_cox" + ) + ) { return(TRUE) } else if ( @@ -99,7 +103,9 @@ setMethod( learner %in% c( "elastic_net", "elastic_net_gaussian", "elastic_net_poisson", "lasso", "lasso_gaussian", "lasso_poisson", - "ridge", "ridge_gaussian", "ridge_poisson")) { + "ridge", "ridge_gaussian", "ridge_poisson" + ) + ) { return(TRUE) } else if ( @@ -107,7 +113,9 @@ setMethod( learner %in% c( "elastic_net", "elastic_net_multinomial", "lasso", "lasso_multinomial", - "ridge", "ridge_multinomial")) { + "ridge", "ridge_multinomial" + ) + ) { return(TRUE) } else if ( @@ -115,16 +123,20 @@ setMethod( learner %in% c( "elastic_net", "elastic_net_binomial", "lasso", "lasso_binomial", - "ridge", "ridge_binomial")) { + "ridge", "ridge_binomial" + ) + ) { return(TRUE) } else if ( outcome_type == "count" && learner %in% c( "elastic_net", "elastic_net_poisson", "lasso", "lasso_poisson", - "ridge", "ridge_poisson")) { + "ridge", "ridge_poisson" + ) + ) { ..deprecation_count() - return(TRUE) + return(FALSE) } return(FALSE) @@ -161,25 +173,34 @@ setMethod( x = object@learner, pattern = c("elastic_net", "lasso", "ridge"), replacement = "", - fixed = TRUE) + fixed = TRUE + ) if (fam != "") { fam <- sub( x = fam, pattern = "_", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } # Check for lasso_test if (object@learner %in% c("lasso_test_all_fail", "lasso_test_some_fail", "lasso_test_extreme")) { - fam <- "" + fam <- switch( + outcome_type, + "continuous" = "gaussian", + "binomial" = "binomial", + "multinomial" = "multinomial", + "survival" = "cox" + ) } # Determine number of subjects n_samples <- data.table::uniqueN( data@data, - by = get_id_columns(id_depth = "series")) + by = get_id_columns(id_depth = "series") + ) # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size(data = data) @@ -188,8 +209,6 @@ setMethod( if (fam == "") { if (outcome_type == "continuous") { family_default <- c("gaussian", "poisson") - } else if (outcome_type == "count") { - family_default <- "poisson" } else if (outcome_type == "binomial") { family_default <- "binomial" } else if (outcome_type == "multinomial") { @@ -207,28 +226,31 @@ setMethod( default = family_default, type = "factor", range = family_default, - randomise = ifelse(length(family_default) > 1, TRUE, FALSE)) + randomise = length(family_default) > 1L + ) # lambda indicating the optimal model complexity --------------------------- param$lambda_min <- .set_hyperparameter( default = "lambda.min", type = "factor", range = c("lambda.1se", "lambda.min"), - randomise = FALSE) + randomise = FALSE + ) # number of cross-validation folds ----------------------------------------- # glmnet requires at least 3 folds. The default number of cross-validation # folds may grow up to 20, for data sets > 200 samples. - n_folds_default <- min(c(20, max(c(3, floor(n_samples / 10))))) + n_folds_default <- min(c(20L, max(c(3L, as.integer(floor(n_samples / 10.0)))))) # Set the number of cross-validation folds. param$n_folds <- .set_hyperparameter( default = n_folds_default, type = "integer", - range = c(3, n_samples), - valid_range = c(3, Inf), - randomise = FALSE) + range = c(3L, n_samples), + valid_range = c(3L, Inf), + randomise = FALSE + ) # feature normalisation ---------------------------------------------------- @@ -239,7 +261,8 @@ setMethod( default = FALSE, type = "logical", range = c(FALSE, TRUE), - randomise = FALSE) + randomise = FALSE + ) # sample weighting method ------------------------------------------------- @@ -254,8 +277,10 @@ setMethod( param$sample_weighting_beta <- .get_default_sample_weighting_beta( method = c( param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type = outcome_type) + user_list$sample_weighting + ), + outcome_type = outcome_type + ) if (is(object, "familiarGLMnetElasticNet")) { # elastic net mixing parameter ------------------------------------------- @@ -263,11 +288,12 @@ setMethod( # Set alpha parameter. Alpha = 1 is lasso, alpha = 0 is ridge. glmnet # requires alpha to be in the closed interval [0, 1]. param$alpha <- .set_hyperparameter( - default = c(0, 1 / 3, 2 / 3, 1), + default = c(0.0, 1.0 / 3.0, 2.0 / 3.0, 1.0), type = "numeric", - range = c(0, 1), - valid_range = c(0, 1), - randomise = TRUE) + range = c(0.0, 1.0), + valid_range = c(0.0, 1.0), + randomise = TRUE + ) } # Return hyperparameters @@ -284,9 +310,8 @@ setMethod( function(object, type = "default") { if ( object@outcome_type != "survival" && - object@learner %in% c( - "elastic_net", "elastic_net_cox", "lasso", "lasso_cox", "ridge", - "ridge_cox")) { + object@learner %in% c("elastic_net", "elastic_net_cox", "lasso", "lasso_cox", "ridge", "ridge_cox") + ) { return(callNextMethod()) } @@ -308,12 +333,14 @@ setMethod( "..train", signature( object = "familiarGLMnet", - data = "dataObject"), + data = "dataObject" + ), function( object, data, force_signature = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table original_name <- NULL @@ -321,25 +348,28 @@ setMethod( if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # For data with one feature, switch to familiarGLM. - if (get_n_features(data) == 1) { + if (get_n_features(data) == 1L) { # Create a familiarGLM object. object <- methods::new("familiarGLM", object) return(..train( object = object, data = data, - ...)) + ... + )) } # Check that required packages are loaded and installed. @@ -352,7 +382,8 @@ setMethod( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Find feature columns in the data. feature_columns <- get_feature_columns(x = encoded_data$encoded_data) @@ -361,7 +392,8 @@ setMethod( if (object@outcome_type == "survival") { outcome_data <- survival::Surv( data@data$outcome_time, - data@data$outcome_event) + data@data$outcome_event + ) } else { outcome_data <- data@data$outcome @@ -377,39 +409,42 @@ setMethod( outcome_type = object@outcome_type, data = encoded_data$encoded_data@data, stratify = FALSE, - return_fold_id = TRUE) + return_fold_id = TRUE + ) # Order according to samples in encoded_data$encoded_data@data so that # fold_id corresponds to the correct rows. fold_table <- merge( x = fold_table, y = encoded_data$encoded_data@data[, mget(id_columns)], - by = id_columns) + by = id_columns + ) if (force_signature) { # Find signature features. signature_feature <- names(object@feature_info)[sapply(object@feature_info, is_in_signature)] - if (length(signature_feature) > 0) { + if (length(signature_feature) > 0.0) { # Initially mark all features for shrinkage. - penalty_factor <- rep(1, length(feature_columns)) + penalty_factor <- rep(1.0, length(feature_columns)) # Update all signature features that were not encoded. - penalty_factor[feature_columns %in% signature_feature] <- 0 + penalty_factor[feature_columns %in% signature_feature] <- 0.0 # Update all signatures features that were encoded. encoded_signature <- encoded_data$reference_table[ - original_name %in% signature_feature]$reference_name - penalty_factor[feature_columns %in% encoded_signature] <- 0 + original_name %in% signature_feature + ]$reference_name + penalty_factor[feature_columns %in% encoded_signature] <- 0.0 } else { # Allow shrinking of each feature. - penalty_factor <- rep(1, length(feature_columns)) + penalty_factor <- rep(1.0, length(feature_columns)) } } else { # Allow shrinking of each feature. - penalty_factor <- rep(1, length(feature_columns)) + penalty_factor <- rep(1.0, length(feature_columns)) } # Set weights @@ -417,8 +452,10 @@ setMethod( data = encoded_data$encoded_data, method = object@hyperparameters$sample_weighting, beta = ..compute_effective_number_of_samples_beta( - object@hyperparameters$sample_weighting_beta), - normalisation = "average_one") + object@hyperparameters$sample_weighting_beta + ), + normalisation = "average_one" + ) # Get the arguments which are shared between all different objects. learner_arguments <- list( @@ -430,7 +467,8 @@ setMethod( "nfolds" = NULL, "foldid" = fold_table$fold_id, "parallel" = FALSE, - "penalty.factor" = penalty_factor) + "penalty.factor" = penalty_factor + ) # Set learner-specific arguments. if (is(object, "familiarGLMnetRidge")) { @@ -442,13 +480,15 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "..train,familiarGLMnet: encountered unknown learner of unknown class: ", - paste_s(class(object)))) + paste_s(class(object)) + )) } # Train the model. model <- do.call_with_handlers( glmnet::cv.glmnet, - args = learner_arguments) + args = learner_arguments + ) # Extract values. object <- ..update_warnings(object = object, model$warning) @@ -483,9 +523,10 @@ setMethod( "..train_naive", signature( object = "familiarGLMnet", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { - if (object@outcome_type %in% c("count", "continuous", "binomial", "multinomial")) { + if (object@outcome_type %in% c("continuous", "binomial", "multinomial")) { # Turn into a Naive model. object <- methods::new("familiarNaiveModel", object) @@ -497,7 +538,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -508,110 +550,138 @@ setMethod( "..predict", signature( object = "familiarGLMnet", - data = "dataObject"), - function(object, data, type = "default", ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) { + return(callNextMethod()) + } + + # Check if the data is empty. + if (is_empty(data)) { + return(callNextMethod()) + } + + # Encode data so that the features are the same as in the training. + encoded_data <- encode_categorical_variables( + data = data, + object = object, + encoding_method = "dummy", + drop_levels = FALSE + ) + if (type == "default") { - # Default method --------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = encoded_data$encoded_data, - type = type) + # default ---------------------------------------------------------------- if (object@outcome_type == "binomial") { # Binomial outcomes ---------------------------------------------------- + # Obtain class levels. + class_levels <- get_outcome_class_levels(x = object) + # Use the model to predict class probabilities. model_predictions <- predict( object = object@model, newx = as.matrix( - encoded_data$encoded_data@data[, mget(object@feature_order)]), + encoded_data$encoded_data@data[, mget(object@feature_order)] + ), s = as.character(object@hyperparameters$lambda_min), - type = "response") - - # Obtain class levels. - class_levels <- get_outcome_class_levels(x = object) - - # Add class probabilities (glmnet always gives probability for the - # second class). - class_probability_columns <- get_class_probability_name(x = object) - prediction_table[, (class_probability_columns[1]) := 1.0 - model_predictions] - prediction_table[, (class_probability_columns[2]) := model_predictions] + type = "response" + ) - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply( - prediction_table[, mget(class_probability_columns)], 1, which.max)] + # Set as list so that the positive class can be directly inferred + # without throwing a warning. + prediction_list <- list() + prediction_list[[tail(class_levels, n = 1L)]] <- model_predictions - class_predictions <- factor(class_predictions, levels = class_levels) - prediction_table[, "predicted_class" := class_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) } else if (object@outcome_type == "multinomial") { # Multinomial outcomes ------------------------------------------------- + # Obtain class levels. + class_levels <- get_outcome_class_levels(x = object) + # Use the model to predict class probabilities. model_predictions <- predict( object = object@model, newx = as.matrix( - encoded_data$encoded_data@data[, mget(object@feature_order)]), + encoded_data$encoded_data@data[, mget(object@feature_order)] + ), s = as.character(object@hyperparameters$lambda_min), type = "response" - )[, , 1] - - # Obtain class levels. - class_levels <- get_outcome_class_levels(x = object) + )[, , 1L] - # Add class probabilities. - class_probability_columns <- get_class_probability_name(x = object) - for (ii in seq_along(class_probability_columns)) { + prediction_list <- list() + for (ii in seq_along(class_levels)) { if (is.matrix(model_predictions)) { - # Check if model_predictions is a matrix. - prediction_table[, (class_probability_columns[ii]) := model_predictions[, class_levels[ii]]] + prediction_list[[class_levels[ii]]] <- model_predictions[, class_levels[ii]] } else { - # Or not. - prediction_table[, (class_probability_columns[ii]) := model_predictions[class_levels[ii]]] + prediction_list[[class_levels[ii]]] <- model_predictions[class_levels[ii]] } } - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply( - prediction_table[, mget(class_probability_columns)], 1, which.max)] - class_predictions <- factor(class_predictions, levels = class_levels) - prediction_table[, "predicted_class" := class_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) - } else if (object@outcome_type %in% c("survival", "continuous", "count")) { - ##### Survival, count and continuous outcomes#################### + } else if (object@outcome_type == "continuous") { + # Continuous outcomes -------------------------------------------------- # Use the model for prediction. model_predictions <- predict( object = object@model, newx = as.matrix(encoded_data$encoded_data@data[, mget(object@feature_order)]), s = as.character(object@hyperparameters$lambda_min), - type = "response") - - # Add regression. - prediction_table[, "predicted_outcome" := model_predictions] + type = "response" + ) + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "regression", + data = data, + model_object = object + ) + + } else if (object@outcome_type == "survival") { + # Survival outcomes ---------------------------------------------------- + + # Use the model for prediction. + model_predictions <- predict( + object = object@model, + newx = as.matrix(encoded_data$encoded_data@data[, mget(object@feature_order)]), + s = as.character(object@hyperparameters$lambda_min), + type = "response" + ) + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "hazard_ratio", + data = data, + model_object = object + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) @@ -619,61 +689,35 @@ setMethod( return(prediction_table) - } else { - # User-specified method -------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(NULL) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(NULL) - } + } else if (type == "survival_probability" && object@outcome_type == "survival") { + # survival probability --------------------------------------------------- - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, + # If time is unset, read the max time stored by the model. + if (is.null(time)) time <- object@settings$time_max + + return(.survival_probability_relative_risk( object = object, - encoding_method = "dummy", - drop_levels = FALSE) + data = data, + time = time + )) + + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- # Use the model to predict class probabilities. return(predict( object = object@model, newx = as.matrix( - encoded_data$encoded_data@data[, mget(object@feature_order)]), + encoded_data$encoded_data@data[, mget(object@feature_order)] + ), s = as.character(object@hyperparameters$lambda_min), type = type, - ...)) - } - } -) - - - -# ..predict_survival_probability ----------------------------------------------- -setMethod( - "..predict_survival_probability", - signature( - object = "familiarGLMnet", - data = "dataObject"), - function(object, data, time, ...) { - if (object@outcome_type != "survival") { - return(callNextMethod()) + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } - - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - return(.survival_probability_relative_risk( - object = object, - data = data, - time = time)) } ) @@ -693,7 +737,8 @@ setMethod( data = data, get_additional_info = FALSE, trim_model = FALSE, - force_signature = TRUE) + force_signature = TRUE + ) } # Check if the model has been trained upon retry. @@ -714,36 +759,39 @@ setMethod( # Read coefficient lists coefficient_list <- coef( object@model, - s = as.character(object@hyperparameters$lambda_min)) + s = as.character(object@hyperparameters$lambda_min) + ) # Parse into matrix and retrieve row names coefficient_matrix <- sapply(coefficient_list, as.matrix) - rownames(coefficient_matrix) <- dimnames(coefficient_list[[1]])[[1]] + rownames(coefficient_matrix) <- dimnames(coefficient_list[[1L]])[[1L]] # Compute variable importance score - vimp_score <- apply(abs(coefficient_matrix), 1, max) + vimp_score <- apply(abs(coefficient_matrix), 1L, max) } else { # Read coefficient matrix coefficient_matrix <- as.matrix(coef( object@model, - s = as.character(object@hyperparameters$lambda_min))) + s = as.character(object@hyperparameters$lambda_min) + )) # Compute variable importance score - vimp_score <- abs(coefficient_matrix)[, 1] + vimp_score <- abs(coefficient_matrix)[, 1L] } # Remove intercept from the variable importances. vimp_score <- vimp_score[names(vimp_score) != "(Intercept)"] - if (length(vimp_score) == 0) { + if (length(vimp_score) == 0L) { return(callNextMethod()) } # Assign to variable importance table. vimp_table <- data.table::data.table( "score" = vimp_score, - "name" = names(vimp_score)) + "name" = names(vimp_score) + ) # Throw out elements with 0.0 coefficients vimp_table <- vimp_table[score != 0.0] @@ -758,7 +806,8 @@ setMethod( vimp_table = vimp_table, encoding_table = object@encoding_reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } @@ -831,7 +880,8 @@ setMethod( "..predict", signature( object = "familiarGLMnetLassoTestAllFail", - data = "dataObject"), + data = "dataObject" + ), function(object, data, type = "default", ...) { # Check if the model was trained. if (!model_is_trained(object)) { @@ -843,22 +893,22 @@ setMethod( return(callNextMethod()) } - # Check that required packages are loaded and installed. - require_package(object, "predict") - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = encoded_data$encoded_data, - type = type) - + # Get the prediction table using the model. + prediction_table <- callNextMethod() + + if (is_empty(prediction_table)) { + return(prediction_table) + } + + # Insert NA values. + for (current_column in colnames(prediction_table@prediction_data)) { + data.table::set( + prediction_table@prediction_data, + j = current_column, + value = NA + ) + } + return(prediction_table) } ) @@ -870,7 +920,8 @@ setMethod( "..predict", signature( object = "familiarGLMnetLassoTestSomeFail", - data = "dataObject"), + data = "dataObject" + ), function(object, data, type = "default", ...) { # Check if the model was trained. if (!model_is_trained(object)) { @@ -882,25 +933,21 @@ setMethod( return(callNextMethod()) } - # Get an empty prediction table. + # Get a prediction table. prediction_table <- callNextMethod() - if (object@outcome_type %in% c("binomial", "multinomial")) { - # Set all class probabilities for the first row to infinite. - class_probability_columns <- get_class_probability_name(x = object) - for (ii in seq_along(class_probability_columns)) { - prediction_table[1L, (class_probability_columns[ii]) := Inf] - } - - # Set the class to NA. - prediction_table[1L, "predicted_class" := NA] - - } else if (object@outcome_type %in% c("survival", "continuous", "count")) { - # Add regression. - prediction_table[1L, "predicted_outcome" := Inf] - - } else { - ..error_outcome_type_not_implemented(object@outcome_type) + if (is_empty(prediction_table)) { + return(prediction_table) + } + + # Insert NA values. + for (current_column in colnames(prediction_table@prediction_data)) { + data.table::set( + prediction_table@prediction_data, + i = 1L, + j = current_column, + value = NA + ) } return(prediction_table) @@ -913,10 +960,18 @@ setMethod( "..predict", signature( object = "familiarGLMnetLassoTestAllExtreme", - data = "dataObject"), + data = "dataObject" + ), function(object, data, type = "default", ...) { + ..set_max <- function(x) { + y <- numeric(length(x)) + y[which.max(x)] <- 1.0 + names(y) <- names(x) + return(as.list(y)) + } + # Suppress NOTES due to non-standard evaluation in data.table - outcome <- NULL + predicted_outcome <- NULL # Check if the model was trained. if (!model_is_trained(object)) { @@ -928,34 +983,30 @@ setMethod( return(callNextMethod()) } - # Check that required packages are loaded and installed. - require_package(object, "predict") - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) + # Get a prediction table. + prediction_table <- callNextMethod() - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = encoded_data$encoded_data, - type = type) + if (is_empty(prediction_table)) { + return(prediction_table) + } if (object@outcome_type %in% c("binomial", "multinomial")) { # Get class levels class_levels <- get_outcome_class_levels(x = object) - # Set probability to 1.0 for the column that matches the outcome. - class_probability_columns <- get_class_probability_name(x = class_levels) - for (ii in seq_along(class_levels)) { - prediction_table[, (class_probability_columns[ii]) := as.numeric(outcome == class_levels[ii])] - } + # Set probability to 1.0 for the column with the highest predicted + # probability. First add maximum probability for each instance. + x <- prediction_table@prediction_data[, ..set_max(.SD), by = .I] + prediction_table@prediction_data <- x[, mget(class_levels)] + + } else if (object@outcome_type == "continuous") { + # Set predicted outcome. + prediction_table@prediction_data[, "predicted_outcome" := data@data$outcome] - # Set the class to the outcome. - prediction_table[, "predicted_class" := outcome] + } else if (object@outcome_type == "survival") { + # Set predicted outcome. + prediction_table@prediction_data[, "predicted_outcome" := 1.0 / data@data$outcome_time] + prediction_table@prediction_data[, "predicted_outcome" := predicted_outcome - mean(predicted_outcome) + 1.0] } else { ..error_outcome_type_not_implemented(object@outcome_type) @@ -989,70 +1040,6 @@ setMethod( -# ..predict_survival_probability (all fail) ------------------------------------ -setMethod( - "..predict_survival_probability", - signature( - object = "familiarGLMnetLassoTestAllFail", - data = "dataObject"), - function(object, data, time) { - if (object@outcome_type != "survival") { - return(callNextMethod()) - } - - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - # Predict, just to obtain a correctly formatted table. - survival_table <- .survival_probability_relative_risk( - object = object, - data = data, - time = time) - - # Set predicted values to NA. - survival_table[, "survival_probability" := NA_real_] - - return(survival_table) - } -) - - - -# ..predict_survival_probability (all fail) ------------------------------------ -setMethod( - "..predict_survival_probability", - signature( - object = "familiarGLMnetLassoTestSomeFail", - data = "dataObject"), - function(object, data, time) { - if (object@outcome_type != "survival") { - return(callNextMethod()) - } - - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - # Predict, just to obtain a correctly formatted table. - survival_table <- .survival_probability_relative_risk( - object = object, - data = data, - time = time) - - # Set first predicted probability to infinite. - survival_table[1L, "survival_probability" := Inf] - - return(survival_table) - } -) - - - .get_available_glmnet_ridge_learners <- function(show_general = TRUE) { # Learners learners <- c( diff --git a/R/LearnerS4KNN.R b/R/LearnerS4KNN.R index 2eedd907..c6ae6922 100644 --- a/R/LearnerS4KNN.R +++ b/R/LearnerS4KNN.R @@ -6,7 +6,8 @@ NULL # familiarKNN ------------------------------------------------------------------ setClass( "familiarKNN", - contains = "familiarModel") + contains = "familiarModel" +) @@ -38,8 +39,7 @@ setMethod( } else if (object@outcome_type == "count") { ..deprecation_count() - return(TRUE) - + return(FALSE) } return(FALSE) @@ -66,7 +66,8 @@ setMethod( # Get the number of unique series. n_samples <- data.table::uniqueN( data@data, - by = get_id_columns(id_depth = "series")) + by = get_id_columns(id_depth = "series") + ) # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size(data = data) @@ -74,15 +75,19 @@ setMethod( # number of nearest neighbours k ------------------------------------------- # Define the range for the number of nearest neighbour clusters. - k_range <- c(1, max(c(1, ceiling(2 * n_samples^(1 / 3))))) + k_range <- c(1L, max(c(1L, as.integer(ceiling(2L * n_samples^(1.0 / 3.0)))))) # Define the default value. - k_default <- sort(unique(c(1, 2, 5, 10, 20, k_range))) - k_default <- k_default[k_default >= k_range[1] & k_default <= k_range[2]] + k_default <- sort(unique(c(1L, 2L, 5L, 10L, 20L, k_range))) + k_default <- k_default[k_default >= k_range[1L] & k_default <= k_range[2L]] param$k <- .set_hyperparameter( - default = k_default, type = "integer", range = k_range, - valid_range = c(1L, Inf), randomise = TRUE) + default = k_default, + type = "integer", + range = k_range, + valid_range = c(1L, Inf), + randomise = TRUE + ) # distance metric ---------------------------------------------------------- @@ -91,14 +96,16 @@ setMethod( x = object@learner, pattern = c("knn", "k_nearest_neighbours"), replacement = "", - fixed = TRUE) + fixed = TRUE + ) if (distance_metric != "") { distance_metric <- sub( x = distance_metric, pattern = "_", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } if (distance_metric == "") { @@ -110,7 +117,8 @@ setMethod( if (all(sapply( feature_columns, function(ii, data) (is.numeric(data@data[[ii]])), - data = data))) { + data = data + ))) { distance_metric_default <- "euclidean" } else { @@ -128,7 +136,8 @@ setMethod( if (requireNamespace("proxy", quietly = TRUE)) { distance_metric_valid_range <- tolower(unname(unlist(lapply( proxy::pr_DB$get_entries(), - function(list_elem) (list_elem$names))))) + function(list_elem) (list_elem$names) + )))) } else { distance_metric_valid_range <- distance_metric_default_range @@ -140,7 +149,8 @@ setMethod( type = "factor", range = distance_metric_default_range, valid_range = distance_metric_valid_range, - randomise = distance_metric == "") + randomise = distance_metric == "" + ) return(param) } @@ -153,20 +163,23 @@ setMethod( "..train", signature( object = "familiarKNN", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Check if training data is ok. if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -178,7 +191,8 @@ setMethod( # Parse formula formula <- stats::reformulate( termlabels = feature_columns, - response = quote(outcome)) + response = quote(outcome) + ) # Train model. Disable scaling because of bad interaction with # predicting single instances. @@ -188,7 +202,9 @@ setMethod( "data" = data@data, "k" = object@hyperparameters$k, "method" = as.character(object@hyperparameters$distance_metric), - "scale" = FALSE)) + "scale" = FALSE + ) + ) # Extract values. object <- ..update_warnings(object = object, model$warning) @@ -217,9 +233,10 @@ setMethod( "..train_naive", signature( object = "familiarKNN", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { - if (object@outcome_type %in% c("count", "continuous", "binomial", "multinomial")) { + if (object@outcome_type %in% c("continuous", "binomial", "multinomial")) { # Turn into a naive model. object <- methods::new("familiarNaiveModel", object) } @@ -227,7 +244,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -238,29 +256,24 @@ setMethod( "..predict", signature( object = "familiarKNN", - data = "dataObject"), + data = "dataObject" + ), function(object, data, type = "default", ...) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) { + return(callNextMethod()) + } + + # Check if the data is empty. + if (is_empty(data)) { + return(callNextMethod()) + } + if (type == "default") { - # Default method --------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = type) + # default ---------------------------------------------------------------- if (object@outcome_type %in% c("binomial", "multinomial")) { # Binomial and multinomial outcomes------------------------------------- @@ -269,34 +282,40 @@ setMethod( model_predictions <- predict( object = object@model, newdata = data@data, - type = "prob") + type = "prob" + ) - # Obtain class levels. + # Obtain class levels and set class probabilities. class_levels <- get_outcome_class_levels(x = object) - - # Add class probabilities. - class_probability_columns <- get_class_probability_name(x = object) - for (ii in seq_along(class_probability_columns)) { - prediction_table[, (class_probability_columns[ii]) := model_predictions[, class_levels[ii]]] + prediction_list <- list() + for (ii in seq_along(class_levels)) { + prediction_list[[class_levels[ii]]] <- model_predictions[, class_levels[ii]] } - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply( - prediction_table[, mget(class_probability_columns)], 1, which.max)] - class_predictions <- factor(class_predictions, levels = class_levels) - prediction_table[, "predicted_class" := class_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) - } else if (object@outcome_type %in% c("continuous", "count")) { - # Count and continuous outcomes ---------------------------------------- + } else if (object@outcome_type %in% c("continuous")) { + # Continuous outcomes -------------------------------------------------- # Use the model for prediction. model_predictions <- predict( object = object@model, - newdata = data@data) - - # Set outcome. - prediction_table[, "predicted_outcome" := model_predictions] + newdata = data@data + ) + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "regression", + data = data, + model_object = object + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) @@ -304,27 +323,19 @@ setMethod( return(prediction_table) - } else { - # User-specified method -------------------------------------------------- - # Note: the predict method for e1071::sknn specifies class, prob and - # votes. - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(NULL) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(NULL) - } - + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- + # Use the model for prediction. return(predict( object = object@model, newdata = data@data, type = type, - ...)) + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } } ) @@ -378,7 +389,9 @@ setMethod( distance_metrics <- tolower(unname(unlist( lapply( proxy::pr_DB$get_entries(), - function(list_elem) (list_elem$names))))) + function(list_elem) (list_elem$names) + ) + ))) distance_metrics_default <- c("euclidean", "manhattan", "gower") diff --git a/R/LearnerS4MBoost.R b/R/LearnerS4MBoost.R index 4b3a022e..01995d3e 100644 --- a/R/LearnerS4MBoost.R +++ b/R/LearnerS4MBoost.R @@ -2,62 +2,48 @@ #' @include FamiliarS4Classes.R NULL -setClass("familiarMBoost", - contains="familiarModel") - -setClass("familiarMBoostLM", - contains="familiarMBoost", - slots=list("encoding_reference_table" = "ANY", - "feature_order"="character"), - prototype=list("encoding_reference_table" = NULL, - "feature_order"=character())) - -setClass("familiarMBoostTree", - contains="familiarMBoost", - slots=list("encoding_reference_table" = "ANY", - "feature_order"="character"), - prototype=list("encoding_reference_table" = NULL, - "feature_order"=character())) - - -#####initialize (familiarMBoostLM) ############################################# -setMethod("initialize", signature(.Object="familiarMBoostLM"), - function(.Object, ...){ - - # Update with parent class first. - .Object <- callNextMethod() - - # Set package - .Object@package <- "mboost" - - return(.Object) - }) - - -#####initialize (familiarMBoostTree) ########################################### -setMethod("initialize", signature(.Object="familiarMBoostTree"), - function(.Object, ...){ - - # Update with parent class first. - .Object <- callNextMethod() - - # Set package - .Object@package <- c("mboost", "partykit") - - return(.Object) - }) - - -.get_available_mboost_lm_learners <- function(show_general=TRUE){ +setClass("familiarMBoost", contains = "familiarModel") + +setClass( + "familiarMBoostLM", + contains = "familiarMBoost", + slots = list( + "encoding_reference_table" = "ANY", + "feature_order" = "character" + ), + prototype = list( + "encoding_reference_table" = NULL, + "feature_order" = character() + ) +) + +setClass( + "familiarMBoostTree", + contains = "familiarMBoost", + slots = list( + "encoding_reference_table" = "ANY", + "feature_order" = "character" + ), + prototype = list( + "encoding_reference_table" = NULL, + "feature_order" = character() + ) +) + + + +.get_available_mboost_lm_learners <- function(show_general = TRUE) { # Learners - learners <- c("boosted_glm", "boosted_glm_logistic", - "boosted_glm_probit", "boosted_glm_loglog", "boosted_glm_cauchy", "boosted_glm_log", - "boosted_glm_auc", "boosted_glm_gaussian", "boosted_glm_huber", "boosted_glm_laplace", - "boosted_glm_poisson", "boosted_glm_cox", "boosted_glm_surv", - "boosted_glm_weibull", "boosted_glm_lognormal", "boosted_glm_gehan", "boosted_glm_cindex") + learners <- c( + "boosted_glm", "boosted_glm_logistic", + "boosted_glm_probit", "boosted_glm_loglog", "boosted_glm_cauchy", "boosted_glm_log", + "boosted_glm_auc", "boosted_glm_gaussian", "boosted_glm_huber", "boosted_glm_laplace", + "boosted_glm_poisson", "boosted_glm_cox", "boosted_glm_surv", + "boosted_glm_weibull", "boosted_glm_lognormal", "boosted_glm_gehan", "boosted_glm_cindex" + ) - if(!show_general){ + if (!show_general) { learners <- setdiff(learners, c("boosted_glm", "boosted_glm_surv")) } @@ -65,16 +51,18 @@ setMethod("initialize", signature(.Object="familiarMBoostTree"), } -.get_available_mboost_tree_learners <- function(show_general=TRUE){ +.get_available_mboost_tree_learners <- function(show_general = TRUE) { # Learners - learners <- c("boosted_tree", "boosted_tree_logistic", "boosted_tree_probit", - "boosted_tree_loglog", "boosted_tree_cauchy", "boosted_tree_log", - "boosted_tree_auc", "boosted_tree_gaussian", "boosted_tree_huber", - "boosted_tree_laplace", "boosted_tree_poisson", "boosted_tree_cox", "boosted_tree_surv", - "boosted_tree_weibull", "boosted_tree_lognormal", "boosted_tree_gehan", "boosted_tree_cindex") + learners <- c( + "boosted_tree", "boosted_tree_logistic", "boosted_tree_probit", + "boosted_tree_loglog", "boosted_tree_cauchy", "boosted_tree_log", + "boosted_tree_auc", "boosted_tree_gaussian", "boosted_tree_huber", + "boosted_tree_laplace", "boosted_tree_poisson", "boosted_tree_cox", "boosted_tree_surv", + "boosted_tree_weibull", "boosted_tree_lognormal", "boosted_tree_gehan", "boosted_tree_cindex" + ) - if(!show_general){ + if (!show_general) { learners <- setdiff(learners, c("boosted_tree", "boosted_tree_surv")) } @@ -82,936 +70,123 @@ setMethod("initialize", signature(.Object="familiarMBoostTree"), } -#####is_available,familiarMBoostLM##### -setMethod("is_available", signature(object="familiarMBoostLM"), - function(object, ...){ - - # Extract learner and outcome_type from the familiarModel object. - learner <- object@learner - outcome_type <- object@outcome_type - - if(outcome_type == "survival" & learner %in% c("boosted_glm", "boosted_glm_cox", "boosted_glm_surv", - "boosted_glm_loglog", "boosted_glm_weibull", - "boosted_glm_lognormal", "boosted_glm_gehan", - "boosted_glm_cindex")){ - ..deprecation_mboost() - return(TRUE) - - } else if(outcome_type == "continuous" & learner %in% c("boosted_glm", "boosted_glm_gaussian", - "boosted_glm_huber", "boosted_glm_laplace", - "boosted_glm_poisson")){ - ..deprecation_mboost() - return(TRUE) - - # } else if(outcome_type == "multinomial" & learner %in% c("boosted_glm", "boosted_glm_multinomial")){ - # return(TRUE) - - } else if(outcome_type == "binomial" & learner %in% c("boosted_glm", "boosted_glm_logistic", - "boosted_glm_probit", "boosted_glm_loglog", - "boosted_glm_cauchy", "boosted_glm_log", - "boosted_glm_auc")){ - ..deprecation_mboost() - return(TRUE) - - } else if(outcome_type == "count" & learner %in% c("boosted_glm", "boosted_glm_poisson")) { - ..deprecation_mboost() - return(TRUE) - - } else { - return(FALSE) - } - }) - - - -#####is_available,familiarMBoostTree##### -setMethod("is_available", signature(object="familiarMBoostTree"), - function(object, ...){ - - # Extract learner and outcome_type from the familiarModel object. - learner <- object@learner - outcome_type <- object@outcome_type - - if(outcome_type == "survival" & learner %in% c("boosted_tree", "boosted_tree_cox", - "boosted_tree_surv","boosted_tree_loglog", - "boosted_tree_weibull", "boosted_tree_lognormal", - "boosted_tree_gehan", "boosted_tree_cindex")){ - return(TRUE) - - } else if(outcome_type == "continuous" & learner %in% c("boosted_tree", "boosted_tree_gaussian", "boosted_tree_huber", - "boosted_tree_laplace", "boosted_tree_poisson")){ - return(TRUE) - - } else if(outcome_type == "binomial" & learner %in% c("boosted_tree", "boosted_tree_logistic", "boosted_tree_probit", - "boosted_tree_loglog", "boosted_tree_cauchy", - "boosted_tree_log", "boosted_tree_auc")){ - return(TRUE) - - } else if(outcome_type == "count" & learner %in% c("boosted_tree", "boosted_tree_poisson")) { - return(TRUE) - - } else { - return(FALSE) - } - }) - - - -#####get_default_hyperparameters##### -setMethod("get_default_hyperparameters", signature(object="familiarMBoost"), - function(object, data=NULL, user_list=NULL, ...){ - - # Initialise list and declare hyperparameter entries. - param <- list() - param$sign_size <- list() - param$family <- list() - param$n_boost <- list() - param$learning_rate <- list() - param$sample_weighting <- list() - param$sample_weighting_beta <- list() - - if(is(object, "familiarMBoostTree")){ - param$tree_depth <- list() - param$min_child_weight <- list() - param$alpha <- list() - } - - # If data is explicitly NULL, return the list with hyperparameter - # names only. - if(is.null(data)) return(param) - - - ##### Signature size ############################################### - param$sign_size <- .get_default_sign_size(data=data) - - - ##### Model family ##### - param$family$type <- "factor" - param$family$range <- c("logistic", "probit", "bin_loglog", "cauchy", - "log", "auc", "gaussian", "huber", "laplace", - "poisson", "cox", "weibull", "lognormal", - "surv_loglog", "gehan", "cindex", "multinomial") - - # Read family string by parsing learner - fam <- sub_all_patterns(x=object@learner, pattern=c("boosted_glm", "boosted_tree"), replacement="", fixed=TRUE) - if(fam != "") fam <- sub(x=fam, pattern="_", replacement="", fixed=TRUE) - - # Define the family based on the name of the learner. - if(fam == ""){ - # No specific family is provided. - if(object@outcome_type == "continuous"){ - family_default <- c("gaussian", "huber", "poisson") - - } else if(object@outcome_type == "count"){ - family_default <- "poisson" - - } else if(object@outcome_type == "binomial") { - family_default <- c("logistic", "probit", "bin_loglog", "cauchy", "log") - - # } else if(object@outcome_type == "multinomial"){ - # family_default <- "multinomial" - # - } else if(object@outcome_type == "survival"){ - family_default <- "cox" - - } else { - ..error_outcome_type_not_implemented(object@outcome_type) - } - - } else if(fam == "surv"){ - # A survival family is provided, but not specified further. - family_default <- c("weibull", "lognormal", "surv_loglog") - - } else if(fam == "loglog") { - # "loglog" is a collection of families that should be further - # split according to outcome type. - if(object@outcome_type == "binomial") { - family_default <- "bin_loglog" - - } else if(object@outcome_type == "survival") { - family_default <- "surv_loglog" - - } else { - ..error_outcome_type_not_implemented(object@outcome_type) - } - - } else { - # Other families are uniquely defined. - family_default <- fam - } - - # Set the family parameter. - param$family <- .set_hyperparameter(default=family_default, - type="factor", - range=family_default, - randomise=ifelse(length(family_default) > 1, TRUE, FALSE)) - - ##### Number of boosting iterations ################################ - - # This parameter could be set using the cv or cvrisk functions in - # mboost. However, the SMAC hyperoptimisation method implemented in - # the framework is superior to that of the grid-search method of cv - # and cvrisk This hyper-parameter is expressed on the log 10 scale - param$n_boost <- .set_hyperparameter(default=c(0, 1, 2, 3), - type="numeric", - range=c(0, 3), - valid_range=c(0, Inf), - randomise=TRUE) - - - ##### Learning rate ################################################ - - # Learning rate is on a log10 scale and determines how fast the - # algorithm tries to learn. Lower values typically lead to better - # models, but converge slower. - param$learning_rate <- .set_hyperparameter(default=c(-5, -3, -2, -1), - type="numeric", - range=c(-7, 0), - valid_range=c(-Inf, 0), - randomise=TRUE) - - - ##### Sample weighting method ###################################### - #Class imbalances may lead to learning majority classes. This can be - #partially mitigated by increasing weight of minority classes. - param$sample_weighting <- .get_default_sample_weighting_method(outcome_type=object@outcome_type) - - ##### Effective number of samples beta ############################# - #Specifies the beta parameter for effective number sample weighting - #method. See Cui et al. (2019). - param$sample_weighting_beta <- .get_default_sample_weighting_beta(method=c(param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type=object@outcome_type) - - - if(is(object, "familiarMBoostTree")){ - ##### Tree maximum depth ######################################### - - # This hyperparameter is only used by tree models. Larger depths - # increase the risk of overfitting. - param$tree_depth <- .set_hyperparameter(default=c(1, 2, 3, 7), - type="integer", - range=c(1, 10), - valid_range=c(1, Inf), - randomise=TRUE) - - - ##### Minimum sum of instance weight ############################# - - # We implement this on a power(10) scale, with -1 offset. - param$min_child_weight <- .set_hyperparameter(default=c(0, 1, 2), - type="numeric", - range=c(0, 2), - valid_range=c(0, Inf), - randomise=TRUE) - - - ##### Significance threshold for splitting ####################### - - # Sets the significance level required to allow a split on a variable. - param$alpha <- .set_hyperparameter(default=c(0.05, 0.1, 0.5, 1.0), - type="numeric", - range=c(10^-6, 1.0), - valid_range=c(0.0, 1.0), - randomise=TRUE, - distribution="log") - } - - # Return hyper-parameters - return(param) - }) - - - -#####get_prediction_type##### -setMethod("get_prediction_type", signature(object="familiarMBoost"), - function(object, type="default"){ - - - if(object@outcome_type != "survival") return(callNextMethod()) - - if(type == "default" & all(as.character(object@hyperparameters$family) %in% c("cox", "cindex", "gehan"))){ - return("hazard_ratio") - - } else if(type == "default" & all(as.character(object@hyperparameters$family) %in% c("weibull", "lognormal", "surv_loglog"))) { - return("expected_survival_time") - - } else if(type == "survival_probability"){ - return("survival_probability") - - } else { - ..error_reached_unreachable_code(paste0("get_prediction_type,familiarGLM: unknown type (", type, - ") for the current family (", as.character(object@hyperparameters$family), ").")) - } - }) - - - -#####..train#### -setMethod("..train", signature(object="familiarMBoost", data="dataObject"), - function(object, data, ...){ - - # Aggregate repeated measurement data - mboost does not facilitate - # repeated measurements. - data <- aggregate_data(data=data) - - # Check if training data is ok. - if(reason <- has_bad_training_data(object=object, data=data)){ - return(callNextMethod(object=.why_bad_training_data(object=object, reason=reason))) - } - - # Check if hyperparameters are set. - if(is.null(object@hyperparameters)){ - return(callNextMethod(object=..update_errors(object=object, - ..error_message_no_optimised_hyperparameters_available()))) - } - - # Check that required packages are loaded and installed. - require_package(object, "train") - - # Use effect coding to convert categorical data into encoded data - - # this is required to deal with factors with missing/new levels - # between training and test data sets. - encoded_data <- encode_categorical_variables(data=data, - object=object, - encoding_method="dummy", - drop_levels=FALSE) - - # Find feature columns in the data. - feature_columns <- get_feature_columns(x=encoded_data$encoded_data) - - # Parse formula. - if(object@outcome_type == "survival") { - formula <- stats::reformulate(termlabels=feature_columns, - response=quote(survival::Surv(outcome_time, outcome_event))) - - } else if(object@outcome_type %in% c("binomial", "count", "continuous")){ - formula <- stats::reformulate(termlabels=feature_columns, - response=quote(outcome)) - - } else { - ..error_outcome_type_not_implemented(object@outcome_type) - } - - # Potentially update the outcome data - encoded_data$encoded_data <- ..update_outcome(object=object, - data=encoded_data$encoded_data) - - # Get family for mboost, which determines how the response and - # predictors are linked. - family <- ..get_distribution_family(object) - - # Set control object. Note that learning rate is defined on the log - # 10 scale. - control_object <- mboost::boost_control(mstop = round(10^object@hyperparameters$n_boost), - nu = 10^object@hyperparameters$learning_rate) - - # Set weights. - weights <- create_instance_weights(data=encoded_data$encoded_data, - method=object@hyperparameters$sample_weighting, - beta=..compute_effective_number_of_samples_beta(object@hyperparameters$sample_weighting_beta), - normalisation="average_one") - - if(is(object, "familiarMBoostLM")){ - # Get the arguments which are shared between all families. - learner_arguments <- list(formula, - "data"=encoded_data$encoded_data@data, - "family"=family, - "center"=FALSE, - "control"=control_object) - - if(!object@hyperparameters$family %in% c("auc")){ - # mboost does not support weights when gradient boosting with - # the AUC family, but others do. - learner_arguments <- c(learner_arguments, - list("weights"=weights)) - } - - # Train the model. - model <- do.call_with_handlers(mboost::glmboost, - args=learner_arguments) - - } else if(is(object, "familiarMBoostTree")){ - # Set tree controls. Note that every parameter except max depth is - # kept at default for mboost. - tree_control_object <- partykit::ctree_control(testtype = "Univariate", - maxdepth = object@hyperparameters$tree_depth, - minsplit = 10^object@hyperparameters$min_child_weight - 1, - mincriterion = 1 - object@hyperparameters$alpha, - saveinfo = FALSE) - - # Get the arguments which are shared between all families. - learner_arguments <- list(formula, - "data"=encoded_data$encoded_data@data, - "family"=family, - "control"=control_object, - "tree_controls"=tree_control_object) - - if(!object@hyperparameters$family %in% c("auc")){ - # mboost does not support weights when gradient boosting with - # the AUC family. - learner_arguments <- c(learner_arguments, - list("weights"=weights)) - } - - # Train the model. - model <- do.call_with_handlers(mboost::blackboost, - args=learner_arguments) - - } else { - ..error_reached_unreachable_code(paste0("..train,familiarMBoost: encountered unknown learner of unknown class: ", paste0(class(object), collapse=", "))) - } - - # Extract values. - object <- ..update_warnings(object=object, model$warning) - object <- ..update_errors(object=object, model$error) - model <- model$value - - # Check if the model trained at all. - if(!is.null(object@messages$error)) return(callNextMethod(object=object)) - - # Add model - object@model <- model - - # Add the contrast references to model_list - object@encoding_reference_table <- encoded_data$reference_table - - # Add feature order - object@feature_order <- feature_columns - - # Set learner version - object <- set_package_version(object) - - return(object) - }) - - - -#### ..train_naive ------------------------------------------------------------- -setMethod("..train_naive", signature(object="familiarMBoost", data="dataObject"), - function(object, data, ...){ - - if(object@outcome_type %in% c("count", "continuous", "binomial", "multinomial")){ - # Turn into a Naive model. - object <- methods::new("familiarNaiveModel", object) - - } else if(object@outcome_type %in% c("survival")){ - - if(as.character(object@hyperparameters$family) %in% c("cox", "cindex", "gehan")){ - # Turn into a Naive Cox model. - object <- methods::new("familiarNaiveCoxModel", object) - - } else if(as.character(object@hyperparameters$family) %in% c("weibull", "lognormal", "surv_loglog")){ - # Turn into a Naive survival regression time. - object <- methods::new("familiarNaiveSurvivalTimeModel", object) - } - } - - return(..train( - object=object, - data=data, - ...)) - }) - - - -#####..predict##### -setMethod("..predict", signature(object="familiarMBoost", data="dataObject"), - function(object, data, type="default", ...){ - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - if(type == "default"){ - ##### Default method ############################################# - - # Check if the model was trained. - if(!model_is_trained(object)) return(callNextMethod()) - - # Check if the data is empty. - if(is_empty(data)) return(callNextMethod()) - - # Set default type - prediction_type <- "response" - - # For several family variants the default type is link instead of - # response. - if(as.character(object@hyperparameters$family) %in% c("auc", "cox", "cindex", "gehan")){ - prediction_type <- "link" - } - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables(data=data, - object=object, - encoding_method="dummy", - drop_levels=FALSE) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table(object=object, - data=encoded_data$encoded_data, - type=type) - - # Make predictions. - if(is(object, "familiarMBoostLM")){ - model_predictions <- mboost::predict.glmboost(object=object@model, - newdata=encoded_data$encoded_data@data, - type=prediction_type) - - } else if(is(object, "familiarMBoostTree")){ - model_predictions <- mboost::predict.mboost(object=object@model, - newdata=encoded_data$encoded_data@data, - type=prediction_type) - - } else { - return(callNextMethod()) - } - - - if(object@outcome_type == "binomial"){ - #####Binomial outcomes########################################## - - if(as.character(object@hyperparameters$family) %in% "auc"){ - # AUC produces the linear predictor, not class probabilities. - # These are set here, prior to re-calibration. - model_predictions <- 0.5 + model_predictions - } - - # Obtain class levels. - class_levels <- get_outcome_class_levels(x=object) - - # Add class probabilities (glm always gives probability for the - # second class). - class_probability_columns <- get_class_probability_name(x=object) - prediction_table[, (class_probability_columns[1]):= 1.0 - model_predictions] - prediction_table[, (class_probability_columns[2]):= model_predictions] - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply(prediction_table[, mget(class_probability_columns)], 1, which.max)] - class_predictions <- factor(class_predictions, levels=class_levels) - prediction_table[, "predicted_class":=class_predictions] - - } else if(object@outcome_type %in% c("continuous", "count")){ - #####Numerical outcomes######################################### - - # Extract predicted regression values. - prediction_table[, "predicted_outcome":=model_predictions[, 1]] - - } else if(object@outcome_type %in% c("survival")){ - #####Survival outcomes########################################## - - # Check model family and convert linear predictors to hazard - # ratio. - if(as.character(object@hyperparameters$family) %in% "cox"){ - # Cox partial likelihood produces the linear predictor, not - # relative risks. - model_predictions <- exp(model_predictions) - - } else if(as.character(object@hyperparameters$family) %in% c("cindex", "gehan")){ - # Concordance probability and gehan loss produce "time-like" - # predictions before calibration using cox models, whereas - # "risk-like" is expected. - model_predictions <- - model_predictions - } - - # Add predictions to the prediction table. - prediction_table[, "predicted_outcome":=model_predictions[, 1]] - - } else { - ..error_outcome_type_not_implemented(object@outcome_type) - } - - return(prediction_table) - - } else { - ##### User-specified method ###################################### - - # Check if the model was trained. - if(!model_is_trained(object)) return(NULL) - - # Check if the data is empty. - if(is_empty(data)) return(NULL) - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables(data=data, - object=object, - encoding_method="dummy", - drop_levels=FALSE) - - # Make predictions. - if(is(object, "familiarMBoostLM")){ - return(mboost::predict.glmboost(object=object@model, - newdata=encoded_data$encoded_data@data, - type=type, - ...)) - - } else if(is(object, "familiarMBoostTree")){ - return(mboost::predict.mboost(object=object@model, - newdata=encoded_data$encoded_data@data, - type=type, - ...)) - - } else { - return(NULL) - } - } - }) - - - -#####..predict_survival_probability##### -setMethod("..predict_survival_probability", signature(object="familiarMBoost", data="dataObject"), - function(object, data, time){ - - # Only predict survival probability for survival outcomes. - if(!object@outcome_type %in% c("survival")) return(callNextMethod()) - - # Weibull, log-normal and log-log don't have an associated survival - # probability function. - if(as.character(object@hyperparameters$family) %in% c("weibull", "lognormal", "surv_loglog")) return(callNextMethod()) - - # If time is unset, read the max time stored by the model. - if(is.null(time)) time <- object@settings$time_max - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - return(.survival_probability_relative_risk(object=object, data=data, time=time)) - }) - - - -#####..vimp##### -setMethod("..vimp", signature(object="familiarMBoostLM"), - function(object, ...){ - - # Suppress NOTES due to non-standard evaluation in data.table - score <- variable <- NULL - - # Check if the model has been trained upon retry. - if(!model_is_trained(object)) return(callNextMethod()) - - # Check that required packages are loaded and installed. - require_package(object, "vimp") - - if(object@is_trimmed){ - # Use stored data. - vimp_score <- data.table::as.data.table(object@trimmed_function$varimp) - - } else { - # Use varimp function from mboost to extract a data table. - vimp_score <- data.table::as.data.table(mboost::varimp(object@model)) - } - - # Select only existing features. - vimp_score <- vimp_score[variable %in% object@feature_order, ] - - # Convert factor to character - vimp_score$variable <- as.character(vimp_score$variable) - - # Parse score to data.table - vimp_table <- data.table::data.table("score"=vimp_score$reduction, - "name"=vimp_score$variable) - - # Create variable importance object. - vimp_object <- methods::new("vimpTable", - vimp_table=vimp_table, - encoding_table=object@encoding_reference_table, - score_aggregation="max", - invert=TRUE) - - return(vimp_object) - }) - - - -#####..set_calibration_info##### -setMethod("..set_calibration_info", signature(object="familiarMBoost"), - function(object, data){ - - # Check if calibration info already. - if(has_calibration_info(object)) return(object) - - if(object@outcome_type=="survival") { - # Determine baseline survival. - object@calibration_info <- get_baseline_survival(data=data) - - } else { - return(callNextMethod()) - } - - return(object) - }) - - - -#####..get_distribution_family##### -setMethod("..get_distribution_family", signature(object="familiarMBoost"), - function(object){ - # Obtain family from the hyperparameters. - family <- object@hyperparameters$family - - # Check that the family hyperparameter exists. - if(!is.character(family) & !is.factor(family)){ - ..error_reached_unreachable_code("..get_distribution_family,familiarMBoost: family hyperparameter was not set.") - } - - # Check that required packages are loaded and installed. - require_package(object, "distribution") - - # Load families for boosted gradients - if(family == "logistic"){ - family_fun <- mboost::Binomial(link="logit") - - } else if(family == "probit"){ - family_fun <- mboost::Binomial(link="probit") - - } else if(family == "bin_loglog"){ - family_fun <- mboost::Binomial(link="cloglog") - - } else if(family == "cauchy"){ - family_fun <- mboost::Binomial(link="cauchit") - - } else if(family == "log"){ - family_fun <- mboost::Binomial(link="log") - - } else if(family == "auc"){ - family_fun <- mboost::AUC() - - } else if(family == "gaussian"){ - family_fun <- mboost::Gaussian() - - } else if(family == "huber"){ - family_fun <- mboost::Huber() - - } else if(family == "laplace"){ - family_fun <- mboost::Laplace() - - } else if(family == "poisson"){ - family_fun <- mboost::Poisson() - - # } else if(family == "multinomial"){ - # family_fun <- mboost::Multinomial() - # - } else if(family == "cox"){ - family_fun <- mboost::CoxPH() - - } else if(family == "weibull"){ - family_fun <- mboost::Weibull() - - } else if(family == "lognormal"){ - family_fun <- mboost::Lognormal() - - } else if(family == "surv_loglog"){ - family_fun <- mboost::Loglog() - - } else if(family == "gehan"){ - family_fun <- mboost::Gehan() - - } else if(family == "cindex"){ - family_fun <- mboost::Cindex() - - } else { - ..error_reached_unreachable_code(paste0("..get_distribution_family,familiarMBoost: unknown family.", family)) - } - - return(family_fun) - }) - - - -#####..set_recalibration_model###### -setMethod("..set_recalibration_model", signature(object="familiarMBoost", data="dataObject"), - function(object, data, time=NULL){ - # Recalibration is performed using standard methods - if(object@outcome_type %in% c("survival") & as.character(object@hyperparameters$family) %in% c("gehan", "cindex")){ - - # Calibrate the models. - object@calibration_model <- .set_recalibration(object=object, data=data, time=time) - - # Return object. - return(object) - - } else if(object@outcome_type %in% c("binomial") & as.character(object@hyperparameters$family) %in% c("auc")){ - - # Calibrate the models. - object@calibration_model <- .set_recalibration(object=object, data=data) - - # Return object. - return(object) - - } else { - return(callNextMethod()) - } - }) - - -#####..update_outcome###### -setMethod("..update_outcome", signature(object="familiarMBoost", data="dataObject"), - function(object, data){ - - # Suppress NOTES due to non-standard evaluation in data.table - outcome <- NULL - - if(is_empty(data)) return(data) - - if(object@outcome_type %in% c("count", "continuous") & as.character(object@hyperparameters$family) %in% c("poisson")){ - # Make a copy to prevent updating by reference. - data@data <- data.table::copy(data@data) - - data@data[, "outcome":=round(outcome)] - } - - return(data) - }) - - -#####.trim_model---------------------------------------------------------------- -setMethod(".trim_model", signature(object="familiarMBoost"), - function(object, ...){ - - # Create a duplicate of the object to avoid changing the input - # object by reference. Since we will be changing environments, we - # don't want to update object by reference. - object <- rlang::duplicate(object) - - # Update model by removing the call. - object@model$call <- call("trimmed") - - # Add show. - quiet(object <- .capture_show(object)) - - # Remove unused elements - object@model$ustart <- NULL - object@model$response <- NULL - object@model$`(weights)` <- NULL - object@model$rownames <- NULL - object@model$baselearner <- NULL - object@model$basemodel <- NULL - - if(is(object, "familiarMBoostLM")){ - - # Clean the main environment of familiarMBoostLM objects. - main_env <- environment(object@model$model.frame) - main_env_dupl <- .duplicate_environment(main_env) - - # Remove most environment variables, except those that are - # necessary for prediction. - main_env_variables <- setdiff(ls(main_env_dupl, all.names=TRUE), - c("mf", "na.action", "contrasts.arg", "cm")) - .remove(main_env_variables, envir=main_env_dupl) - - # Remove leftover sample data. - evalq(mf <- head(mf, n=0L), envir=main_env_dupl) - - # Assign duplicate environment - object@model <- .change_environment(object@model, - old_env=main_env, - new_env=main_env_dupl) - } - # Clean the main subsidiary environment. - subs_env <- environment(object@model$predict) - subs_env_dupl <- .duplicate_environment(subs_env) - - # Remove - .remove("fit", "fit1", "oob", "response", - "u", "ustart", "weights", "y", "yna", - "basefit", "blfit", "blg", "boost", envir=subs_env_dupl) - - # Assign duplicate environment - object@model <- .change_environment(object@model, - old_env=subs_env, - new_env=subs_env_dupl) - - # Change environment of elements in the subsidiary environment. - .change_environment(subs_env_dupl, - old_env=subs_env, - new_env=subs_env_dupl) - - # Remove copies of the sample data from bl in the subsidiary - # environment. - bl <- get("bl", envir=subs_env_dupl) - for(ii in seq_along(bl)){ - x_env <- environment(bl[[ii]]$fit) - x_env_dupl <- .duplicate_environment(x_env) - - if(is(object, "familiarMBoostLM")){ - # Linear model-specific data. - - # Strip data. - evalq(X <- head(X, n=0L), envir=x_env_dupl) - - # Remove weights - .remove("weights", envir=x_env_dupl) - - } else { - - # Tree-specific data. - evalq(df <- head(df, n=0L), envir=x_env_dupl) - evalq(mymf <- head(mymf, n=0L), envir=x_env_dupl) - - .remove("weights", "y", "Y", envir=x_env_dupl) - - # Update d - d <- get("d", envir=x_env_dupl) - - # Shrink d - d$data <- head(d$data, n=0L) - - # Update terms by removing the environment. - d$terms <- lapply(d$terms, .replace_environment) - - # Update zindex. - for(ii in seq_along(d$zindex)){ - if(is.null(d$zindex[[ii]])) next() - - d$zindex[[ii]] <- head(d$zindex[[ii]], n=0L) - } - - # Re-assign d - assign("d", d, envir=x_env_dupl) - - } - - # Update the elements in the environment directly. This includes - # bl. - .change_environment(subs_env_dupl, - old_env=x_env, - new_env=x_env_dupl) - - # Make sure that x_env_dupl is self-referenced. - .change_environment(x_env_dupl, - old_env=x_env, - new_env=x_env_dupl) - - } - - # Clean up the ens variable in the subsidiary environment. - if(is(object, "familiarMBoostLM")){ - ens <- get("ens", envir=subs_env_dupl) - for(ii in seq_along(ens)){ - x_env <- environment(ens[[ii]]$fitted) - x_env_dupl <- .duplicate_environment(x_env) - - # Remove y - .remove("y", envir=x_env_dupl) - - # Update the elements in the environment directly. This includes - # ens itself. - .change_environment(subs_env_dupl, - old_env=x_env, - new_env=x_env_dupl) - - # The old environment also appears in the new environment, - # notably in "ret". - .change_environment(x_env_dupl, - old_env=x_env, - new_env=x_env_dupl) - } - } - - # Set is_trimmed to TRUE. - object@is_trimmed <- TRUE - - # Default method for models that lack a more specific method. - return(object) - }) +# is_available,familiarMBoostLM ------------------------------------------------ +setMethod( + "is_available", + signature(object = "familiarMBoostLM"), + function(object, ...) { + + # Extract learner and outcome_type from the familiarModel object. + learner <- object@learner + outcome_type <- object@outcome_type + + if ( + outcome_type == "survival" && + learner %in% c( + "boosted_glm", "boosted_glm_cox", "boosted_glm_surv", + "boosted_glm_loglog", "boosted_glm_weibull", "boosted_glm_lognormal", + "boosted_glm_gehan", "boosted_glm_cindex" + ) + ) { + ..deprecation_mboost() + return(FALSE) + + } else if ( + outcome_type == "continuous" && + learner %in% c( + "boosted_glm", "boosted_glm_gaussian", "boosted_glm_huber", + "boosted_glm_laplace", "boosted_glm_poisson" + ) + ) { + ..deprecation_mboost() + return(FALSE) + + } else if ( + outcome_type == "binomial" && + learner %in% c( + "boosted_glm", "boosted_glm_logistic", "boosted_glm_probit", "boosted_glm_loglog", + "boosted_glm_cauchy", "boosted_glm_log", "boosted_glm_auc" + ) + ) { + ..deprecation_mboost() + return(FALSE) + + } else if (outcome_type == "count" && learner %in% c("boosted_glm", "boosted_glm_poisson")) { + ..deprecation_mboost() + ..deprecation_count() + return(FALSE) + + } else { + return(FALSE) + } + } +) + + + +# is_available,familiarMBoostTree ---------------------------------------------- +setMethod( + "is_available", + signature(object = "familiarMBoostTree"), + function(object, ...) { + + # Extract learner and outcome_type from the familiarModel object. + learner <- object@learner + outcome_type <- object@outcome_type + + if ( + outcome_type == "survival" && + learner %in% c( + "boosted_tree", "boosted_tree_cox", "boosted_tree_surv", + "boosted_tree_loglog", "boosted_tree_weibull", "boosted_tree_lognormal", + "boosted_tree_gehan", "boosted_tree_cindex" + ) + ) { + ..deprecation_mboost() + return(FALSE) + + } else if ( + outcome_type == "continuous" && + learner %in% c( + "boosted_tree", "boosted_tree_gaussian", "boosted_tree_huber", + "boosted_tree_laplace", "boosted_tree_poisson" + ) + ) { + ..deprecation_mboost() + return(FALSE) + + } else if ( + outcome_type == "binomial" && + learner %in% c( + "boosted_tree", "boosted_tree_logistic", "boosted_tree_probit", + "boosted_tree_loglog", "boosted_tree_cauchy", "boosted_tree_log", + "boosted_tree_auc" + ) + ) { + ..deprecation_mboost() + return(FALSE) + + } else if (outcome_type == "count" && learner %in% c("boosted_tree", "boosted_tree_poisson")) { + ..deprecation_mboost() + ..deprecation_count() + return(FALSE) + + } else { + return(FALSE) + } + } +) + + +# ..predict -------------------------------------------------------------------- +setMethod( + "..predict", + signature( + object = "familiarMBoost", + data = "dataObject" + ), + function(object, data, type = "default", ...) { + ..deprecation_mboost() + return(callNextMethod()) + } +) diff --git a/R/LearnerS4Naive.R b/R/LearnerS4Naive.R index fce708dd..e14fdeb0 100644 --- a/R/LearnerS4Naive.R +++ b/R/LearnerS4Naive.R @@ -5,19 +5,23 @@ NULL # familiarNaiveModel objects --------------------------------------------------- setClass( "familiarNaiveModel", - contains = "familiarModel") + contains = "familiarModel" +) setClass( "familiarNaiveCoxModel", - contains = "familiarNaiveModel") + contains = "familiarNaiveModel" +) setClass( "familiarNaiveSurvivalTimeModel", - contains = "familiarNaiveModel") + contains = "familiarNaiveModel" +) setClass( "familiarNaiveCumulativeIncidenceModel", - contains = "familiarNaiveModel") + contains = "familiarNaiveModel" +) @@ -26,27 +30,31 @@ setMethod( "..train", signature( object = "familiarNaiveModel", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Check if training data is ok. if (reason <- has_bad_training_data( object = object, data = data, - allow_no_features = TRUE)) { + allow_no_features = TRUE + )) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } - + # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } - - if (object@outcome_type %in% c("count", "continuous")) { + + if (object@outcome_type %in% c("continuous")) { model <- object@outcome_info@distribution } else if (object@outcome_type %in% c("binomial", "multinomial")) { model <- object@outcome_info@distribution @@ -55,13 +63,13 @@ setMethod( } else { ..error_outcome_type_not_implemented(object@outcome_type) } - + # Add model... well "model" really. object@model <- model - + # Set learner version object <- set_package_version(object) - + return(object) } ) @@ -73,73 +81,91 @@ setMethod( "..predict", signature( object = "familiarNaiveModel", - data = "dataObject"), - function(object, data, ...) { - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "default") - - if (object@outcome_type %in% c("binomial", "multinomial")) { - # Get classes and their probabilities from the stored model data. In the - # naive model, the probability of each class is its occurrence in the - # development data. - class_levels <- object@model$frequency$outcome - class_probabilities <- object@model$frequency$count / object@model$n - - # Fill class probabilities. - class_probability_columns <- get_class_probability_name(class_levels) - for (ii in seq_along(class_probability_columns)) { - prediction_table[, (class_probability_columns[ii]) := class_probabilities[ii]] - } - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply( - prediction_table[, mget(class_probability_columns)], 1, which.max)] - - class_predictions <- factor( - x = class_predictions, - levels = get_outcome_class_levels(object)) - - prediction_table[, "predicted_class" := class_predictions] + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { + + # Check n_samples, and then ensure that n_samples is equal to the number + # of rows in the dataset. + n_samples <- get_n_samples(data) + if (n_samples == 0L) return(callNextMethod()) + n_samples <- nrow(data@data) + + if (type == "default") { + # default ---------------------------------------------------------------- - } else if (object@outcome_type %in% c("count", "continuous")) { - # In the naive model, return the median value for regression problems. - prediction_table[, "predicted_outcome" := object@model$median] + if (object@outcome_type %in% c("binomial", "multinomial")) { + # Get classes and their probabilities from the stored model data. In the + # naive model, the probability of each class is its occurrence in the + # development data. + class_levels <- get_outcome_class_levels(object) + class_probabilities <- object@model$frequency$count / object@model$n + + # Fill class probabilities. + prediction_list <- list() + for (ii in seq_along(class_levels)) { + prediction_list[[class_levels[ii]]] <- rep.int(class_probabilities[ii], n_samples) + } + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) + + } else if (object@outcome_type %in% c("continuous")) { + # Store as prediction table. In the naive model, return the median value + # for regression problems. + prediction_table <- as_prediction_table( + x = rep.int(object@model$median, n_samples), + type = "regression", + data = data, + model_object = object + ) + + } else if (object@outcome_type %in% c("survival")) { + # For survival outcomes based on relative risks, predict the average + # risk, i.e. 1.0. + prediction_table <- as_prediction_table( + x = rep.int(1.0, n_samples), + type = "hazard_ratio", + data = data, + model_object = object + ) + + } else { + ..error_outcome_type_not_implemented(object@outcome_type) + } + } else if (type == "survival_probability" && object@outcome_type == "survival") { + # survival probability --------------------------------------------------- - } else { - ..error_outcome_type_not_implemented(object@outcome_type) - } - - return(prediction_table) - } -) - + # If time is unset, read the max time stored by the model. + if (is.null(time)) time <- object@settings$time_max - -# ..predict (familiarNaiveCoxModel) -------------------------------------------- -setMethod( - "..predict", - signature( - object = "familiarNaiveCoxModel", - data = "dataObject"), - function(object, data, ...) { - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "default") - - if (object@outcome_type %in% c("survival")) { - # For survival outcomes based on relative risks, predict the average risk, - # i.e. 1.0. - prediction_table[, "predicted_outcome" := 1.0] + # Check for several issues that prevent survival probabilities from being + # predicted. + if (!has_calibration_info(object)) return(callNextMethod()) + + # For naive models, survival probability is defined by the Kaplan-Meier + # estimate of survival at the time point time. + prediction_table <- .survival_probability_relative_risk( + object = object, + data = data, + time = time + ) } else { - ..error_outcome_type_not_implemented(object@outcome_type) + ..error_no_predictions_possible(object, type) } - + return(prediction_table) } ) @@ -151,15 +177,23 @@ setMethod( "..predict", signature( object = "familiarNaiveSurvivalTimeModel", - data = "dataObject"), - function(object, data, ...) { - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "default") + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { + + # Check n_samples, and then ensure that n_samples is equal to the number + # of rows in the dataset. + n_samples <- get_n_samples(data) + if (n_samples == 0L) return(callNextMethod()) + n_samples <- nrow(data@data) - if (object@outcome_type %in% c("survival")) { + if (object@outcome_type == "survival" && type == "default") { # For survival outcomes based on survival times, predict the average # survival time. @@ -172,8 +206,9 @@ setMethod( y = object@model$survival_probability$time, xout = 0.5, method = "linear", - rule = 2 - )$y) + rule = 2L + )$y + ) } else { # Use the last known time point. @@ -181,10 +216,41 @@ setMethod( } # Set the survival time. - prediction_table[, "predicted_outcome" := survival_time] + prediction_table <- as_prediction_table( + x = rep.int(survival_time, n_samples), + type = "expected_survival_time", + data = data, + model_object = object + ) + + } else if (object@outcome_type == "survival" && type == "survival_probability") { + # For naive models, survival probability is defined by the Kaplan-Meier + # estimate of survival at the time point time. + prediction_table <- as_prediction_table( + x = rep.int(1.0, n_samples), + type = "hazard_ratio", + data = data, + model_object = object + ) + + # If time is unset, read the max time stored by the model. + if (is.null(time)) time <- object@settings$time_max + + # Check for several issues that prevent survival probabilities from being + # predicted. + if (!has_calibration_info(object)) return(callNextMethod()) + + # For naive models, survival probability is defined by the Kaplan-Meier + # estimate of survival at the time point time. + prediction_table <- .survival_probability_relative_risk( + object = prediction_table, + data = data, + time = time, + model = object + ) } else { - ..error_outcome_type_not_implemented(object@outcome_type) + ..error_no_predictions_possible(object, type) } return(prediction_table) @@ -198,21 +264,29 @@ setMethod( "..predict", signature( object = "familiarNaiveCumulativeIncidenceModel", - data = "dataObject"), - function(object, data, time = NULL, ...) { - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "default") + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { + + # Check n_samples, and then ensure that n_samples is equal to the number + # of rows in the dataset. + n_samples <- get_n_samples(data) + if (n_samples == 0L) return(callNextMethod()) + n_samples <- nrow(data@data) - if (object@outcome_type %in% c("survival")) { + if (object@outcome_type %in% c("survival") && type == "default") { # For survival outcomes based on survival times, predict the average # survival time. - + # If time is not provided, set the time at the last observed event. if (is.null(time)) time <- object@model$event_fivenum$max - + # Approximate cumulative incidence. cumulative_incidence <- suppressWarnings( stats::approx( @@ -220,52 +294,49 @@ setMethod( y = object@model$cumulative_incidence$cumulative_incidence, xout = time, method = "linear", - rule = 2 - )$y) - + rule = 2L + )$y + ) + # Compute the cumulative hazard at the indicated time point. - prediction_table[, "predicted_outcome" := cumulative_incidence] + # Set the survival time. + prediction_table <- as_prediction_table( + x = rep.int(cumulative_incidence, n_samples), + type = "cumulative_hazard", + data = data, + model_object = object + ) + + } else if (object@outcome_type == "survival" && type == "survival_probability") { + # For naive models, survival probability is defined by the Kaplan-Meier + # estimate of survival at the time point time. + prediction_table <- as_prediction_table( + x = rep.int(1.0, n_samples), + type = "hazard_ratio", + data = data, + model_object = object + ) + + # If time is unset, read the max time stored by the model. + if (is.null(time)) time <- object@settings$time_max + + # Check for several issues that prevent survival probabilities from being + # predicted. + if (!has_calibration_info(object)) return(callNextMethod()) + + # For naive models, survival probability is defined by the Kaplan-Meier + # estimate of survival at the time point time. + prediction_table <- .survival_probability_relative_risk( + object = prediction_table, + data = data, + time = time, + model = object + ) } else { - ..error_outcome_type_not_implemented(object@outcome_type) - } - - return(prediction_table) - } -) - - -# ..predict_survival_probability ----------------------------------------------- -setMethod( - "..predict_survival_probability", - signature( - object = "familiarNaiveModel", - data = "dataObject"), - function(object, data, time) { - if (!object@outcome_type %in% c("survival")) { - return(callNextMethod()) + ..error_no_predictions_possible(object, type) } - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - # Prepare an empty table in case things go wrong. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "survival_probability") - - # Check for several issues that prevent survival probabilities from being - # predicted. - if (!has_calibration_info(object)) return(prediction_table) - - # For naive models, survival probability is defined by the Kaplan-Meier - # estimate of survival at the time point time. - prediction_table[, "survival_probability" := ..survival_probability_relative_risk( - object = object, - relative_risk = rep_len(1.0, nrow(prediction_table)), - time = time)] - return(prediction_table) } ) @@ -284,7 +355,8 @@ setMethod( return("survival_probability") } else { ..error_reached_unreachable_code( - "get_prediction_type,familiarNaiveCoxModel: unknown type") + "get_prediction_type,familiarNaiveCoxModel: unknown type" + ) } } ) @@ -304,7 +376,8 @@ setMethod( return("survival_probability") } else { ..error_reached_unreachable_code( - "get_prediction_type,familiarNaiveSurvivalTimeModel: unknown type") + "get_prediction_type,familiarNaiveSurvivalTimeModel: unknown type" + ) } } ) @@ -323,7 +396,8 @@ setMethod( return("survival_probability") } else { ..error_reached_unreachable_code( - "get_prediction_type,familiarNaiveCumulativeIncidenceModel: unknown type") + "get_prediction_type,familiarNaiveCumulativeIncidenceModel: unknown type" + ) } } ) @@ -342,6 +416,7 @@ setMethod( if (object@outcome_type == "survival") { # Determine baseline survival. object@calibration_info <- get_baseline_survival(data = data) + } else { return(callNextMethod()) } @@ -362,35 +437,39 @@ setMethod( if (!model_is_trained(object)) { cat(paste0( - "A ", object@learner, " model (class: ", class(object)[1], + "A ", object@learner, " model (class: ", class(object)[1L], ") that was not successfully trained (", .familiar_version_string(object), - ").\n")) + ").\n" + )) - if (length(object@messages$warning) > 0) { + if (length(object@messages$warning) > 0L) { condition_messages <- condition_summary(object@messages$warning) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "warning was", "warnings were"), + ifelse(length(condition_messages) == 1L, "warning was", "warnings were"), " generated while trying to train the model:\n", paste0(condition_messages, collapse = "\n"), - "\n")) + "\n" + )) } - if (length(object@messages$error) > 0) { + if (length(object@messages$error) > 0L) { condition_messages <- condition_summary(object@messages$error) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "error was", "errors were"), + ifelse(length(condition_messages) == 1L, "error was", "errors were"), " encountered while trying to train the model:\n", paste0(condition_messages, collapse = "\n"), - "\n")) + "\n" + )) } } # Describe the learner and the version of familiar. message_str <- paste0( - "A naive ", object@learner, " model (class: ", class(object)[1], - "; ", .familiar_version_string(object), ")") + "A naive ", object@learner, " model (class: ", class(object)[1L], + "; ", .familiar_version_string(object), ")" + ) # Describe the package(s), if any if (!is.null(object@package)) { @@ -400,8 +479,10 @@ setMethod( paste_s(mapply( ..message_package_version, x = object@package, - version = object@package_version)), - ifelse(length(object@package) > 1, " packages", " package")) + version = object@package_version + )), + ifelse(length(object@package) > 1L, " packages", " package") + ) } # Complete message and write. @@ -430,32 +511,35 @@ setMethod( function(x, object) { cat(paste0(" ", x, ": ", object@hyperparameters[[x]], "\n")) }, - object = object)) + object = object + )) # Add note that naive models don't directly use hyperparameters. if (model_is_trained(object)) { cat("Note that the above hyperparameters are not directly used by the naive model.\n") } - if (length(object@messages$warning) > 0 || length(object@messages$error) > 0) { + if (length(object@messages$warning) > 0L || length(object@messages$error) > 0L) { cat(paste0("\n------------ Warnings and errors ------------\n")) - if (length(object@messages$warning) > 0) { + if (length(object@messages$warning) > 0L) { condition_messages <- condition_summary(object@messages$warning) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "warning was", "warnings were"), + ifelse(length(condition_messages) == 1L, "warning was", "warnings were"), " generated while training the model:\n", - paste0(condition_messages, collapse = "\n"))) + paste0(condition_messages, collapse = "\n") + )) } - if (length(object@messages$error) > 0) { + if (length(object@messages$error) > 0L) { condition_messages <- condition_summary(object@messages$error) cat(paste0( "\nThe following ", - ifelse(length(condition_messages) == 1, "error was", "errors were"), + ifelse(length(condition_messages) == 1L, "error was", "errors were"), " encountered while training the model:\n", - paste0(condition_messages, collapse = "\n"))) + paste0(condition_messages, collapse = "\n") + )) } } diff --git a/R/LearnerS4NaiveBayes.R b/R/LearnerS4NaiveBayes.R index 81d10646..9f93b01b 100644 --- a/R/LearnerS4NaiveBayes.R +++ b/R/LearnerS4NaiveBayes.R @@ -7,7 +7,8 @@ NULL # familiarNaiveBayes ----------------------------------------------------------- setClass( "familiarNaiveBayes", - contains = "familiarModel") + contains = "familiarModel" +) @@ -56,22 +57,22 @@ setMethod( # If data is explicitly set to NULL, return the list with # hyperparameter names only. - if (is.null(data)) { - return(param) - } - + if (is.null(data)) return(param) + # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size( data = data, - restrict_samples = TRUE) + restrict_samples = TRUE + ) # laplace smoothing parameter ---------------------------------------------- param$laplace <- .set_hyperparameter( - default = c(0, 1, 2, 5), + default = c(0.0, 1.0, 2.0, 5.0), type = "numeric", - range = c(0, 10), - valid_range = c(0, Inf), - randomise = TRUE) + range = c(0.0, 10.0), + valid_range = c(0.0, Inf), + randomise = TRUE + ) return(param) } @@ -84,20 +85,23 @@ setMethod( "..train", signature( object = "familiarNaiveBayes", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Check if training data is ok. if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -109,7 +113,8 @@ setMethod( # Parse formula formula <- stats::reformulate( termlabels = feature_columns, - response = quote(outcome)) + response = quote(outcome) + ) # Train the model. model <- do.call_with_handlers( @@ -117,7 +122,9 @@ setMethod( args = list( formula, "data" = data@data, - "laplace" = object@hyperparameters$laplace)) + "laplace" = object@hyperparameters$laplace + ) + ) # Extract values. object <- ..update_warnings(object = object, model$warning) @@ -146,7 +153,8 @@ setMethod( "..train_naive", signature( object = "familiarNaiveBayes", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { if (object@outcome_type %in% c("binomial", "multinomial")) { # Turn into a Naive model. @@ -156,7 +164,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -167,73 +176,70 @@ setMethod( "..predict", signature( object = "familiarNaiveBayes", - data = "dataObject"), + data = "dataObject" + ), function(object, data, type = "default", ...) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) { + return(callNextMethod()) + } + + # Check if the data is empty. + if (is_empty(data)) { + return(callNextMethod()) + } + if (type == "default") { - # Default method --------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = type) - - # Use the model to predict class probabilities. - model_predictions <- predict( - object = object@model, - newdata = data@data, - type = "raw") - - # Obtain class levels. - class_levels <- get_outcome_class_levels(x = object) - - # Add class probabilities. - class_probability_columns <- get_class_probability_name(x = object) - for (ii in seq_along(class_probability_columns)) { - prediction_table[, (class_probability_columns[ii]) := model_predictions[, class_levels[ii]]] - } - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[apply( - prediction_table[, mget(class_probability_columns)], 1, which.max)] + # default ---------------------------------------------------------------- - class_predictions <- factor(class_predictions, levels = class_levels) - prediction_table[, "predicted_class" := class_predictions] + if (object@outcome_type %in% c("binomial", "multinomial")) { + + # Use the model to predict class probabilities. + model_predictions <- predict( + object = object@model, + newdata = data@data, + type = "raw" + ) + + # Obtain class levels. + class_levels <- get_outcome_class_levels(x = object) + + # Add class probabilities. + prediction_list <- list() + for (ii in seq_along(class_levels)) { + prediction_list[[class_levels[ii]]] <- model_predictions[, class_levels[ii]] + } + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) + + } else { + ..error_outcome_type_not_implemented(object@outcome_type) + } return(prediction_table) - } else { - # User-specified method -------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) { - return(NULL) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(NULL) - } + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- # Use the model for prediction. return(predict( object = object@model, newdata = data@data, type = type, - ...)) + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } } ) diff --git a/R/LearnerS4RFSRC.R b/R/LearnerS4RFSRC.R index 946eae52..fa7f58fe 100644 --- a/R/LearnerS4RFSRC.R +++ b/R/LearnerS4RFSRC.R @@ -42,7 +42,10 @@ setMethod( function(object, ...) { # Random forests exists for all outcome types and variable importance # methods. - if (object@outcome_type == "count") ..deprecation_count() + if (object@outcome_type == "count") { + ..deprecation_count() + return(FALSE) + } return(TRUE) } @@ -71,9 +74,6 @@ setMethod( # Variable importance only parameters (are not optimised by hyperparameter # optimisation) param$fs_vimp_method <- list() - param$fs_vh_fold <- list() - param$fs_vh_step_size <- list() - param$fs_vh_n_rep <- list() # If datat is not provided, return the list with hyperparameter names only if (is.null(data)) return(param) @@ -90,11 +90,12 @@ setMethod( # T. M., Perez, P. S., & Baranauskas, J. A. (2012, July). How many trees in # a random forest?. In MLDM (pp. 154-168). param$n_tree <- .set_hyperparameter( - default = c(4, 8, 10), + default = c(4L, 8L, 10L), type = "integer", - range = c(4, 10), - valid_range = c(0, Inf), - randomise = TRUE) + range = c(4L, 10L), + valid_range = c(0L, Inf), + randomise = TRUE + ) # sample size -------------------------------------------------------------- @@ -103,9 +104,10 @@ setMethod( param$sample_size <- .set_hyperparameter( default = c(0.30, 0.50, 0.70, 0.90), type = "numeric", - range = c(2.0 / n_samples, 1.00), - valid_range = c(0, 1.0), - randomise = TRUE) + range = c(2.0 / n_samples, 1.0), + valid_range = c(0.0, 1.0), + randomise = TRUE + ) # number of candidate features selected at node ---------------------------- @@ -116,51 +118,56 @@ setMethod( default = c(0.1, 0.3, 0.5, 1.0), type = "numeric", range = c(0.0, 1.0), - randomise = TRUE) - + randomise = TRUE + ) + # terminal node size ------------------------------------------------------- # Number of instances in the terminal node. Larger terminal node sizes limit # tree depth and overfitting. # Define the default range. - node_size_range <- c(5, floor(n_samples / 3)) + node_size_range <- c(5L, as.integer(max(c(5L, floor(n_samples / 3L))))) # Define the default values. - node_size_default <- c(5, 10, 20, 50) + node_size_default <- c(5L, 10L, 20L, 50L) node_size_default <- node_size_default[ - node_size_default >= node_size_range[1] & - node_size_default <= node_size_range[2]] + node_size_default >= node_size_range[1L] & + node_size_default <= node_size_range[2L] + ] # Set the node_size parameter. param$node_size <- .set_hyperparameter( default = node_size_default, type = "integer", range = node_size_range, - valid_range = c(1, Inf), - randomise = TRUE) + valid_range = c(1L, Inf), + randomise = TRUE + ) # maximum tree depth ------------------------------------------------------- # Determines the depth trees are allowed to grow to. Larger depths increase # the risk of overfitting. param$tree_depth <- .set_hyperparameter( - default = c(1, 2, 3, 7), + default = c(1L, 2L, 3L, 7L), type = "integer", - range = c(1, 10), - valid_range = c(1, Inf), - randomise = TRUE) + range = c(1L, 10L), + valid_range = c(1L, Inf), + randomise = TRUE + ) # number of split points --------------------------------------------------- # The number of split points for each candidate variable is not randomised # by default, and deterministic splitting is used. param$n_split <- .set_hyperparameter( - default = 0, + default = 0L, type = "integer", - range = c(0, 10), - valid_range = c(0, Inf), - randomise = FALSE) + range = c(0L, 10L), + valid_range = c(0L, Inf), + randomise = FALSE + ) # splitting rule ----------------------------------------------------------- @@ -168,7 +175,7 @@ setMethod( if (data@outcome_type %in% c("binomial", "multinomial")) { split_rule_range <- c("gini", "auc", "entropy") split_rule_default <- "gini" - } else if (data@outcome_type %in% c("continuous", "count")) { + } else if (data@outcome_type %in% c("continuous")) { split_rule_range <- c("mse", "quantile.regr", "la.quantile.regr") split_rule_default <- "mse" } else if (data@outcome_type == "survival") { @@ -186,14 +193,16 @@ setMethod( default = split_rule_default, type = "factor", range = split_rule_range, - randomise = FALSE) + randomise = FALSE + ) # sample weighting method -------------------------------------------------- # Class imbalances may lead to learning majority classes. This can be # partially mitigated by increasing weight of minority classes. param$sample_weighting <- .get_default_sample_weighting_method( - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) # effective number of samples beta ----------------------------------------- @@ -203,39 +212,18 @@ setMethod( param$sample_weighting_beta <- .get_default_sample_weighting_beta( method = c( param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type = object@outcome_type) + user_list$sample_weighting + ), + outcome_type = object@outcome_type + ) # variable importance method ----------------------------------------------- param$fs_vimp_method <- .set_hyperparameter( default = "permutation", type = "factor", - range = c("permutation", "minimum_depth", "variable_hunting", "holdout"), - randomise = FALSE) - - # variable hunting cross-validation folds (variable importance only) ------- - param$fs_vh_fold <- .set_hyperparameter( - default = 5, - type = "integer", - range = c(2, n_samples), - valid_range = c(2, Inf), - randomise = FALSE) - - # variable hunting step size (variable importance only) -------------------- - param$fs_vh_step_size <- .set_hyperparameter( - default = 1, - type = "integer", - range = c(1, 50), - valid_range = c(1, Inf), - randomise = FALSE) - - # variable hunting repetitions (variable importance only) ------------------ - param$fs_vh_n_rep <- .set_hyperparameter( - default = 50, - type = "integer", - range = c(1, 50), - valid_range = c(1, Inf), - randomise = FALSE) + range = c("permutation", "holdout"), + randomise = FALSE + ) return(param) } @@ -247,7 +235,12 @@ setMethod( setMethod( "get_default_hyperparameters", signature(object = "familiarRFSRCDefault"), - function(object, data = NULL, user_list = NULL, ...) { + function( + object, + data = NULL, + user_list = NULL, + ... + ) { # Initialise list and declare hyperparameter entries param <- list() param$sign_size <- list() @@ -257,16 +250,10 @@ setMethod( # Variable importance only parameters (are not optimised by hyperparameter # optimisation) param$fs_vimp_method <- list() - param$fs_vh_fold <- list() - param$fs_vh_step_size <- list() - param$fs_vh_n_rep <- list() # If data is not provided, return the list with hyperparameter names only. if (is.null(data)) return(param) - # Get the number of samples - n_samples <- get_n_samples(data, id_depth = "series") - # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size(data = data) @@ -275,7 +262,8 @@ setMethod( # Class imbalances may lead to learning majority classes. This can be # partially mitigated by increasing weight of minority classes. param$sample_weighting <- .get_default_sample_weighting_method( - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) # effective number of samples beta ----------------------------------------- @@ -284,39 +272,18 @@ setMethod( param$sample_weighting_beta <- .get_default_sample_weighting_beta( method = c( param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type = object@outcome_type) + user_list$sample_weighting + ), + outcome_type = object@outcome_type + ) # variable importance method ----------------------------------------------- param$fs_vimp_method <- .set_hyperparameter( default = "permutation", type = "factor", - range = c("permutation", "minimum_depth", "variable_hunting", "holdout"), - randomise = FALSE) - - # variable hunting cross-validation folds (variable importance only) ------- - param$fs_vh_fold <- .set_hyperparameter( - default = 5, - type = "integer", - range = c(2, n_samples), - valid_range = c(2, Inf), - randomise = FALSE) - - # variable hunting step size (variable importance only) -------------------- - param$fs_vh_step_size <- .set_hyperparameter( - default = 1, - type = "integer", - range = c(1, 50), - valid_range = c(1, Inf), - randomise = FALSE) - - # variable hunting repetitions (variable importance only) ------------------ - param$fs_vh_n_rep <- .set_hyperparameter( - default = 50, - type = "integer", - range = c(1, 50), - valid_range = c(1, Inf), - randomise = FALSE) + range = c("permutation", "holdout"), + randomise = FALSE + ) return(param) } @@ -338,7 +305,7 @@ setMethod( } else if (type %in% c("response", "cumulative_hazard")) { return("cumulative_hazard") } else { - stop(paste0("Prediction type is not implemented: ", type)) + ..error(paste0("Prediction type is not implemented: ", type)) } } else { @@ -354,8 +321,14 @@ setMethod( "..train", signature( object = "familiarRFSRC", - data = "dataObject"), - function(object, data, anonymous = TRUE, ...) { + data = "dataObject" + ), + function( + object, + data, + anonymous = TRUE, + ... + ) { # Aggregate repeated measurement data - randomForestSRC does not facilitate # repeated measurements. data <- aggregate_data(data = data) @@ -364,14 +337,16 @@ setMethod( if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -385,12 +360,14 @@ setMethod( Surv <- survival::Surv formula <- stats::reformulate( termlabels = feature_columns, - response = quote(Surv(outcome_time, outcome_event))) + response = quote(Surv(outcome_time, outcome_event)) + ) - } else if (object@outcome_type %in% c("binomial", "multinomial", "count", "continuous")) { + } else if (object@outcome_type %in% c("binomial", "multinomial", "continuous")) { formula <- stats::reformulate( termlabels = feature_columns, - response = quote(outcome)) + response = quote(outcome) + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) @@ -408,14 +385,17 @@ setMethod( data = data, method = object@hyperparameters$sample_weighting, beta = ..compute_effective_number_of_samples_beta( - object@hyperparameters$sample_weighting_beta), - normalisation = "average_one") + object@hyperparameters$sample_weighting_beta + ), + normalisation = "average_one" + ) # Set forest seed. If object comes with a defined seed use the seed. forest_seed <- ifelse( is.null(object@seed), - as.integer(stats::runif(1, -100000, -1)), - object@seed) + as.integer(stats::runif(1L, -100000L, -1L)), + object@seed + ) # Use anonymised version for the forest, if available. if (utils::packageVersion("randomForestSRC") >= "2.11.0" && anonymous) { @@ -428,27 +408,31 @@ setMethod( learner_arguments <- list(formula, "data" = data@data, "case.wt" = weights, - "seed" = forest_seed) + "seed" = forest_seed + ) # Add additional hyperparameters for models that use them. if (!is(object, "familiarRFSRCDefault")) { learner_arguments <- c( learner_arguments, list( - "ntree" = 2^param$n_tree, + "ntree" = 2L^param$n_tree, "samptype" = sample_type, "sampsize" = sample_size, - "mtry" = max(c(1, ceiling(param$m_try * length(feature_columns)))), + "mtry" = max(c(1L, ceiling(param$m_try * length(feature_columns)))), "nodesize" = param$node_size, "nodedepth" = param$tree_depth, "nsplit" = param$n_split, - "splitrule" = as.character(param$split_rule))) + "splitrule" = as.character(param$split_rule) + ) + ) } # Train the model. model <- do.call_with_handlers( forest_function, - args = learner_arguments) + args = learner_arguments + ) # Extract values. object <- ..update_warnings(object = object, model$warning) @@ -479,9 +463,10 @@ setMethod( "..train_naive", signature( object = "familiarRFSRC", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { - if (object@outcome_type %in% c("count", "continuous", "binomial", "multinomial")) { + if (object@outcome_type %in% c("continuous", "binomial", "multinomial")) { # Turn into a Naive model. object <- methods::new("familiarNaiveModel", object) @@ -493,7 +478,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -504,49 +490,67 @@ setMethod( "..predict", signature( object = "familiarRFSRC", - data = "dataObject"), - function(object, data, type = "default", time = NULL, ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) { + return(NULL) + } + + # Check if the data is empty. + if (is_empty(data)) { + return(NULL) + } + if (type %in% c("default", "survival_probability")) { # Default method --------------------------------------------------------- - # Check if the model was trained. - if (!model_is_trained(object)) return(callNextMethod()) - - # Check if the data is empty. - if (is_empty(data)) return(callNextMethod()) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = type) - # Make predictions using the model. model_predictions <- predict( object = object@model, - newdata = data@data) + newdata = data@data + ) if (object@outcome_type %in% c("binomial", "multinomial")) { # categorical outcomes ------------------------------------------------- - # Set predicted class. - prediction_table[, "predicted_class" := model_predictions$class] - - # Add class probabilities. - class_probability_columns <- get_class_probability_name(x = object) + # Obtain class levels. + class_levels <- colnames(model_predictions$predicted) - for (ii in seq_along(class_probability_columns)) { - prediction_table[, (class_probability_columns[ii]) := model_predictions$predicted[, ii]] + # Add class probabilities. + prediction_list <- list() + for (ii in seq_along(class_levels)) { + prediction_list[[class_levels[ii]]] <- model_predictions$predicted[, ii] } - } else if (object@outcome_type %in% c("continuous", "count")) { + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) + + } else if (object@outcome_type %in% c("continuous")) { # numerical outcomes --------------------------------------------------- - # Extract predicted regression values. - prediction_table[, "predicted_outcome" := model_predictions$predicted] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = as.numeric(model_predictions$predicted), + type = "regression", + data = data, + model_object = object + ) } else if (object@outcome_type %in% c("survival")) { # survival outcomes ---------------------------------------------------- @@ -561,23 +565,27 @@ setMethod( # Cumulative hazard. # Get the cumulative hazards at the given time point. - prediction_table <- process_random_forest_survival_predictions( + prediction_table <- .random_forest_survival_predictions( + object = object, event_matrix = model_predictions$chf, event_times = event_times, - prediction_table = prediction_table, + data = data, time = time, - type = "cumulative_hazard") + type = "cumulative_hazard" + ) } else if (type == "survival_probability") { # Survival probability. # Get the survival probability at the given time point. - prediction_table <- process_random_forest_survival_predictions( + prediction_table <- .random_forest_survival_predictions( + object = object, event_matrix = model_predictions$survival, event_times = event_times, - prediction_table = prediction_table, + data = data, time = time, - type = "survival") + type = "survival" + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) @@ -586,48 +594,37 @@ setMethod( return(prediction_table) - } else { + } else if (!.is_available_prediction_type(type)) { # User-specified method -------------------------------------------------- - # Check if the model was trained. - if (!model_is_trained(object)) { - return(NULL) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(NULL) - } - # Make predictions using the model. return(predict( object = object@model, newdata = data@data, - ...)) + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } } ) -# ..predict_survival_probability ----------------------------------------------- +# ..get_prediction_table_type -------------------------------------------------- setMethod( - "..predict_survival_probability", - signature( - object = "familiarRFSRC", - data = "dataObject"), - function(object, data, time, ...) { + "..get_prediction_table_type", + signature(object = "familiarRFSRC"), + function(object, type, ...) { + prediction_table_type <- NULL + if (object@outcome_type %in% c("survival") && type == "default") { + prediction_table_type <- "cumulative_hazard" + } else { + prediction_table_type <- callNextMethod() + } - if (!object@outcome_type %in% c("survival")) return(callNextMethod()) - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - return(..predict( - object = object, - data = data, - time = time, - type = "survival_probability")) + return(prediction_table_type) } ) @@ -646,7 +643,8 @@ setMethod( data = data, get_additional_info = FALSE, trim_model = FALSE, - anonymous = FALSE) + anonymous = FALSE + ) } # Check if the model has been trained upon retry. @@ -660,7 +658,8 @@ setMethod( if (is.null(vimp_method)) { ..error_reached_unreachable_code(paste0( "..vimp,familiarRFSRC: vimp method was not specified as a ", - "hyperparameter (fs_vimp_method)")) + "hyperparameter (fs_vimp_method)" + )) } vimp_method <- as.character(vimp_method) @@ -675,7 +674,8 @@ setMethod( data = data, get_additional_info = FALSE, trim_model = FALSE, - anonymous = FALSE) + anonymous = FALSE + ) # Check that the non-anonymous model is trained. if (!model_is_trained(object)) return(callNextMethod()) @@ -694,7 +694,8 @@ setMethod( # outcomes is per class if (is.matrix(vimp_score)) { vimp_score_names <- rownames(vimp_score) - vimp_score <- vimp_score[, 1] + vimp_score <- vimp_score[, 1L] + } else { vimp_score_names <- names(vimp_score) } @@ -704,126 +705,48 @@ setMethod( "vimpTable", vimp_table = data.table::data.table( "score" = vimp_score, - "name" = vimp_score_names), + "name" = vimp_score_names + ), score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } else if (vimp_method == "minimum_depth") { - # Check if the model is anonymous, and rebuild if it is. VIMP does not - # work otherwise. - if (inherits(object@model, "anonymous")) { - object <- .train( - object = object, - data = data, - get_additional_info = FALSE, - trim_model = FALSE, - anonymous = FALSE) - - # Check that the non-anonymous model is trained. - if (!model_is_trained(object)) return(callNextMethod()) - } - - # Determine minimum depth variable importance - vimp_score <- randomForestSRC::var.select( - object = object@model, - method = "md", - verbose = FALSE - )$md.obj$order - - # Check that the variable importance score is not empty. - if (is_empty(vimp_score)) return(callNextMethod()) - - # Select the "min depth" column, which is the first column - if (is.matrix(vimp_score)) { - vimp_score_names <- rownames(vimp_score) - vimp_score <- vimp_score[, 1] - } else { - vimp_score_names <- names(vimp_score) - } - - # Create variable importance object. - vimp_object <- methods::new( - "vimpTable", - vimp_table = data.table::data.table( - "score" = vimp_score, - "name" = vimp_score_names), - score_aggregation = "max", - invert = FALSE) - - return(vimp_object) + ..deprecation_rfsrc_minimum_depth() + return(callNextMethod()) } else if (vimp_method == "variable_hunting") { - # Check if the model is anonymous, and rebuild if it is. VIMP does not - # work otherwise. - if (inherits(object@model, "anonymous")) { - object <- .train( - object = object, - data = data, - get_additional_info = FALSE, - trim_model = FALSE, - anonymous = FALSE) - - # Check that the non-anonymous model is trained. - if (!model_is_trained(object)) return(callNextMethod()) - } - - # Perform variable hunting - vimp_score <- randomForestSRC::var.select( - object = object@model, - method = "vh", - K = object@hyperparameters$fs_vh_fold, - nstep = object@hyperparameters$fs_vh_step_size, - nrep = object@hyperparameters$fs_vh_n_rep, - verbose = FALSE, - refit = FALSE - )$varselect - - # Check that the variable importance score is not empty. - if (is_empty(vimp_score)) return(callNextMethod()) - - # Select the "rel.freq" column, which is the second column - if (is.matrix(vimp_score)) { - vimp_score_names <- rownames(vimp_score) - vimp_score <- vimp_score[, 2] - } else { - vimp_score_names <- names(vimp_score) - } - - # Create variable importance object. - vimp_object <- methods::new( - "vimpTable", - vimp_table = data.table::data.table( - "score" = vimp_score, - "name" = vimp_score_names), - score_aggregation = "max", - invert = TRUE) - - return(vimp_object) + ..deprecation_rfsrc_variable_hunting() + return(callNextMethod()) } else if (vimp_method == "holdout") { # Check that data is present. if (is_empty(data)) { warning(paste0( "Data is required to assess variable importance using ", - "randomForestRFSRC::holdout.vimp")) + "randomForestRFSRC::holdout.vimp" + )) return(callNextMethod()) } - if (get_n_features(data) <= 1) { + if (get_n_features(data) <= 1L) { warning(paste0( "Variable importance using randomForestRFSRC::holdout.vimp ", - "requires more than 1 feature.")) + "requires more than 1 feature." + )) # Create variable importance object. vimp_object <- methods::new( "vimpTable", vimp_table = data.table::data.table( "score" = 0.0, - "name" = get_feature_columns(x = data)), + "name" = get_feature_columns(x = data) + ), score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } @@ -838,12 +761,14 @@ setMethod( Surv <- survival::Surv formula <- stats::reformulate( termlabels = feature_columns, - response = quote(Surv(outcome_time, outcome_event))) + response = quote(Surv(outcome_time, outcome_event)) + ) - } else if (object@outcome_type %in% c("binomial", "multinomial", "count", "continuous")) { + } else if (object@outcome_type %in% c("binomial", "multinomial", "continuous")) { formula <- stats::reformulate( termlabels = feature_columns, - response = quote(outcome)) + response = quote(outcome) + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) @@ -853,7 +778,8 @@ setMethod( learner_arguments <- list( formula, "data" = data@data, - "verbose" = FALSE) + "verbose" = FALSE + ) # Get additional variables for the optimised learner. if (!is(object, "familiarRFSRCDefault")) { @@ -864,13 +790,15 @@ setMethod( learner_arguments <- c( learner_arguments, list( - "mtry" = max(c(1, ceiling(object@hyperparameters$m_try * get_n_features(data)))), + "mtry" = max(c(1L, ceiling(object@hyperparameters$m_try * get_n_features(data)))), "samptype" = sample_type, "sampsize" = sample_size, "nodesize" = object@hyperparameters$node_size, "nodedepth" = object@hyperparameters$tree_depth, "nsplit" = object@hyperparameters$n_split, - "splitrule" = as.character(object@hyperparameters$split_rule))) + "splitrule" = as.character(object@hyperparameters$split_rule) + ) + ) } # Perform holdout variable importance. @@ -885,7 +813,8 @@ setMethod( # Select the "all" column, which is the first column if (is.matrix(vimp_score)) { vimp_score_names <- rownames(vimp_score) - vimp_score <- vimp_score[, 1] + vimp_score <- vimp_score[, 1L] + } else { vimp_score_names <- names(vimp_score) } @@ -895,15 +824,18 @@ setMethod( "vimpTable", vimp_table = data.table::data.table( "score" = vimp_score, - "name" = vimp_score_names), + "name" = vimp_score_names + ), score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } else { ..error_reached_unreachable_code(paste0( - "..vimp,familiarRFSRC: unknown vimp method was specified: ", vimp_method)) + "..vimp,familiarRFSRC: unknown vimp method was specified: ", vimp_method + )) } return(NULL) @@ -923,6 +855,7 @@ setMethod( if (object@outcome_type == "survival") { # Determine baseline survival. object@calibration_info <- get_baseline_survival(data = data) + } else { return(callNextMethod()) } @@ -937,40 +870,53 @@ setMethod( setMethod( "..set_vimp_parameters", signature(object = "familiarRFSRC"), - function(object, method, ...) { + function( + object, + method, + ... + ) { # Determine variable importance method if (startswith_any( method, prefix = c( "random_forest_permutation", - "random_forest_rfsrc_permutation"))) { + "random_forest_rfsrc_permutation" + ) + )) { vimp_method <- "permutation" } else if (startswith_any( method, prefix = c( "random_forest_minimum_depth", - "random_forest_rfsrc_minimum_depth"))) { - vimp_method <- "minimum_depth" + "random_forest_rfsrc_minimum_depth" + ) + )) { + ..deprecation_rfsrc_minimum_depth(as_error = TRUE) } else if (startswith_any( method, prefix = c( "random_forest_variable_hunting", - "random_forest_rfsrc_variable_hunting"))) { - vimp_method <- "variable_hunting" + "random_forest_rfsrc_variable_hunting" + ) + )) { + ..deprecation_rfsrc_variable_hunting(as_error = TRUE) } else if (startswith_any( method, prefix = c( "random_forest_holdout", - "random_forest_rfsrc_holdout"))) { + "random_forest_rfsrc_holdout" + ) + )) { vimp_method <- "holdout" } else { ..error_reached_unreachable_code(paste0( "..set_vimp_parameters,familiarRFSRC: unknown feature selection ", - "method was specified.")) + "method was specified." + )) } # Check if a list of hyperparameters is already present. @@ -1033,10 +979,9 @@ setMethod( .get_available_rfsrc_vimp_methods <- function(show_general = TRUE) { return(c( - "random_forest_permutation", "random_forest_minimum_depth", - "random_forest_variable_hunting", "random_forest_rfsrc_permutation", - "random_forest_rfsrc_minimum_depth", "random_forest_rfsrc_variable_hunting", - "random_forest_holdout", "random_forest_rfsrc_holdout")) + "random_forest_permutation", "random_forest_rfsrc_permutation", + "random_forest_holdout", "random_forest_rfsrc_holdout" + )) } diff --git a/R/LearnerS4Ranger.R b/R/LearnerS4Ranger.R index 40848462..d502f6bc 100644 --- a/R/LearnerS4Ranger.R +++ b/R/LearnerS4Ranger.R @@ -7,12 +7,14 @@ NULL # familiarRanger object -------------------------------------------------------- setClass( "familiarRanger", - contains = "familiarModel") + contains = "familiarModel" +) # familiarRangerDefault object -------------------------------------------------- setClass( "familiarRangerDefault", - contains = "familiarRanger") + contains = "familiarRanger" +) @@ -40,7 +42,10 @@ setMethod( function(object, ...) { # Ranger exists for all outcome types and variable importance methods, # including impurity for survival. - if (object@outcome_type == "count") ..deprecation_count() + if (object@outcome_type == "count") { + ..deprecation_count() + return(FALSE) + } return(TRUE) } @@ -74,9 +79,7 @@ setMethod( if (is.null(data)) return(param) # Get the number of samples - n_samples <- data.table::uniqueN( - data@data, - by = get_id_columns(id_depth = "series")) + n_samples <- get_n_samples(data, "series") # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size(data = data) @@ -87,11 +90,12 @@ setMethod( # T. M., Perez, P. S., & Baranauskas, J. A. (2012, July). How many trees in # a random forest?. In MLDM (pp. 154-168). param$n_tree <- .set_hyperparameter( - default = c(4, 8, 10), + default = c(4L, 8L, 10L), type = "integer", - range = c(4, 10), - valid_range = c(0, Inf), - randomise = TRUE) + range = c(4L, 10L), + valid_range = c(0L, Inf), + randomise = TRUE + ) # sample size -------------------------------------------------------------- @@ -100,9 +104,10 @@ setMethod( param$sample_size <- .set_hyperparameter( default = c(0.30, 0.50, 0.70, 1.00), type = "numeric", - range = c(2 / n_samples, 1.0), - valid_range = c(0, 1), - randomise = TRUE) + range = c(2.0 / n_samples, 1.0), + valid_range = c(0.0, 1.0), + randomise = TRUE + ) # number of candidate features selected at node ---------------------------- @@ -113,7 +118,8 @@ setMethod( default = c(0.1, 0.3, 0.5, 1.0), type = "numeric", range = c(0.0, 1.0), - randomise = TRUE) + randomise = TRUE + ) # terminal node size ------------------------------------------------------- @@ -121,32 +127,35 @@ setMethod( # tree depth and overfitting. # Define the default range. - node_size_range <- c(5, floor(n_samples / 3)) + node_size_range <- c(5L, as.integer(floor(n_samples / 3.0))) # Define the default values. - node_size_default <- c(5, 10, 20, 50) + node_size_default <- c(5L, 10L, 20L, 50L) node_size_default <- node_size_default[ - node_size_default >= node_size_range[1] & - node_size_default <= node_size_range[2]] + node_size_default >= node_size_range[1L] & + node_size_default <= node_size_range[2L] + ] # Set the node_size parameter. param$node_size <- .set_hyperparameter( default = node_size_default, type = "integer", range = node_size_range, - valid_range = c(1, Inf), - randomise = TRUE) + valid_range = c(1L, Inf), + randomise = TRUE + ) # maximum tree depth ------------------------------------------------------- # Determines the depth trees are allowed to grow to. Larger depths increase # the risk of overfitting. param$tree_depth <- .set_hyperparameter( - default = c(1, 2, 3, 7), + default = c(1L, 2L, 3L, 7L), type = "integer", - range = c(1, 10), - valid_range = c(1, Inf), - randomise = TRUE) + range = c(1L, 10L), + valid_range = c(1L, Inf), + randomise = TRUE + ) # splitting rule ----------------------------------------------------------- @@ -154,7 +163,7 @@ setMethod( if (object@outcome_type %in% c("binomial", "multinomial")) { split_rule_range <- c("gini", "extratrees", "hellinger") split_rule_default <- "gini" - } else if (object@outcome_type %in% c("continuous", "count")) { + } else if (object@outcome_type %in% c("continuous")) { split_rule_range <- c("variance", "extratrees", "maxstat", "beta") split_rule_default <- "maxstat" } else if (object@outcome_type == "survival") { @@ -169,7 +178,8 @@ setMethod( default = split_rule_default, type = "factor", range = split_rule_range, - randomise = FALSE) + randomise = FALSE + ) # significance threshold for splitting ------------------------------------- @@ -187,17 +197,19 @@ setMethod( param$alpha <- .set_hyperparameter( default = default_values, type = "numeric", - range = c(10^-6, 1.0), + range = c(10.0^-6.0, 1.0), valid_range = c(0.0, 1.0), randomise = alpha_randomise, - distribution = "log") + distribution = "log" + ) # sample weighting method -------------------------------------------------- # Class imbalances may lead to learning majority classes. This can be # partially mitigated by increasing weight of minority classes. param$sample_weighting <- .get_default_sample_weighting_method( - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) # effective number of samples beta ----------------------------------------- @@ -206,8 +218,10 @@ setMethod( param$sample_weighting_beta <- .get_default_sample_weighting_beta( method = c( param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type = object@outcome_type) + user_list$sample_weighting + ), + outcome_type = object@outcome_type + ) # feature selection forest type -------------------------------------------- @@ -218,7 +232,8 @@ setMethod( default = "standard", type = "factor", range = c("standard", "holdout"), - randomise = FALSE) + randomise = FALSE + ) # feature selection variable importance method ----------------------------- @@ -228,7 +243,8 @@ setMethod( default = "permutation", type = "factor", range = c("permutation", "impurity", "impurity_corrected"), - randomise = FALSE) + randomise = FALSE + ) return(param) } @@ -246,6 +262,7 @@ setMethod( param$sign_size <- list() param$sample_weighting <- list() param$sample_weighting_beta <- list() + param$split_rule <- list() # The following hyperparameters are only used for feature selection. param$fs_forest_type <- list() @@ -261,7 +278,8 @@ setMethod( # Class imbalances may lead to learning majority classes. This can be # partially mitigated by increasing weight of minority classes. param$sample_weighting <- .get_default_sample_weighting_method( - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) # effective number of samples beta ----------------------------------------- # Specifies the beta parameter for effective number sample weighting method. @@ -269,9 +287,35 @@ setMethod( param$sample_weighting_beta <- .get_default_sample_weighting_beta( method = c( param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type = object@outcome_type) + user_list$sample_weighting + ), + outcome_type = object@outcome_type + ) + # splitting rule ----------------------------------------------------------- + + # Availability of splitting rules is dependent on the type of outcome. + if (object@outcome_type %in% c("binomial", "multinomial")) { + split_rule_range <- c("gini", "extratrees", "hellinger") + split_rule_default <- "gini" + } else if (object@outcome_type %in% c("continuous")) { + split_rule_range <- c("variance", "extratrees", "maxstat", "beta") + split_rule_default <- "maxstat" + } else if (object@outcome_type == "survival") { + split_rule_range <- c("logrank", "extratrees", "C", "maxstat") + split_rule_default <- "maxstat" + } else { + ..error_no_known_outcome_type(object@outcome_type) + } + + # Set the split_rule parameter. + param$split_rule <- .set_hyperparameter( + default = split_rule_default, + type = "factor", + range = split_rule_range, + randomise = FALSE + ) + # feature selection forest type -------------------------------------------- # Enables the construction of holdout forests. A conventional forest is # grown by default. @@ -279,7 +323,8 @@ setMethod( default = "standard", type = "factor", range = c("standard", "holdout"), - randomise = FALSE) + randomise = FALSE + ) # feature selection variable importance method ----------------------------- # Enables the use of different variable importance methods. The permutation @@ -288,7 +333,8 @@ setMethod( default = "permutation", type = "factor", range = c("permutation", "impurity", "impurity_corrected"), - randomise = FALSE) + randomise = FALSE + ) return(param) } @@ -323,7 +369,8 @@ setMethod( "..train", signature( object = "familiarRanger", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Aggregate repeated measurement data - ranger does not facilitate repeated # measurements. @@ -333,14 +380,16 @@ setMethod( if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -353,12 +402,15 @@ setMethod( if (object@outcome_type == "survival") { formula <- stats::reformulate( termlabels = feature_columns, - response = quote(survival::Surv(outcome_time, outcome_event))) + response = quote(survival::Surv(outcome_time, outcome_event)) + ) - } else if (object@outcome_type %in% c("binomial", "multinomial", "count", "continuous")) { + } else if (object@outcome_type %in% c("binomial", "multinomial", "continuous")) { formula <- stats::reformulate( termlabels = feature_columns, - response = quote(outcome)) + response = quote(outcome) + ) + } else { ..error_outcome_type_not_implemented(object@outcome_type) } @@ -374,27 +426,32 @@ setMethod( data = data, method = object@hyperparameters$sample_weighting, beta = ..compute_effective_number_of_samples_beta( - object@hyperparameters$sample_weighting_beta), - normalisation = "average_one") + object@hyperparameters$sample_weighting_beta + ), + normalisation = "average_one" + ) # Get the arguments which are shared between holdout and standard forests. learner_arguments <- list(formula, "data" = data@data, "probability" = fit_probability, "num.threads" = 1L, - "verbose" = FALSE) + "verbose" = FALSE, + "splitrule" = as.character(param$split_rule) + ) if (!is(object, "familiarRangerDefault")) { # Non-default random forests have more arguments. learner_arguments <- c( learner_arguments, list( - "num.trees" = 2^param$n_tree, - "mtry" = max(c(1, ceiling(param$m_try * length(feature_columns)))), + "num.trees" = 2.0^param$n_tree, + "mtry" = max(c(1.0, ceiling(param$m_try * length(feature_columns)))), "min.node.size" = param$node_size, "max.depth" = param$tree_depth, - "alpha" = param$alpha, - "splitrule" = as.character(param$split_rule))) + "alpha" = param$alpha + ) + ) } # Create random forest using ranger. @@ -406,7 +463,8 @@ setMethod( # Non-default random forests have more arguments. learner_arguments <- c( learner_arguments, - list("sample.fraction" = param$sample_size)) + list("sample.fraction" = param$sample_size) + ) } model <- do.call_with_handlers( @@ -415,18 +473,23 @@ setMethod( learner_arguments, list( "case.weights" = weights, - "importance" = as.character(param$fs_vimp_method)))) + "importance" = as.character(param$fs_vimp_method) + ) + ) + ) } else if (param$fs_forest_type == "holdout") { # Hold-out random forest (used only for variable importance estimations). model <- do.call_with_handlers( ranger::holdoutRF, - args = learner_arguments) + args = learner_arguments + ) } else { ..error_reached_unreachable_code(paste0( "..train,familiarRanger: encountered unknown forest type: ", - param$fs_forest_type)) + param$fs_forest_type + )) } # Extract values. @@ -456,9 +519,10 @@ setMethod( "..train_naive", signature( object = "familiarRanger", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { - if (object@outcome_type %in% c("count", "continuous", "binomial", "multinomial")) { + if (object@outcome_type %in% c("continuous", "binomial", "multinomial")) { # Turn into a Naive model. object <- methods::new("familiarNaiveModel", object) @@ -470,7 +534,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -481,84 +546,87 @@ setMethod( "..predict", signature( object = "familiarRanger", - data = "dataObject"), - function(object, data, type = "default", time = NULL, ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) { + return(callNextMethod()) + } + + # Check if the data is empty. + if (is_empty(data)) { + return(callNextMethod()) + } + if (type %in% c("default", "survival_probability")) { # Default method --------------------------------------------------------- - # Check if the model was trained. - if (!model_is_trained(object)) { - return(callNextMethod()) - } - - # Check if the data is empty. - if (is_empty(data)) { - return(callNextMethod()) - } - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = type) - # Make predictions using the model. if (inherits(object@model, "ranger")) { model_predictions <- suppressWarnings(predict( object = object@model, data = data@data, type = "response", - num.threads = 1, - verbose = FALSE)) + num.threads = 1L, + verbose = FALSE + )) } else if (inherits(object@model, "holdoutRF")) { model_predictions <- suppressWarnings(predict( object = object@model$rf1, data = data@data, type = "response", - num.threads = 1, - verbose = FALSE)) + num.threads = 1L, + verbose = FALSE + )) + } else { ..error_reached_unreachable_code(paste0( "..predict,familiarRanger,dataObject: unknown model class detected ", - class(object@model), ". Expected: ranger, holdoutRF")) + class(object@model), ". Expected: ranger, holdoutRF" + )) } - if (object@outcome_type %in% c("binomial", "multinomial")) { # categorical outcomes ------------------------------------------------- - # Extract class levels from the predictions. + # Obtain class levels. class_levels <- colnames(model_predictions$predictions) - # We have to determine the predicted class based on the class - # probabilities. We do so by first determining the column with the - # maximum probability. Subsequently we read the corresponding class - # level, i.e. column name. - class_predicted <- class_levels[apply( - model_predictions$predictions, 1, which.max)] - - class_predicted <- factor( - x = class_predicted, - levels = get_outcome_class_levels(x = object)) - - # Set predicted class. - prediction_table[, "predicted_class" := class_predicted] - # Add class probabilities. - class_probability_columns <- get_class_probability_name(x = class_levels) - for (ii in seq_along(class_probability_columns)) { - prediction_table[, (class_probability_columns[ii]) := model_predictions$predictions[, ii]] + prediction_list <- list() + for (ii in seq_along(class_levels)) { + prediction_list[[class_levels[ii]]] <- model_predictions$predictions[, ii] } - } else if (object@outcome_type %in% c("continuous", "count")) { + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) + + } else if (object@outcome_type %in% c("continuous")) { # numerical outcomes --------------------------------------------------- - # Extract predicted regression values. - prediction_table[, "predicted_outcome" := model_predictions$predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions$predictions, + type = "regression", + data = data, + model_object = object + ) } else if (object@outcome_type %in% c("survival")) { # survival outcomes ---------------------------------------------------- @@ -577,23 +645,27 @@ setMethod( # Cumulative hazard. # Get the cumulative hazards at the given time point. - prediction_table <- process_random_forest_survival_predictions( + prediction_table <- .random_forest_survival_predictions( + object = object, event_matrix = model_predictions$chf, event_times = event_times, - prediction_table = prediction_table, + data = data, time = time, - type = "cumulative_hazard") + type = "cumulative_hazard" + ) } else if (type == "survival_probability") { # Survival probability. - + # Get the survival probability at the given time point. - prediction_table <- process_random_forest_survival_predictions( + prediction_table <- .random_forest_survival_predictions( + object = object, event_matrix = model_predictions$survival, event_times = event_times, - prediction_table = prediction_table, + data = data, time = time, - type = "survival") + type = "survival" + ) } } else { @@ -602,50 +674,39 @@ setMethod( return(prediction_table) - } else { - # User-specified method -------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) return(NULL) - - # Check if the data is empty. - if (is_empty(data)) return(NULL) + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- # Make predictions using the model. return(predict( object = object@model, data = data@data, type = type, - num.threads = 1, - ...)) + num.threads = 1L, + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } } ) -# ..predict_survival_probability ----------------------------------------------- +# ..get_prediction_table_type -------------------------------------------------- setMethod( - "..predict_survival_probability", - signature( - object = "familiarRanger", - data = "dataObject"), - function(object, data, time, ...) { - if (!object@outcome_type %in% c("survival")) { - return(callNextMethod()) + "..get_prediction_table_type", + signature(object = "familiarRanger"), + function(object, type, ...) { + prediction_table_type <- NULL + if (object@outcome_type %in% c("survival") && type == "default") { + prediction_table_type <- "cumulative_hazard" + } else { + prediction_table_type <- callNextMethod() } - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - return(..predict( - object = object, - data = data, - time = time, - type = "survival_probability")) + + return(prediction_table_type) } ) @@ -662,7 +723,8 @@ setMethod( object = object, data = data, get_additional_info = FALSE, - trim_model = FALSE) + trim_model = FALSE + ) } # Check if the model has been trained upon retry. @@ -685,9 +747,11 @@ setMethod( "vimpTable", vimp_table = data.table::data.table( "score" = vimp_score, - "name" = names(vimp_score)), + "name" = names(vimp_score) + ), score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } @@ -728,26 +792,32 @@ setMethod( method, prefix = c( "random_forest_ranger_holdout_permutation", - "random_forest_ranger_permutation"))) { + "random_forest_ranger_permutation" + ) + )) { vimp_method <- "permutation" } else if (startswith_any( method, - prefix = c("random_forest_ranger_impurity"))) { + prefix = c("random_forest_ranger_impurity") + )) { vimp_method <- "impurity_corrected" } # Determine forest type if (startswith_any( method, - prefix = c("random_forest_ranger_holdout_permutation"))) { + prefix = c("random_forest_ranger_holdout_permutation") + )) { forest_type <- "holdout" } else if (startswith_any( method, prefix = c( "random_forest_ranger_permutation", - "random_forest_ranger_impurity"))) { + "random_forest_ranger_impurity" + ) + )) { forest_type <- "standard" } @@ -818,5 +888,152 @@ setMethod( .get_available_ranger_default_vimp_methods <- function(show_general = TRUE) { return(paste0( .get_available_ranger_vimp_methods(show_general = show_general), - "_default")) + "_default" + )) +} + + + +.random_forest_survival_predictions <- function( + object, + event_matrix, + event_times, + data, + time, + type +) { + # Suppress NOTES due to non-standard evaluation in data.table + event_time <- NULL + + # Set id columns + id_columns <- get_id_columns() + + # Convert event_matrix to a matrix. + if (!is.matrix(event_matrix)) { + event_matrix <- matrix( + data = event_matrix, + ncol = length(event_matrix) + ) + } + + # Combine with identifiers and cast to table. + event_table <- cbind( + data@data[, mget(id_columns)], + data.table::as.data.table(event_matrix) + ) + + # Remove duplicate entries + event_table <- unique(event_table, by = id_columns) + + # Melt to a long format. + event_table <- data.table::melt( + event_table, + id.vars = id_columns, + variable.name = "time_variable", + value.name = "value" + ) + + # Create conversion table to convert temporary variables into the event times. + conversion_table <- data.table::data.table( + "time_variable" = paste0("V", seq_along(event_times)), + "event_time" = event_times + ) + + # Add in event times + event_table <- merge( + x = event_table, + y = conversion_table, + by = "time_variable" + ) + + # Drop the time_variable column + event_table[, "time_variable" := NULL] + + if (time %in% event_times) { + # Get the event time directly. + event_table <- event_table[event_time == time, ] + + # Remove event_time column and rename the value column to predicted_outcome. + event_table[, "event_time" := NULL] + data.table::setnames(x = event_table, old = "value", new = "predicted_outcome") + + } else { + # Add starting values. + if (!0.0 %in% event_times) { + # Create initial table + initial_event_table <- data.table::copy(event_table[event_time == event_times[1L]]) + + # Update values + if (type == "cumulative_hazard") { + initial_event_table[, ":="("value" = 0.0, "event_time" = 0.0)] + + } else if (type == "survival") { + initial_event_table[, ":="("value" = 1.0, "event_time" = 0.0)] + + } else { + ..error_reached_unreachable_code(paste0( + ".random_forest_survival_predictions: type was not recognised: ", + type + )) + } + + # Combine with the event table. + event_table <- rbind(initial_event_table, event_table) + } + + # Now, interpolate at the given time point. + event_table <- lapply( + split(event_table, by = id_columns), + function(sample_table, time, id_columns) { + # Interpolate values at the given time. + value <- stats::approx( + x = sample_table$event_time, + y = sample_table$value, + xout = time, + rule = 2L + )$y + + # Create an output table + output_table <- data.table::copy(sample_table[1L, mget(id_columns)]) + output_table[, "predicted_outcome" := value] + + return(output_table) + }, + time = time, + id_columns = id_columns + ) + + # Concatenate to single table. + event_table <- data.table::rbindlist(event_table) + } + + # Sort as original data. + event_table <- merge( + x = data@data[, mget(id_columns)], + y = event_table, + by = id_columns, + sort = FALSE + ) + + # Convert to prediction table objects. + if (type == "cumulative_hazard") { + prediction_table <- as_prediction_table( + x = event_table$predicted_outcome, + type = "cumulative_hazard", + data = data, + time = time, + model_object = object + ) + + } else { + prediction_table <- as_prediction_table( + x = event_table$predicted_outcome, + type = "survival_probability", + data = data, + time = time, + model_object = object + ) + } + + return(prediction_table) } diff --git a/R/LearnerS4SVM.R b/R/LearnerS4SVM.R index f4bd1232..62af3ae7 100644 --- a/R/LearnerS4SVM.R +++ b/R/LearnerS4SVM.R @@ -39,17 +39,20 @@ setMethod( # Extract outcome type. outcome_type <- object@outcome_type - if ( - outcome_type %in% c("continuous", "count") && - (is(object, "familiarSVMNu") || is(object, "familiarSVMEps"))) { - - if (outcome_type == "count") ..deprecation_count() + if (outcome_type %in% c("continuous") && + (is(object, "familiarSVMNu") || is(object, "familiarSVMEps")) + ) { return(TRUE) } else if ( outcome_type %in% c("binomial", "multinomial") && - (is(object, "familiarSVMNu") || is(object, "familiarSVMC"))) { + (is(object, "familiarSVMNu") || is(object, "familiarSVMC")) + ) { return(TRUE) + + } else if (outcome_type == "count") { + ..deprecation_count() + return(FALSE) } else { return(FALSE) @@ -110,61 +113,67 @@ setMethod( default = svm_kernel, type = "factor", range = svm_kernel, - randomise = FALSE) + randomise = FALSE + ) # constraints violation cost C --------------------------------------------- # This parameter defines the cost for constraint violations. It is expressed # on a log10 scale. param$c <- .set_hyperparameter( - default = c(-3, -1, -0, 1, 3), + default = c(-3.0, -1.0, -0.0, 1.0, 3.0), type = "numeric", - range = c(-5, 3), + range = c(-5.0, 3.0), valid_range = c(-Inf, Inf), - randomise = TRUE) + randomise = TRUE + ) # error tolerance epsilon -------------------------------------------------- if (is(object, "familiarSVMNu") || is(object, "familiarSVMEps")) { # This parameter defines the error tolerance for regression SVM. It is # expressed on a log10 scale. param$epsilon <- .set_hyperparameter( - default = c(-5, -3, -1, 0, 1), + default = c(-5.0, -3.0, -1.0, 0.0, 1.0), type = "numeric", - range = c(-5, 1), + range = c(-5.0, 1.0), valid_range = c(-Inf, Inf), - randomise = TRUE) + randomise = TRUE + ) } # error bounds parameter nu ------------------------------------------------ if (is(object, "familiarSVMNu")) { # nu is expressed on a log10 scale. param$nu <- .set_hyperparameter( - default = c(-5, -3, -1, 0, 1), + default = c(-5.0, -3.0, -1.0, 0.0, 1.0), type = "numeric", - range = c(-5, 1), + range = c(-5.0, 1.0), valid_range = c(-Inf, Inf), - randomise = TRUE) + randomise = TRUE + ) } # inverse kernel width gamma ----------------------------------------------- if (svm_kernel %in% c("radial", "polynomial", "sigmoid")) { # sigma is expressed on a log10 scale param$gamma <- .set_hyperparameter( - default = c(-7, -5, -3, -1, 1), + default = c(-7.0, -5.0, -3.0, -1.0, 1.0), type = "numeric", - range = c(-9, 3), + range = c(-9.0, 3.0), valid_range = c(-Inf, Inf), - randomise = TRUE) + randomise = TRUE + ) } # polynomial degree -------------------------------------------------------- if (svm_kernel %in% c("polynomial")) { param$degree <- .set_hyperparameter( - default = c(1, 2, 3, 4, 5), + default = c(1L, 2L, 3L, 4L, 5L), type = "integer", - range = c(1, 5), - valid_range = c(1, Inf), - randomise = TRUE) + range = c(1L, 5L), + valid_range = c(1L, Inf), + randomise = TRUE + ) } # kernel offset parameter -------------------------------------------------- @@ -175,9 +184,10 @@ setMethod( param$offset <- .set_hyperparameter( default = c(0.0, 0.2, 0.5, 1.0), type = "numeric", - range = c(0, 1), - valid_range = c(0, Inf), - randomise = TRUE) + range = c(0.0, 1.0), + valid_range = c(0.0, Inf), + randomise = TRUE + ) } return(param) @@ -191,20 +201,23 @@ setMethod( "..train", signature( object = "familiarSVM", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Check if training data is ok. if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -216,7 +229,8 @@ setMethod( # Parse the formula. formula <- stats::reformulate( termlabels = feature_columns, - response = quote(outcome)) + response = quote(outcome) + ) # Derive fitting parameters for fitting class probabilities. fit_probability <- object@outcome_type %in% c("binomial", "multinomial") @@ -224,16 +238,22 @@ setMethod( # Derive svm type from object if (is(object, "familiarSVMC")) { svm_type <- "C-classification" + } else if ( is(object, "familiarSVMNu") && - object@outcome_type %in% c("binomial", "multinomial")) { + object@outcome_type %in% c("binomial", "multinomial") + ) { svm_type <- "nu-classification" + } else if ( is(object, "familiarSVMNu") && - object@outcome_type %in% c("count", "continuous")) { + object@outcome_type %in% c("continuous") + ) { svm_type <- "nu-regression" + } else if (is(object, "familiarSVMEps")) { svm_type <- "eps-regression" + } else { ..error_reached_unreachable_code("..train,familiarSVM: can not set the type of SVM.") } @@ -241,20 +261,21 @@ setMethod( # Set svm-related parameters. svm_parameter_list <- list( "kernel" = as.character(object@hyperparameters$kernel), - "cost" = 10^(object@hyperparameters$c)) + "cost" = 10.0^(object@hyperparameters$c) + ) # Set nu-parameter (which not all svm types use). if (is(object, "familiarSVMNu")) { - svm_parameter_list$nu <- 10^(object@hyperparameters$nu) + svm_parameter_list$nu <- 10.0^(object@hyperparameters$nu) } # Set epsilon parameter (which not all svm types use). if (is(object, "familiarSVMNu") || is(object, "familiarSVMEps")) { - svm_parameter_list$epsilon <- 10^(object@hyperparameters$epsilon) + svm_parameter_list$epsilon <- 10.0^(object@hyperparameters$epsilon) } if (!is.null(object@hyperparameters$gamma)) { - svm_parameter_list$gamma <- 10^object@hyperparameters$gamma + svm_parameter_list$gamma <- 10.0^object@hyperparameters$gamma } if (!is.null(object@hyperparameters$degree)) { @@ -278,9 +299,12 @@ setMethod( "type" = svm_type, "probability" = fit_probability, "fitted" = FALSE, - "cross" = 0L), - svm_parameter_list)) - + "cross" = 0L + ), + svm_parameter_list + ) + ) + # Extract values. object <- ..update_warnings(object = object, model$warning) object <- ..update_errors(object = object, model$error) @@ -292,7 +316,8 @@ setMethod( if (is.null(model)) { return(callNextMethod(object = ..update_errors( object = object, - "SVM model returned as NULL."))) + "SVM model returned as NULL." + ))) } # Add model @@ -312,9 +337,10 @@ setMethod( "..train_naive", signature( object = "familiarSVM", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { - if (object@outcome_type %in% c("count", "continuous", "binomial", "multinomial")) { + if (object@outcome_type %in% c("continuous", "binomial", "multinomial")) { # Turn into a naive model. object <- methods::new("familiarNaiveModel", object) } @@ -322,7 +348,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -333,33 +360,35 @@ setMethod( "..predict", signature( object = "familiarSVM", - data = "dataObject"), - function(object, data, type = "default", ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) return(callNextMethod()) + + # Check if the data is empty. + if (is_empty(data)) return(callNextMethod()) + if (type == "default") { - # Default method --------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) return(callNextMethod()) - - # Check if the data is empty. - if (is_empty(data)) return(callNextMethod()) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = type) + # default ---------------------------------------------------------------- # Make predictions using the model. model_predictions <- tryCatch( predict( object = object@model, newdata = data@data, - probability = object@outcome_type %in% c("binomial", "multinomial")), - error = identity) + probability = object@outcome_type %in% c("binomial", "multinomial") + ), + error = identity + ) # Check if the model trained at all. if (inherits(model_predictions, "error")) return(callNextMethod()) @@ -372,41 +401,51 @@ setMethod( # Obtain class levels from the object. class_levels <- get_outcome_class_levels(x = object) - - # Add class probabilities to the prediction table. - class_probability_columns <- get_class_probability_name(x = object) - for (ii in seq_along(class_probability_columns)) { + prediction_list <- list() + for (ii in seq_along(class_levels)) { if (is.matrix(model_predictions)) { - # Check if model_predictions is a matrix. - prediction_table[, (class_probability_columns[ii]) := model_predictions[, class_levels[ii]]] + prediction_list[[class_levels[ii]]] <- model_predictions[, class_levels[ii]] } else { - # Or not. - prediction_table[, (class_probability_columns[ii]) := model_predictions[class_levels[ii]]] + prediction_list[[class_levels[ii]]] <- model_predictions[class_levels[ii]] } } - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[ - apply(prediction_table[, mget(class_probability_columns)], 1, which.max)] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) - class_predictions <- factor( - x = class_predictions, - levels = class_levels) - - prediction_table[, "predicted_class" := class_predictions] - - } else if (object@outcome_type %in% c("continuous", "count")) { + } else if (object@outcome_type %in% c("continuous")) { # numerical outcomes --------------------------------------------------- - # Extract predicted regression values. - prediction_table[, "predicted_outcome" := model_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "regression", + data = data, + model_object = object + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) } return(prediction_table) + + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- + return(predict( + object = object@model, + newdata = data@data, + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } } ) @@ -471,10 +510,14 @@ setMethod( svm_kernels <- ..get_available_svm_kernels() # Find matches with end of learner string. - kernel_matches <- sapply(svm_kernels, function(suffix, x) (endsWith(x = x, suffix = suffix)), x = learner) + kernel_matches <- sapply( + svm_kernels, + function(suffix, x) (endsWith(x = x, suffix = suffix)), + x = learner + ) # If all are missing (e.g. "svm_eps), use default RBF kernel. - if (all(!kernel_matches)) { + if (!any(kernel_matches)) { return("radial") } diff --git a/R/LearnerS4SurvivalRegression.R b/R/LearnerS4SurvivalRegression.R index a5b28acb..79c81719 100644 --- a/R/LearnerS4SurvivalRegression.R +++ b/R/LearnerS4SurvivalRegression.R @@ -7,7 +7,8 @@ setClass( "familiarSurvRegr", contains = "familiarModel", slots = list("encoding_reference_table" = "ANY"), - prototype = list("encoding_reference_table" = NULL)) + prototype = list("encoding_reference_table" = NULL) +) # initialize ------------------------------------------------------------------- setMethod( @@ -54,21 +55,24 @@ setMethod( # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size( data = data, - restrict_samples = TRUE) + restrict_samples = TRUE + ) # outcome distribution ----------------------------------------------------- # Randomisation of distribution depends on selected learner. if (object@learner == "survival_regr") { distribution_default <- c( - "weibull", "exponential", "gaussian", "logistic", "loglogistic", "lognormal") + "weibull", "exponential", "gaussian", "logistic", "loglogistic", "lognormal" + ) } else { distribution_default <- sub( x = object@learner, pattern = "survival_regr_", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } # Set the distribution parameter @@ -76,7 +80,8 @@ setMethod( default = distribution_default, type = "factor", range = distribution_default, - randomise = ifelse(length(distribution_default) > 1, TRUE, FALSE)) + randomise = length(distribution_default) > 1L + ) # Return hyper-parameters return(param) @@ -97,7 +102,8 @@ setMethod( return("survival_probability") } else { ..error_reached_unreachable_code( - "get_prediction_type,familiarSurvRegr: unknown type") + "get_prediction_type,familiarSurvRegr: unknown type" + ) } } ) @@ -109,20 +115,23 @@ setMethod( "..train", signature( object = "familiarSurvRegr", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Check if training data is ok. if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -135,7 +144,8 @@ setMethod( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Find feature columns in the data. feature_columns <- get_feature_columns(x = encoded_data$encoded_data) @@ -148,7 +158,7 @@ setMethod( # Set limits to the number of iterations that can be performed by # survival regression. - model_control <- survival::survreg.control(iter.max = 100) + model_control <- survival::survreg.control(iter.max = 100L) # Train the model. model <- do.call_with_handlers( @@ -157,7 +167,9 @@ setMethod( "data" = encoded_data$encoded_data@data, "control" = model_control, "y" = FALSE, - "dist" = as.character(object@hyperparameters$distribution))) + "dist" = as.character(object@hyperparameters$distribution) + ) + ) # Extract values. object <- ..update_warnings(object = object, model$warning) @@ -168,10 +180,11 @@ setMethod( if (!is.null(object@messages$error)) return(callNextMethod(object = object)) # Check if the model fitter converged in time. - if (model$iter >= 100) { + if (model$iter >= 100L) { return(callNextMethod(object = ..update_errors( object = object, - "Model fitter ran out of iterations and did not converge."))) + "Model fitter ran out of iterations and did not converge." + ))) } # Check if all coefficients could not be estimated. Sometimes models could @@ -180,10 +193,11 @@ setMethod( # selected during hyperparameter optimisation, especially in situations # where there is not a lot of signal. Checking for non-finite coefficients # is an easy way to figure out if the model is not properly trained. - if (any(!sapply(stats::coef(model), is.finite))) { + if (!all(sapply(stats::coef(model), is.finite))) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_failed_model_coefficient_estimation()))) + ..error_message_failed_model_coefficient_estimation() + ))) } # Add model @@ -206,7 +220,8 @@ setMethod( "..train_naive", signature( object = "familiarSurvRegr", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Turn into a Naive model. object <- methods::new("familiarNaiveSurvivalTimeModel", object) @@ -214,7 +229,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -225,32 +241,34 @@ setMethod( "..predict", signature( object = "familiarSurvRegr", - data = "dataObject"), - function(object, data, type = "default", time = NULL, ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) return(callNextMethod()) + + # Check if the data is empty. + if (is_empty(data)) return(callNextMethod()) + + # Encode data so that the features are the same as in the training. + encoded_data <- encode_categorical_variables( + data = data, + object = object, + encoding_method = "dummy", + drop_levels = FALSE + ) + if (type %in% c("default", "survival_probability")) { - # Default method --------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) return(callNextMethod()) - - # Check if the data is empty. - if (is_empty(data)) return(callNextMethod()) - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = encoded_data$encoded_data, - type = type) + # default ---------------------------------------------------------------- if (object@outcome_type == "survival") { if (type == "default") { @@ -258,15 +276,24 @@ setMethod( model_predictions <- predict( object = object@model, newdata = encoded_data$encoded_data@data, - type = "response") - - # Update the prediction table. - prediction_table[, "predicted_outcome" := model_predictions] + type = "response" + ) + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "expected_survival_time", + data = data, + model_object = object + ) } else if (type == "survival_probability") { # To predict survival probability we first compute survival quantiles, # which are survival probabilities. + # If time is unset, read the max time stored by the model. + if (is.null(time)) time <- object@settings$time_max + # Survival quantiles from 1.00 to 0.01 survival_quantiles <- seq(from = 1.00, to = 0.01, by = -0.01) @@ -275,8 +302,9 @@ setMethod( object = object@model, newdata = encoded_data$encoded_data@data, type = "quantile", - p = 1.00 - survival_quantiles) - + p = 1.00 - survival_quantiles + ) + # Set id columns id_columns <- get_id_columns() @@ -284,13 +312,15 @@ setMethod( if (!is.matrix(failure_matrix)) { failure_matrix <- matrix( data = failure_matrix, - ncol = length(failure_matrix)) + ncol = length(failure_matrix) + ) } # Combine with identifiers and cast to table. failure_table <- cbind( - prediction_table[, mget(id_columns)], - data.table::as.data.table(failure_matrix)) + data@data[, mget(id_columns)], + data.table::as.data.table(failure_matrix) + ) # Remove duplicate entries failure_table <- unique(failure_table, by = id_columns) @@ -300,19 +330,22 @@ setMethod( failure_table, id.vars = id_columns, variable.name = "quantile_variable", - value.name = "survival_time") + value.name = "survival_time" + ) # Create conversion table to convert temporary variables into # the event times. conversion_table <- data.table::data.table( "quantile_variable" = paste0("V", seq_along(survival_quantiles)), - "survival_quantile" = survival_quantiles) + "survival_quantile" = survival_quantiles + ) # Add in failure_table <- merge( x = failure_table, y = conversion_table, - on = "quantile_variable") + by = "quantile_variable" + ) # Drop the time_variable column failure_table[, "quantile_variable" := NULL] @@ -326,29 +359,38 @@ setMethod( x = sample_table$survival_time, y = sample_table$survival_quantile, xout = time, - rule = 2 + rule = 2L )$y # Create an output table - output_table <- data.table::copy(sample_table[1, mget(id_columns)]) + output_table <- data.table::copy(sample_table[1L, mget(id_columns)]) output_table[, "survival_probability" := value] return(output_table) }, time = time, - id_columns = id_columns) + id_columns = id_columns + ) # Concatenate to single table. failure_table <- data.table::rbindlist(failure_table) - # Remove survival_probability from the prediction table. - prediction_table[, "survival_probability" := NULL] - # Then merge the event table into the prediction table. prediction_table <- merge( - x = prediction_table, + x = data@data[, mget(id_columns)], y = failure_table, - by = id_columns) + by = id_columns, + sort = FALSE + ) + + # Store as prediction table + prediction_table <- as_prediction_table( + x = prediction_table$survival_probability, + type = "survival_probability", + data = data, + time = time, + model_object = object + ) } } else { @@ -357,56 +399,38 @@ setMethod( return(prediction_table) - } else { - # User-specified method -------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) return(NULL) - - # Check if the data is empty. - if (is_empty(data)) return(NULL) - - # Encode data so that the features are the same as in the - # training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- # Use the model to predict expected survival time. return(predict( object = object@model, newdata = encoded_data$encoded_data@data, type = type, - ...)) + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } } ) -# ..predict_survival_probability ----------------------------------------------- +# ..get_prediction_table_type -------------------------------------------------- setMethod( - "..predict_survival_probability", - signature( - object = "familiarSurvRegr", - data = "dataObject"), - function(object, data, time, ...) { + "..get_prediction_table_type", + signature(object = "familiarSurvRegr"), + function(object, type, ...) { + prediction_table_type <- NULL + if (object@outcome_type %in% c("survival") && type == "default") { + prediction_table_type <- "expected_survival_time" + } else { + prediction_table_type <- callNextMethod() + } - if (!object@outcome_type %in% c("survival")) return(callNextMethod()) - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - return(..predict( - object = object, - data = data, - time = time, - type = "survival_probability")) + return(prediction_table_type) } ) @@ -428,20 +452,23 @@ setMethod( # Define p-values coefficient_z_values <- tryCatch( .compute_z_statistic(object), - error = identity) + error = identity + ) if (inherits(coefficient_z_values, "error")) return(callNextMethod()) # Remove any intercept from the data. coefficient_z_values <- coefficient_z_values[ - names(coefficient_z_values) != "(Intercept)"] + names(coefficient_z_values) != "(Intercept)" + ] - if (length(coefficient_z_values) == 0) return(callNextMethod()) + if (length(coefficient_z_values) == 0L) return(callNextMethod()) # Assign to variable importance table. vimp_table <- data.table::data.table( "score" = coefficient_z_values, - "name" = names(coefficient_z_values)) + "name" = names(coefficient_z_values) + ) # Remove NA values vimp_table <- vimp_table[is.finite(score)] @@ -452,7 +479,8 @@ setMethod( vimp_table = vimp_table, encoding_table = object@encoding_reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } diff --git a/R/LearnerS4XGBoost.R b/R/LearnerS4XGBoost.R index 3d55a091..500daf36 100644 --- a/R/LearnerS4XGBoost.R +++ b/R/LearnerS4XGBoost.R @@ -8,16 +8,13 @@ setClass( contains = "familiarModel", slots = list( "encoding_reference_table" = "ANY", - "outcome_table" = "ANY", - "outcome_shift" = "numeric", - "outcome_scale" = "numeric", - "feature_order" = "character"), + "feature_order" = "character" + ), prototype = list( "encoding_reference_table" = NULL, - "outcome_table" = NULL, - "outcome_shift" = 0.0, - "outcome_scale" = 1.0, - "feature_order" = character())) + "feature_order" = character() + ) +) setClass("familiarXGBoostLM", contains = "familiarXGBoost") setClass("familiarXGBoostTree", contains = "familiarXGBoost") @@ -55,42 +52,36 @@ setMethod( x = object@learner, pattern = c("xgboost_lm", "xgboost_tree", "xgboost_dart"), replacement = "", - fixed = TRUE) + fixed = TRUE + ) if (startsWith(learner, "_")) { learner <- sub( x = learner, pattern = "_", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } if ( outcome_type == "continuous" && - learner %in% c("", "logistic", "gaussian", "gamma")) { + learner %in% c("", "gaussian", "gamma", "poisson") + ) { return(TRUE) - } else if ( - outcome_type == "multinomial" && - learner %in% c("", "logistic")) { + } else if (outcome_type == "multinomial" && learner %in% c("", "logistic")) { return(TRUE) - } else if ( - outcome_type == "binomial" && - learner %in% c("", "logistic")) { + } else if (outcome_type == "binomial" && learner %in% c("", "logistic")) { return(TRUE) - } else if ( - outcome_type == "survival" && - learner %in% c("", "cox")) { + } else if (outcome_type == "survival" && learner %in% c("", "cox")) { return(TRUE) - } else if ( - outcome_type == "count" && - learner %in% c("", "poisson", "gaussian")) { + } else if (outcome_type == "count" && learner %in% c("", "poisson", "gaussian")) { ..deprecation_count() - return(TRUE) - + return(FALSE) } return(FALSE) @@ -103,7 +94,12 @@ setMethod( setMethod( "get_default_hyperparameters", signature(object = "familiarXGBoost"), - function(object, data = NULL, user_list = NULL, ...) { + function( + object, + data = NULL, + user_list = NULL, + ... + ) { # Initialise list and declare hyperparameter entries param <- list() param$sign_size <- list() @@ -139,9 +135,7 @@ setMethod( outcome_type <- object@outcome_type # Determine number of samples. - n_samples <- data.table::uniqueN( - data@data, - by = get_id_columns(id_depth = "series")) + n_samples <- get_n_samples(data) # signature size ----------------------------------------------------------- param$sign_size <- .get_default_sign_size(data = data) @@ -155,27 +149,30 @@ setMethod( x = object@learner, pattern = c("xgboost_lm", "xgboost_tree", "xgboost_dart"), replacement = "", - fixed = TRUE) + fixed = TRUE + ) if (fam != "") { fam <- sub( x = fam, pattern = "_", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } # Define the objective based on the name of the learner. if (fam == "") { # No specific objective is provided. if (outcome_type == "continuous") { - learn_objective_default <- c("gaussian", "continuous_logistic", "gamma") - } else if (outcome_type == "count") { - learn_objective_default <- c("gaussian", "poisson") + learn_objective_default <- c("gaussian", "gamma") + } else if (outcome_type == "binomial") { learn_objective_default <- "binomial_logistic" + } else if (outcome_type == "multinomial") { learn_objective_default <- "multinomial_logistic" + } else if (outcome_type == "survival") { learn_objective_default <- "cox" } @@ -185,10 +182,9 @@ setMethod( # defined according to the type of outcome. if (outcome_type == "binomial") { learn_objective_default <- "binomial_logistic" + } else if (outcome_type == "multinomial") { learn_objective_default <- "multinomial_logistic" - } else if (outcome_type == "continuous") { - learn_objective_default <- "continuous_logistic" } } else { @@ -201,18 +197,20 @@ setMethod( default = learn_objective_default, type = "factor", range = learn_objective_default, - randomise = length(learn_objective_default) > 1) + randomise = length(learn_objective_default) > 1L + ) # number of boosting iterations -------------------------------------------- # This hyper-parameter is expressed on the log 10 scale. It is called # nrounds in xgboost. param$n_boost <- .set_hyperparameter( - default = c(0, 1, 2, 3), + default = c(0.0, 1.0, 2.0, 3.0), type = "numeric", - range = c(0, 3), - valid_range = c(0, Inf), - randomise = TRUE) + range = c(0.0, 3.0), + valid_range = c(0.0, Inf), + randomise = TRUE + ) # learning rate ------------------------------------------------------------ @@ -221,33 +219,36 @@ setMethod( # lead to better models, but take longer to learn. This parameter is called # eta by xgboost. param$learning_rate <- .set_hyperparameter( - default = c(-3, -2, -1), + default = c(-3.0, -2.0, -1.0), type = "numeric", - range = c(-5, 0), - valid_range = c(-Inf, 0), - randomise = TRUE) + range = c(-5.0, 0.0), + valid_range = c(-Inf, 0.0), + randomise = TRUE + ) # L2 regularisation term --------------------------------------------------- # The L2 regularisation term lambda lies in the half-open range [0, inf). # This term is implemented as a power(10) with a 10^-6 offset. param$lambda <- .set_hyperparameter( - default = c(-6, -3, -1, 1, 3), + default = c(-6.0, -3.0, -1.0, 1.0, 3.0), type = "numeric", - range = c(-6, 3), - valid_range = c(-6, Inf), - randomise = TRUE) + range = c(-6.0, 3.0), + valid_range = c(-6.0, Inf), + randomise = TRUE + ) # L1 regularisation term --------------------------------------------------- # The L1 regularisation term alpha is implemented as the L2 regularisation # term. param$alpha <- .set_hyperparameter( - default = c(-6, -3, -1, 1, 3), + default = c(-6.0, -3.0, -1.0, 1.0, 3.0), type = "numeric", - range = c(-6, 3), - valid_range = c(-6, Inf), - randomise = TRUE) + range = c(-6.0, 3.0), + valid_range = c(-6.0, Inf), + randomise = TRUE + ) # sample weighting method -------------------------------------------------- @@ -262,8 +263,10 @@ setMethod( param$sample_weighting_beta <- .get_default_sample_weighting_beta( method = c( param$sample_weighting$init_config, - user_list$sample_weighting), - outcome_type = object@outcome_type) + user_list$sample_weighting + ), + outcome_type = object@outcome_type + ) # Parameters for tree-based gradient boosting if (is(object, "familiarXGBoostTree") || is(object, "familiarXGBoostDart")) { @@ -272,11 +275,12 @@ setMethod( # This hyperparameter is only used by tree models. The parameter is called # max_depth by xgboost. Larger depths increase the risk of overfitting. param$tree_depth <- .set_hyperparameter( - default = c(1, 2, 3, 7), + default = c(1L, 2L, 3L, 7L), type = "integer", - range = c(1, 10), - valid_range = c(1, Inf), - randomise = TRUE) + range = c(1L, 10L), + valid_range = c(1L, Inf), + randomise = TRUE + ) # data subsampling fraction ---------------------------------------------- @@ -285,9 +289,10 @@ setMethod( param$sample_size <- .set_hyperparameter( default = c(0.30, 0.50, 0.70, 1.00), type = "numeric", - range = c(2 / n_samples, 1.0), - valid_range = c(0, 1), - randomise = TRUE) + range = c(2.0 / n_samples, 1.0), + valid_range = c(0.0, 1.0), + randomise = TRUE + ) # minimum sum of instance weight ----------------------------------------- @@ -301,11 +306,12 @@ setMethod( # # We implement this on a power(10) scale, with -1 offset. param$min_child_weight <- .set_hyperparameter( - default = c(0, 1, 2), + default = c(0.0, 1.0, 2.0), type = "numeric", - range = c(0, 2), - valid_range = c(0, Inf), - randomise = TRUE) + range = c(0.0, 2.0), + valid_range = c(0.0, Inf), + randomise = TRUE + ) # minimum splitting error reduction -------------------------------------- @@ -313,15 +319,16 @@ setMethod( # called gamma or min_split_loss in xgboost. We implement it on the # power(10) scale, with 10^-6 offset. # - # For continuous and count-type outcomes, this parameter can be a bit - # tricky due to a wide range in possible scales, and thus in error values. - # This is resolved by normalising the outcome to the [0, 1] range. + # For continuous type outcomes, this parameter can be a bit tricky due to + # a wide range in possible scales, and thus in error values. This is + # resolved by normalising the outcome to the [0, 1] range. param$gamma <- .set_hyperparameter( - default = c(-6, -3, -1, 1, 3), + default = c(-6.0, -3.0, -1.0, 1.0, 3.0), type = "numeric", - range = c(-6, 3), - valid_range = c(-6, Inf), - randomise = TRUE) + range = c(-6.0, 3.0), + valid_range = c(-6.0, Inf), + randomise = TRUE + ) } # Parameters for dart tree-based gradient boosting @@ -333,16 +340,18 @@ setMethod( default = c("uniform", "weighted"), type = "factor", range = c("uniform", "weighted"), - randomise = TRUE) + randomise = TRUE + ) ## dart booster tree drop rate -------------------------------------------- # Fraction of previous trees to drop during dropout. param$rate_drop <- .set_hyperparameter( - default = c(0, 0.1, 0.3), + default = c(0.0, 0.1, 0.3), type = "numeric", - range = c(0, 1), - randomise = TRUE) + range = c(0.0, 1.0), + randomise = TRUE + ) } # Return hyper-parameters @@ -362,14 +371,19 @@ setMethod( # The prediction type is a bit more complicated for xgboost methods. if (type == "default") { - return("hazard_ratio") + if (as.character(object@hyperparameters$learn_objective %in% c("cox"))) { + return("hazard_ratio") + } + } else if (type == "survival_probability") { return("survival_probability") + } else { ..error_reached_unreachable_code(paste0( "get_prediction_type,familiarXGBoost: unknown type (", type, ") for the current objective (", - as.character(object@hyperparameters$learn_objective), ").")) + as.character(object@hyperparameters$learn_objective), ")." + )) } } ) @@ -381,7 +395,8 @@ setMethod( "..train", signature( object = "familiarXGBoost", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Suppress NOTES due to non-standard evaluation in data.table outcome <- NULL @@ -394,14 +409,16 @@ setMethod( if (reason <- has_bad_training_data(object = object, data = data)) { return(callNextMethod(object = .why_bad_training_data( object = object, - reason = reason))) + reason = reason + ))) } # Check if hyperparameters are set. if (is.null(object@hyperparameters)) { return(callNextMethod(object = ..update_errors( object = object, - ..error_message_no_optimised_hyperparameters_available()))) + ..error_message_no_optimised_hyperparameters_available() + ))) } # Check that required packages are loaded and installed. @@ -414,7 +431,8 @@ setMethod( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Find feature columns in the data. feature_columns <- get_feature_columns(x = encoded_data$encoded_data) @@ -422,58 +440,15 @@ setMethod( # Find outcome columns in data table. outcome_columns <- get_outcome_columns(x = object) - # Build a xgb data matrix - if (object@outcome_type %in% c("binomial", "multinomial")) { - # Convert categorical outcomes to numerical labels expected by - # xgboost. - class_levels <- get_outcome_class_levels(x = object) - class_num_labels <- as.numeric(seq_along(class_levels) - 1) - class_conversion_table <- data.table::data.table( - "class_level" = factor(class_levels, levels = class_levels), - "num_label" = class_num_labels) - - # Convert categorical outcomes by adding numerical labels to the outcome - # data. - outcome_data <- data.table::copy( - encoded_data$encoded_data@data[, mget(outcome_columns)]) - - for (ii in seq_along(class_levels)) { - outcome_data[ - outcome == class_conversion_table$class_level[ii], - "outcome_label" := class_conversion_table$num_label[ii]] - } - - # Save conversion table to model_list - object@outcome_table <- class_conversion_table - - # Set outcome_labels - outcome_labels <- outcome_data$outcome_label - - } else if (object@outcome_type %in% c("continuous", "count")) { - # Set outcome_labels - outcome_labels <- encoded_data$encoded_data@data[[outcome_columns[1]]] - - # # Determine normalisation parameters so that outcome can be # normalised - # to [0, 1] range (for logistic regression). - if (as.character(object@hyperparameters$learn_objective) == "continuous_logistic") { - object@outcome_shift <- min(outcome_labels) - object@outcome_scale <- max(outcome_labels) - min(outcome_labels) - - # Normalise outcome labels. - outcome_labels <- (outcome_labels - object@outcome_shift) / object@outcome_scale - } + # Set y (response variable) + if (object@outcome_type %in% c("binomial", "multinomial", "continuous")) { + y <- encoded_data$encoded_data@data[[outcome_columns]] } else if (object@outcome_type == "survival") { - # According to the xgboost documentation, right censored survival time - # should be represented by negative values. - outcome_labels <- encoded_data$encoded_data@data[[outcome_columns[1]]] - - # Identify right-censored entries - right_censored <- encoded_data$encoded_data@data[[outcome_columns[2]]] == 0 - - # Parse right-censored entries in outcome_labels to the correct - # representation. - outcome_labels[right_censored] <- outcome_labels[right_censored] * -1.0 + y <- survival::Surv( + encoded_data$encoded_data@data[[outcome_columns[1L]]], + encoded_data$encoded_data@data[[outcome_columns[2L]]] + ) } # Set weights. @@ -481,17 +456,13 @@ setMethod( data = encoded_data$encoded_data, method = object@hyperparameters$sample_weighting, beta = ..compute_effective_number_of_samples_beta( - object@hyperparameters$sample_weighting_beta), - normalisation = "average_one") - - # Create a data_matrix object - data_matrix <- xgboost::xgb.DMatrix( - data = as.matrix(encoded_data$encoded_data@data[, mget(feature_columns)]), - label = outcome_labels) + object@hyperparameters$sample_weighting_beta + ), + normalisation = "average_one" + ) - # Set the number of classes for the multi:softmax objective - n_classes <- 1 - if (object@outcome_type == "multinomial") n_classes <- length(class_levels) + # Create data object + x <- encoded_data$encoded_data@data[, mget(feature_columns)] # Identify the booster to use. if (is(object, "familiarXGBoostLM")) { @@ -503,46 +474,52 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "..train,familiarXGBoost: could not set booster for object of unknown class: ", - paste_s(class(object)))) + paste_s(class(object)) + )) } # Select shared arguments. learner_arguments <- list( - "params" = list( - "booster" = booster, - "nthread" = 1L, - "eta" = 10^object@hyperparameters$learning_rate, - "lambda" = 10^object@hyperparameters$lambda - 10^-6, - "alpha" = 10^object@hyperparameters$alpha - 10^-6, - "objective" = ..get_distribution_family(object), - "num_class" = n_classes), - "data" = data_matrix, + "booster" = booster, + "nthreads" = 1L, + "learning_rate" = 10.0^object@hyperparameters$learning_rate, + "reg_lambda" = 10.0^object@hyperparameters$lambda - 10.0^-6.0, + "reg_alpha" = 10.0^object@hyperparameters$alpha - 10.0^-6.0, + "objective" = ..get_distribution_family(object), + "x" = x, + "y" = y, "weight" = weights, - "nrounds" = round(10^object@hyperparameters$n_boost), - "verbose" = 0) + "nrounds" = round(10.0^object@hyperparameters$n_boost), + "verbosity" = 0L + ) if (is(object, "familiarXGBoostTree") || is(object, "familiarXGBoostDart")) { - learner_arguments$params <- c( - learner_arguments$params, + learner_arguments <- c( + learner_arguments, list( "max_depth" = object@hyperparameters$tree_depth, "subsample" = object@hyperparameters$sample_size, - "min_child_weight" = 10^object@hyperparameters$min_child_weight - 1.0, - "gamma" = 10^object@hyperparameters$gamma - 10^-6)) + "min_child_weight" = 10.0^object@hyperparameters$min_child_weight - 1.0, + "min_split_loss" = 10.0^object@hyperparameters$gamma - 10.0^-6.0 + ) + ) } if (is(object, "familiarXGBoostDart")) { - learner_arguments$params <- c( - learner_arguments$params, + learner_arguments <- c( + learner_arguments, list( "sample_type" = as.character(object@hyperparameters$sample_type), - "rate_drop" = object@hyperparameters$rate_drop)) + "rate_drop" = object@hyperparameters$rate_drop + ) + ) } # Train the model. model <- do.call_with_handlers( xgboost::xgboost, - args = learner_arguments) + args = learner_arguments + ) # Extract values. object <- ..update_warnings(object = object, model$warning) @@ -576,9 +553,10 @@ setMethod( "..train_naive", signature( object = "familiarXGBoost", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { - if (object@outcome_type %in% c("count", "continuous", "binomial", "multinomial")) { + if (object@outcome_type %in% c("continuous", "binomial", "multinomial")) { # Turn into a Naive model. object <- methods::new("familiarNaiveModel", object) @@ -590,7 +568,8 @@ setMethod( return(..train( object = object, data = data, - ...)) + ... + )) } ) @@ -601,189 +580,166 @@ setMethod( "..predict", signature( object = "familiarXGBoost", - data = "dataObject"), - function(object, data, type = "default", ...) { + data = "dataObject" + ), + function( + object, + data, + type = "default", + time = NULL, + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") + # Check if the model was trained. + if (!model_is_trained(object)) return(callNextMethod()) + + # Check if the data is empty. + if (is_empty(data)) return(callNextMethod()) + + # Load model through unserialisation. + if (inherits(object@model, "raw")) { + object@model <- xgboost::xgb.load.raw(object@model) + } + + # Encode data so that the features are the same as in the training. + encoded_data <- encode_categorical_variables( + data = data, + object = object, + encoding_method = "dummy", + drop_levels = FALSE + ) + if (type == "default") { - # Default method --------------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) return(callNextMethod()) - - # Check if the data is empty. - if (is_empty(data)) return(callNextMethod()) - - # Load model through unserialisation. - if (inherits(object@model, "raw")) { - object@model <- xgboost::xgb.load.raw(object@model) - } - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, - object = object, - encoding_method = "dummy", - drop_levels = FALSE) - - # Get an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = encoded_data$encoded_data, - type = type) - - # Make predictions. If the booster object is DART type, predict() will - # perform dropouts, i.e. only some of the trees will be evaluated. This - # will produce incorrect results if data is not the training data. To - # obtain correct results on test sets, set ntree_limit to a nonzero value, - # e.g. preds = bst.predict(dtest, ntree_limit=num_round) [from the - # documentation]. - # - # Also note that for cox regression, the predictions are recalibrated - # based on the linear predictor / marginal prediction. - if (utils::packageVersion("xgboost") < "1.4.0") { - model_predictions <- predict( - object = object@model, - newdata = as.matrix(encoded_data$encoded_data@data[, mget(object@feature_order)]), - outputmargin = object@outcome_type == "survival", - ntreelimit = round(10^object@hyperparameters$n_boost), - reshape = TRUE) - - } else { - # From version 1.4 onward, ntreelimit was deprecated, and - # replaced by iterationrange. - model_predictions <- predict( - object = object@model, - newdata = as.matrix(encoded_data$encoded_data@data[, mget(object@feature_order)]), - outputmargin = object@outcome_type == "survival", - iterationrange = c(1, round(10^object@hyperparameters$n_boost)), - reshape = TRUE) - } + # default ---------------------------------------------------------------- + model_predictions <- predict( + object = object@model, + newdata = as.matrix(encoded_data$encoded_data@data[, mget(object@feature_order)]) + ) + if (object@outcome_type == "binomial") { # binomial outcomes ---------------------------------------------------- - + # Obtain class levels. class_levels <- get_outcome_class_levels(x = object) # Add class probabilities (glm always gives probability for the second # class). - class_probability_columns <- get_class_probability_name(x = object) - prediction_table[, (class_probability_columns[1]) := 1.0 - model_predictions] - prediction_table[, (class_probability_columns[2]) := model_predictions] - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[ - apply(prediction_table[, mget(class_probability_columns)], 1, which.max)] + prediction_list <- list() + prediction_list[[tail(class_levels, n = 1L)]] <- model_predictions - class_predictions <- factor( - x = class_predictions, - levels = class_levels) - - prediction_table[, "predicted_class" := class_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) } else if (object@outcome_type == "multinomial") { # multinomial outcomes ------------------------------------------------- - + # Obtain class levels. class_levels <- get_outcome_class_levels(x = object) - # Add class probabilities. - class_probability_columns <- get_class_probability_name(x = object) - for (ii in seq_along(class_probability_columns)) { + prediction_list <- list() + for (ii in seq_along(class_levels)) { if (is.matrix(model_predictions)) { - # Check if model_predictions is a matrix. - prediction_table[, (class_probability_columns[ii]) := model_predictions[, ii]] + prediction_list[[class_levels[ii]]] <- model_predictions[, ii] + } else { - # Or not. - prediction_table[, (class_probability_columns[ii]) := model_predictions[ii]] + prediction_list[[class_levels[ii]]] <- model_predictions[ii] } } - - # Update predicted class based on provided probabilities. - class_predictions <- class_levels[ - apply(prediction_table[, mget(class_probability_columns)], 1, which.max)] - - class_predictions <- factor( - x = class_predictions, - levels = class_levels) - prediction_table[, "predicted_class" := class_predictions] + # Store as prediction table. + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) - } else if (object@outcome_type %in% c("continuous", "count")) { + } else if (object@outcome_type %in% c("continuous")) { # Numerical outcomes --------------------------------------------------- # Map predictions back to original scale. - model_predictions <- model_predictions * object@outcome_scale + object@outcome_shift - - # Extract predicted regression values. - prediction_table[, "predicted_outcome" := model_predictions] + model_predictions <- model_predictions + + # Store as prediction table. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "regression", + data = data, + model_object = object + ) } else if (object@outcome_type %in% c("survival")) { # Survival outcomes ---------------------------------------------------- - - # Add predictions to the prediction table. - prediction_table[, "predicted_outcome" := model_predictions] + + # Store as prediction table. Note that the raw prediction output needs + # to be recalibrated. + prediction_table <- as_prediction_table( + x = model_predictions, + type = "survival", + data = data, + model_object = object + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) } return(prediction_table) + + } else if (type == "survival_probability" && object@outcome_type == "survival") { - } else { - # User-specified method -------------------------------------------------- - - # Check if the model was trained. - if (!model_is_trained(object)) return(NULL) - - # Check if the data is empty. - if (is_empty(data)) return(NULL) - - # Encode data so that the features are the same as in the training. - encoded_data <- encode_categorical_variables( - data = data, + # Only compute for cox-like objectives. + if (!as.character(object@hyperparameters$learn_objective) %in% c("cox")) { + return(callNextMethod()) + } + + # If time is unset, read the max time stored by the model. + if (is.null(time)) time <- object@settings$time_max + + return(.survival_probability_relative_risk( object = object, - encoding_method = "dummy", - drop_levels = FALSE) + data = data, + time = time + )) + + } else if (!.is_available_prediction_type(type)) { + # user-specified method -------------------------------------------------- # Note that xgboost:::predict.xgb.Booster does not have a type argument. return(predict( object = object@model, - newdata = as.matrix(encoded_data$encoded_data@data[, mget(object@feature_order)]), - ...)) + newdata = encoded_data$encoded_data@data[, mget(object@feature_order)], + ... + )) + + } else { + ..error_no_predictions_possible(object, type) } } ) - -# ..predict_survival_probability ----------------------------------------------- +# ..get_prediction_table_type -------------------------------------------------- setMethod( - "..predict_survival_probability", - signature( - object = "familiarXGBoost", - data = "dataObject"), - function(object, data, time, ...) { - # Only predict survival probability for survival outcomes. - if (!object@outcome_type %in% c("survival")) return(callNextMethod()) - - # We can only predict probability for Cox. - if (!as.character(object@hyperparameters$learn_objective) %in% c("cox")) { - return(callNextMethod()) + "..get_prediction_table_type", + signature(object = "familiarXGBoost"), + function(object, type, ...) { + prediction_table_type <- NULL + if (object@outcome_type %in% c("survival") && type == "default") { + prediction_table_type <- "survival" + } else { + prediction_table_type <- callNextMethod() } - - # If time is unset, read the max time stored by the model. - if (is.null(time)) time <- object@settings$time_max - - # Check that required packages are loaded and installed. - require_package(object, "predict") - - return(.survival_probability_relative_risk( - object = object, - data = data, - time = time)) + + return(prediction_table_type) } ) @@ -813,7 +769,8 @@ setMethod( # data.table. xgboost_score <- tryCatch( xgboost::xgb.importance(model = object@model), - error = identity) + error = identity + ) if (inherits(xgboost_score, "error")) return(callNextMethod()) @@ -821,7 +778,9 @@ setMethod( # Process to variable importance table. vimp_table <- data.table::data.table( "score" = xgboost_score$Gain, - "name" = xgboost_score$Feature) + "name" = xgboost_score$Feature + ) + } else if (is(object, "familiarXGBoostLM")) { # Output are linear coefficients, which may be negative. We keep # the maximum weight of each feature. @@ -830,12 +789,14 @@ setMethod( # Parse score to data.table vimp_table <- data.table::data.table( "score" = xgboost_score$Weight, - "name" = xgboost_score$Feature) + "name" = xgboost_score$Feature + ) } else { ..error_reached_unreachable_code(paste0( "..vimp,familiarXGBoost: could not process vimp for object of unknown class: ", - paste_s(class(object)))) + paste_s(class(object)) + )) } # Create variable importance object. @@ -843,7 +804,8 @@ setMethod( vimp_table = vimp_table, encoding_table = object@encoding_reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } @@ -885,14 +847,13 @@ setMethod( if (!is.character(objective) && !is.factor(objective)) { ..error_reached_unreachable_code(paste0( "..get_distribution_family,familiarXGBoost: learn_objective ", - "hyperparameter was not set.")) + "hyperparameter was not set." + )) } # Load objective for extreme gradient boosting. if (objective == "gaussian") { boost_objective <- "reg:squarederror" - } else if (objective == "continuous_logistic") { - boost_objective <- "reg:logistic" } else if (objective == "multinomial_logistic") { boost_objective <- "multi:softprob" } else if (objective == "binomial_logistic") { @@ -906,7 +867,8 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( "..get_distribution_family,familiarXGBoost: unknown learn objective: ", - objective)) + objective + )) } return(boost_objective) @@ -920,7 +882,8 @@ setMethod( "..set_recalibration_model", signature( object = "familiarXGBoost", - data = "dataObject"), + data = "dataObject" + ), function(object, data, time = NULL) { # Recalibration is performed using standard methods if (object@outcome_type %in% c("survival")) { @@ -928,7 +891,8 @@ setMethod( object@calibration_model <- .set_recalibration( object = object, data = data, - time = time) + time = time + ) # Return object. return(object) @@ -947,13 +911,10 @@ setMethod( function(object, ...) { # Set is_trimmed to TRUE. object@is_trimmed <- TRUE - + # Prevent trimming of raw, serialised model information. if (inherits(object@model, "raw")) return(object) - # Update model by removing the call. - object@model$call <- call("trimmed") - # Add show. object <- .capture_show(object) diff --git a/R/LearnerSurvivalGrouping.R b/R/LearnerSurvivalGrouping.R deleted file mode 100644 index 3876e5a3..00000000 --- a/R/LearnerSurvivalGrouping.R +++ /dev/null @@ -1,288 +0,0 @@ -.get_available_stratification_methods <- function() { - return(c("median", "fixed", "optimised", "mean", "mean_trim", "mean_winsor")) -} - - - -.find_survival_grouping_thresholds <- function(object, data) { - if (!object@outcome_type %in% c("survival")) { - ..error_reached_unreachable_code(paste0( - ".find_survival_grouping_thresholds: only available for ", - "survival outcome. Found: ", object@outcome_type)) - } - - # Load settings to find survival thresholds - settings <- get_settings() - - # Set time_max - time_max <- settings$eval$time_max - - # Generate prediction table - prediction_table <- .predict( - object = object, - data = data, - allow_recalibration = TRUE, - time = time_max) - - # Check if any predictions are valid. - if (!any_predictions_valid( - prediction_table, - outcome_type = object@outcome_type)) { - return(NULL) - } - - # Remove data with missing predictions. - prediction_table <- remove_nonvalid_predictions( - prediction_table, - outcome_type = object@outcome_type) - - km_info_list <- list() - - # Iterate over stratification methods - for (cut_off_method in settings$eval$strat_method) { - if (cut_off_method == "median") { - # Identify threshold - cutoff <- .find_quantile_threshold( - object = object, - prediction_table = prediction_table, - quantiles = 0.5) - - } else if (cut_off_method == "fixed") { - # Identify thresholds - cutoff <- .find_quantile_threshold( - object = object, - prediction_table = prediction_table, - quantiles = settings$eval$strat_quant_threshold) - - } else if (cut_off_method == "optimised") { - # Identify threshold - cutoff <- .find_maxstat_threshold(prediction_table = prediction_table) - - } else if (cut_off_method %in% c("mean", "mean_winsor", "mean_trim")) { - # Identify threshold - cutoff <- .find_mean_threshold( - object = object, - prediction_table = prediction_table, - method = cut_off_method) - - } else { - ..error_reached_unreachable_code(paste0( - ".find_survival_grouping_thresholds: encountered an unknown ", - "threshold type:", cut_off_method)) - } - - # Find corresponding sizes of the generated groups - risk_group <- .apply_risk_threshold( - object = object, - predicted_values = prediction_table$predicted_outcome, - cutoff = cutoff) - - group_size <- .get_risk_group_sizes(risk_group = risk_group) - - # Populate method_list - method_list <- list( - "method" = cut_off_method, - "cutoff" = cutoff, - "group_size" = group_size) - - # Attach method_list to the general km_info_list - km_info_list[[cut_off_method]] <- method_list - } - - # Add stratification methods - out_list <- list( - "stratification_method" = settings$eval$strat_method, - "parameters" = km_info_list, - "time_max" = time_max) - - return(out_list) -} - - - -.find_mean_threshold <- function(object, prediction_table, method) { - # Select finite values. - x <- prediction_table$predicted_outcome[is.finite(prediction_table$predicted_outcome)] - - if (method == "mean_trim") x <- trim(x) - if (method == "mean_winsor") x <- winsor(x) - - return(mean(x)) -} - - - -.find_quantile_threshold <- function(object, prediction_table, quantiles) { - - if (get_prediction_type(object = object) %in% c("expected_survival_time")) { - # For time-like predictions, we should use the complements of the provided - # quantiles. - quantiles <- abs(1 - quantiles) - } - # Order quantiles in ascending order - quantiles <- quantiles[order(quantiles)] - - # Return threshold values - return(stats::quantile( - x = prediction_table$predicted_outcome, - probs = quantiles, - names = FALSE, - na.rm = TRUE)) -} - - - -.find_maxstat_threshold <- function(prediction_table) { - # Check whether the model always predicted the same value - if (stats::var(prediction_table$predicted_outcome) == 0) { - return(prediction_table$predicted_outcome[1]) - } - - require_package( - x = "maxstat", - purpose = "to determine an optimal risk threshold") - - # Perform maxstat test - h <- tryCatch( - maxstat::maxstat.test( - survival::Surv(outcome_time, outcome_event) ~ predicted_outcome, - data = prediction_table, - smethod = "LogRank", - minprop = 0.10, - maxprop = 0.90), - error = identity) - - # Check that maxstat.test did not produce an error. - if (inherits(h, "error")) { - return(mean(prediction_table$predicted_outcome, na.rm = TRUE)) - } - - # Check if at least 4 unique values are present for the smoothing spline - if (length(h$cuts) < 4) { - return(unname(h$estimate)) - } - - # Smoothed scores - spline_fit <- tryCatch( - stats::smooth.spline(x = h$cuts, y = h$stats)$fit, - error = identity) - - # Capture error. - if (inherits(spline_fit, "error")) { - return(unname(h$estimate)) - } - - # Predict scores on a fine grid - x_sample_cuts <- seq( - from = min(h$cuts), - to = max(h$cuts), - length.out = 100) - - test_scores <- stats::predict( - object = spline_fit, - x = x_sample_cuts)$y - - return(x_sample_cuts[which.max(test_scores)]) -} - - - -.get_risk_group_sizes <- function(risk_group) { - # Suppress NOTES due to non-standard evaluation in data.table - indicated_group <- NULL - - # Find group sizes - group_table <- data.table::data.table("indicated_group" = risk_group) - group_table <- group_table[, list("group_size" = .N), by = "indicated_group"][order(indicated_group)] - - # Get group sizes and set names - group_sizes <- group_table$group_size / length(risk_group) - names(group_sizes) <- group_table$indicated_group - - return(group_sizes) -} - - - -.apply_risk_threshold <- function(object, predicted_values, cutoff) { - # Initialise risk group - risk_group <- rep.int(1, times = length(predicted_values)) - - # Determine inversion. We assume that risk groups go from 1 (low risk) to k - # (high risk), with k-1 being the number of provided cutoff values. - invert <- !get_prediction_type(object = object) %in% .get_available_risklike_prediction_types() - - # Iterate over cutoffs and define risk groups - for (current_cutoff in cutoff) { - if (invert) { - risk_group <- risk_group + as.numeric(predicted_values < current_cutoff) - } else { - risk_group <- risk_group + as.numeric(predicted_values >= current_cutoff) - } - } - - # Convert to factor - risk_group <- .assign_risk_group_names( - risk_group = risk_group, - cutoff = cutoff) - - # Replace non-finite predicted values by NA. - risk_group[!is.finite(predicted_values)] <- NA - - # Return risk groups - return(risk_group) -} - - - -.assign_risk_group_names <- function(risk_group, cutoff) { - # Determine the number of risk groups - n_groups <- length(cutoff) + 1 - - if (n_groups == 2) { - # Stratification into low and high-risk groups - y <- factor( - x = risk_group, - levels = seq_len(n_groups), - labels = c("low", "high"), - ordered = TRUE) - - } else if (n_groups == 3) { - # Stratification into low, moderate and high-risk groups - y <- factor( - x = risk_group, - levels = seq_len(n_groups), - labels = c("low", "moderate", "high"), - ordered = TRUE) - - } else { - # Assign numbers - y <- factor( - x = risk_group, - levels = seq_len(n_groups), - ordered = TRUE) - } - - return(y) -} - - - -get_mean_risk_group <- function(risk_group) { - # Determine the mean average risk group. This requires discretisation - # as rounding toward the nearest group would overinflate center groups. - group_names <- levels(risk_group) - n <- length(group_names) - - # Discretise bins floor((mu - 1) / ((n-1) / n)) + 1. See fixed bin size - # discretisation. - risk_group_num <- floor(n * (mean(as.numeric(risk_group), na.rm = TRUE) - 1) / (n - 1)) + 1 - - # Check if the risk_group_num still falls within the range - risk_group_num <- ifelse(risk_group_num > n, n, risk_group_num) - - return(factor( - x = group_names[risk_group_num], - levels = group_names, - ordered = TRUE)) -} diff --git a/R/LearnerSurvivalProbability.R b/R/LearnerSurvivalProbability.R index d4b48390..e920e44a 100644 --- a/R/LearnerSurvivalProbability.R +++ b/R/LearnerSurvivalProbability.R @@ -9,17 +9,20 @@ get_baseline_survival <- function(data) { if (!is(data, "dataObject")) { ..error_reached_unreachable_code( - "get_baseline_survival: data is not a dataObject object.") + "get_baseline_survival: data is not a dataObject object." + ) } if (!data@outcome_type %in% c("survival")) { ..error_reached_unreachable_code( - "get_baseline_survival: outcome_type is not survival.") + "get_baseline_survival: outcome_type is not survival." + ) } # Extract relevant information regarding survival. survival_data <- unique(data@data[, mget(c( - get_id_columns(id_depth = "series"), "outcome_time", "outcome_event"))]) + get_id_columns(id_depth = "series"), "outcome_time", "outcome_event" + ))]) # Make a local copy. survival_data <- data.table::copy(survival_data) @@ -27,35 +30,41 @@ get_baseline_survival <- function(data) { # Get the survival estimate from a Kaplan-Meier fit. km_fit <- survival::survfit( Surv(outcome_time, outcome_event) ~ 1, - data = survival_data) + data = survival_data + ) # Add censoring rate cens_fit <- survival::survfit( - Surv(outcome_time, outcome_event == 0) ~ 1, - data = survival_data) + Surv(outcome_time, outcome_event == 0L) ~ 1, + data = survival_data + ) # Complete a Kaplan-Meier table including censoring rates. kaplan_meier_table <- data.table::data.table( "time" = km_fit$time, "km_survival" = km_fit$surv, - "km_survival_var" = km_fit$std.err^2, - "cens_distr" = cens_fit$surv) + "km_survival_var" = km_fit$std.err^2.0, + "cens_distr" = cens_fit$surv + ) # Add time 0. - if (min(kaplan_meier_table$time) > 0) { + if (min(kaplan_meier_table$time) > 0.0) { kaplan_meier_table <- rbind( kaplan_meier_table, data.table::data.table( "time" = 0.0, "km_survival" = 1.0, "km_survival_var" = 0.0, - "cens_distr" = 1.0)) + "cens_distr" = 1.0 + ) + ) } # Replace inf variance by 1.0 kaplan_meier_table[ is.infinite(km_survival_var), - "km_survival_var" := 1.0] + "km_survival_var" := 1.0 + ] # Sort by time. kaplan_meier_table <- kaplan_meier_table[order(time)] @@ -64,59 +73,100 @@ get_baseline_survival <- function(data) { } - -.survival_probability_relative_risk <- function(object, data, time) { - if (!is(object, "familiarModel")) { - ..error_reached_unreachable_code( - ".survival_probability_relative_risk: object is not a familiarModel object.") +# .survival_probability_relative_risk (generic) -------------------------------- +setGeneric( + ".survival_probability_relative_risk", + function(object, ...) setGeneric(".survival_probability_relative_risk") +) + + +# .survival_probability_relative_risk (model) ---------------------------------- +setMethod( + ".survival_probability_relative_risk", + signature(object = "familiarModel"), + function( + object, + data, + time, + ... + ) { + if (!is(data, "dataObject")) { + ..error_reached_unreachable_code( + ".survival_probability_relative_risk: object is not a dataObject object." + ) + } + + # Predict relative risks. + prediction_table <- .predict( + object = object, + data = data, + type = "default", + allow_recalibration = TRUE, + time = time + ) + + # Convert to probability. + prediction_table <- .survival_probability_relative_risk( + object = prediction_table, + data = data, + time = time, + model = object, + ... + ) + + return(prediction_table) } - if (!is(data, "dataObject")) { - ..error_reached_unreachable_code( - ".survival_probability_relative_risk: object is not a dataObject object.") +) + + +# .survival_probability_relative_risk (prediction_table) ----------------------- +setMethod( + ".survival_probability_relative_risk", + signature(object = "predictionTableSurvivalHazardRatio"), + function( + object, + data, + time, + model, + ... + ) { + + if (!is(data, "dataObject")) { + ..error_reached_unreachable_code( + ".survival_probability_relative_risk: object is not a dataObject object." + ) + } + + # Check for several issues that prevent survival probabilities from being + # predicted. + if (is_empty(object)) return(NULL) + if (!any_predictions_valid(object)) return(NULL) + if (!has_calibration_info(model)) return(NULL) + + # Survival in the group is based on proportional hazards assumption, and + # uses baseline cumulative hazard and the group's predicted relative risks. + # This evaluation comes in handy when performing, e.g. the Nam-D'Agostino + # test. It avoids recalculating the baseline hazard. Following Demler, + # Paynter and Cook. (Stat. Med. 2015), we compute the survival probability + # at t=time_max for each sample. + survival_probabilities <- ..survival_probability_relative_risk( + object = model, + relative_risk = object@prediction_data$predicted_outcome, + time = time + ) + + # Create prediction table. + prediction_table <- as_prediction_table( + x = survival_probabilities, + type = "survival_probability", + data = data, + time = time, + model_object = model + ) + + return(prediction_table) } - - # Predict relative risks. - prediction_table <- .predict( - object = object, - data = data, - allow_recalibration = TRUE, - time = time) - - # Prepare an empty table in case things go wrong. - empty_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "survival_probability") - - # Check for several issues that prevent survival probabilities from being - # predicted. - if (!any_predictions_valid( - prediction_table = prediction_table, - outcome_type = object@outcome_type)) { - return(empty_table) - } - if (!has_calibration_info(object)) { - return(empty_table) - } - - # Survival in the group is based on proportional hazards assumption, and - # uses baseline cumulative hazard and the group's predicted relative risks. - # This evaluation comes in handy when performing, e.g. the Nam-D'Agostino - # test. It avoids recalculating the baseline hazard. Following Demler, - # Paynter and Cook. (Stat. Med. 2015), we compute the survival probability - # at t=time_max for each sample. - survival_probabilities <- ..survival_probability_relative_risk( - object = object, - relative_risk = prediction_table$predicted_outcome, - time = time) - - # Updated the prediction table - prediction_table[, ":="( - "predicted_outcome" = NULL, - "survival_probability" = survival_probabilities)] - - return(prediction_table) -} +) @@ -134,12 +184,13 @@ get_baseline_survival <- function(data) { y = object@calibration_info$km_survival, xout = time, method = "linear", - rule = 2 + rule = 2L )$y # Create a n_sample x n_times matrix return(sapply( relative_risk, function(rr, s0) (s0^rr), - s0 = baseline_surv)) + s0 = baseline_surv + )) } diff --git a/R/Logger.R b/R/Logger.R index ce610ce0..87b46388 100644 --- a/R/Logger.R +++ b/R/Logger.R @@ -2,13 +2,14 @@ logger_message <- function( mess_str, file_name = NULL, indent = 0L, - verbose = TRUE) { + verbose = TRUE +) { # Write message to console and file if (is.null(file_name)) file_name <- .get_log_file() # Derive an indent string using two spaces for each indentation. - indent_str <- paste0(rep(" ", indent), collapse = "") + indent_str <- strrep(" ", indent) # Date and time string date_str <- format(Sys.time(), "%Y-%m-%d %H:%M:%S") @@ -21,7 +22,8 @@ logger_message <- function( tryCatch(write( x = log_str, file = file_name, - append = TRUE)) + append = TRUE + )) } # Write message to console @@ -34,9 +36,12 @@ logger_message <- function( logger_warning <- function( warn_str, - file_name = NULL) { + file_name = NULL, + warn_class = NULL, + call = rlang::caller_env() +) { # Write warning to console and file - + if (is.null(file_name)) file_name <- .get_log_file() # Date and time string @@ -50,11 +55,16 @@ logger_warning <- function( tryCatch(write( x = log_str, file = file_name, - append = TRUE)) + append = TRUE + )) } # Write warning to console - warning(warn_str) + rlang::warn( + message = warn_str, + class = union("familiar_warning", warn_class), + call = call + ) return(invisible(NULL)) } @@ -63,7 +73,10 @@ logger_warning <- function( logger_stop <- function( err_str, - file_name = NULL) { + file_name = NULL, + error_class = NULL, + call = rlang::caller_env() +) { # Write error to console and file if (is.null(file_name)) file_name <- .get_log_file() @@ -76,11 +89,19 @@ logger_stop <- function( # Write error to log file if (!is.null(file_name)) { - tryCatch(write(x = log_str, file = file_name, append = TRUE)) + tryCatch(write( + x = log_str, + file = file_name, + append = TRUE + )) } # Write error to console - stop(err_str) + rlang::abort( + message = err_str, + class = union("familiar_error", error_class), + call = call + ) } diff --git a/R/MetricS4.R b/R/MetricS4.R index 970221f4..28fb5f15 100644 --- a/R/MetricS4.R +++ b/R/MetricS4.R @@ -1,22 +1,8 @@ #' @include FamiliarS4Generics.R #' @include FamiliarS4Classes.R -as_metric <- function( - metric, - object = NULL, - outcome_type = NULL, - ...) { +as_metric <- function(metric, outcome_type, ...) { - # Find the outcome type - if (is.null(outcome_type)) { - if ( - is(object, "familiarModel") || - is(object, "familiarEnsemble") || - is(object, "familiarVimpMethod")) { - outcome_type <- object@outcome_type - } - } - if (metric %in% .get_available_auc_roc_metrics()) { metric_object <- do.call( methods::new, @@ -24,8 +10,11 @@ as_metric <- function( list( "Class" = "familiarMetricAUCROC", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricAUCROC", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricAUCROC", ...) + ) + ) } else if (metric %in% .get_available_brier_metrics()) { metric_object <- do.call( @@ -34,8 +23,11 @@ as_metric <- function( list( "Class" = "familiarMetricBrier", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricBrier", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricBrier", ...) + ) + ) } else if (metric %in% .get_available_accuracy_metrics()) { metric_object <- do.call( @@ -44,8 +36,11 @@ as_metric <- function( list( "Class" = "familiarMetricAccuracy", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricAccuracy", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricAccuracy", ...) + ) + ) } else if (metric %in% .get_available_balanced_accuracy_metrics()) { metric_object <- do.call( @@ -54,8 +49,11 @@ as_metric <- function( list( "Class" = "familiarMetricBalancedAccuracy", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricBalancedAccuracy", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricBalancedAccuracy", ...) + ) + ) } else if (metric %in% .get_available_balanced_error_rate_metrics()) { metric_object <- do.call( @@ -66,7 +64,9 @@ as_metric <- function( "metric" = metric, "outcome_type" = outcome_type ), - .sanitise_dots("familiarMetricBalancedErrorRate", ...))) + .sanitise_dots("familiarMetricBalancedErrorRate", ...) + ) + ) } else if (metric %in% .get_available_cohen_kappa_metrics()) { metric_object <- do.call( @@ -75,8 +75,11 @@ as_metric <- function( list( "Class" = "familiarMetricCohenKappa", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricCohenKappa", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricCohenKappa", ...) + ) + ) } else if (metric %in% .get_available_f1_score_metrics()) { metric_object <- do.call( @@ -85,8 +88,11 @@ as_metric <- function( list( "Class" = "familiarMetricF1Score", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricF1Score", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricF1Score", ...) + ) + ) } else if (metric %in% .get_available_fdr_metrics()) { metric_object <- do.call( @@ -95,8 +101,11 @@ as_metric <- function( list( "Class" = "familiarMetricFDR", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricFDR", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricFDR", ...) + ) + ) } else if (metric %in% .get_available_informedness_metrics()) { metric_object <- do.call( @@ -105,8 +114,11 @@ as_metric <- function( list( "Class" = "familiarMetricInformedness", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricInformedness", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricInformedness", ...) + ) + ) } else if (metric %in% .get_available_markedness_metrics()) { metric_object <- do.call( @@ -115,8 +127,11 @@ as_metric <- function( list( "Class" = "familiarMetricMarkedness", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricMarkedness", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricMarkedness", ...) + ) + ) } else if (metric %in% .get_available_mcc_metrics()) { metric_object <- do.call( @@ -125,8 +140,11 @@ as_metric <- function( list( "Class" = "familiarMetricMCC", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricMCC", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricMCC", ...) + ) + ) } else if (metric %in% .get_available_npv_metrics()) { metric_object <- do.call( @@ -135,8 +153,11 @@ as_metric <- function( list( "Class" = "familiarMetricNPV", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricNPV", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricNPV", ...) + ) + ) } else if (metric %in% .get_available_ppv_metrics()) { metric_object <- do.call( @@ -145,8 +166,11 @@ as_metric <- function( list( "Class" = "familiarMetricPPV", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricPPV", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricPPV", ...) + ) + ) } else if (metric %in% .get_available_sensitivity_metrics()) { metric_object <- do.call( @@ -155,8 +179,11 @@ as_metric <- function( list( "Class" = "familiarMetricSensitivity", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricSensitivity", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricSensitivity", ...) + ) + ) } else if (metric %in% .get_available_specificity_metrics()) { metric_object <- do.call( @@ -165,8 +192,11 @@ as_metric <- function( list( "Class" = "familiarMetricSpecificity", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricSpecificity", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricSpecificity", ...) + ) + ) } else if (metric %in% .get_available_youden_metrics()) { metric_object <- do.call( @@ -175,8 +205,11 @@ as_metric <- function( list( "Class" = "familiarMetricYouden", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricYouden", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricYouden", ...) + ) + ) } else if (metric %in% .get_available_mae_metrics()) { metric_object <- do.call( @@ -185,8 +218,11 @@ as_metric <- function( list( "Class" = "familiarMetricMAE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricMAE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricMAE", ...) + ) + ) } else if (metric %in% .get_available_rae_metrics()) { metric_object <- do.call( @@ -195,8 +231,11 @@ as_metric <- function( list( "Class" = "familiarMetricRAE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricRAE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricRAE", ...) + ) + ) } else if (metric %in% .get_available_mlae_metrics()) { metric_object <- do.call( @@ -205,8 +244,11 @@ as_metric <- function( list( "Class" = "familiarMetricMLAE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricMLAE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricMLAE", ...) + ) + ) } else if (metric %in% .get_available_mse_metrics()) { metric_object <- do.call( @@ -215,8 +257,11 @@ as_metric <- function( list( "Class" = "familiarMetricMSE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricMSE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricMSE", ...) + ) + ) } else if (metric %in% .get_available_rse_metrics()) { metric_object <- do.call( @@ -225,8 +270,11 @@ as_metric <- function( list( "Class" = "familiarMetricRSE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricRSE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricRSE", ...) + ) + ) } else if (metric %in% .get_available_msle_metrics()) { metric_object <- do.call( @@ -235,8 +283,11 @@ as_metric <- function( list( "Class" = "familiarMetricMSLE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricMSLE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricMSLE", ...) + ) + ) } else if (metric %in% .get_available_medea_metrics()) { metric_object <- do.call( @@ -245,8 +296,11 @@ as_metric <- function( list( "Class" = "familiarMetricMedianAE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricMedianAE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricMedianAE", ...) + ) + ) } else if (metric %in% .get_available_rmse_metrics()) { metric_object <- do.call( @@ -255,8 +309,11 @@ as_metric <- function( list( "Class" = "familiarMetricRMSE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricRMSE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricRMSE", ...) + ) + ) } else if (metric %in% .get_available_rrse_metrics()) { metric_object <- do.call( @@ -265,8 +322,11 @@ as_metric <- function( list( "Class" = "familiarMetricRRSE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricRRSE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricRRSE", ...) + ) + ) } else if (metric %in% .get_available_rmsle_metrics()) { metric_object <- do.call( @@ -275,8 +335,11 @@ as_metric <- function( list( "Class" = "familiarMetricRMSLE", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricRMSLE", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricRMSLE", ...) + ) + ) } else if (metric %in% .get_available_r_squared_metrics()) { metric_object <- do.call( @@ -285,8 +348,11 @@ as_metric <- function( list( "Class" = "familiarMetricR2", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots("familiarMetricR2", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricR2", ...) + ) + ) } else if (metric %in% .get_available_explained_variance_metrics()) { metric_object <- do.call( @@ -295,9 +361,11 @@ as_metric <- function( list( "Class" = "familiarMetricExplainedVariance", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots( - "familiarMetricExplainedVariance", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricExplainedVariance", ...) + ) + ) } else if (metric %in% .get_available_concordance_index_harrell()) { metric_object <- do.call( @@ -306,10 +374,11 @@ as_metric <- function( list( "Class" = "familiarMetricConcordanceIndexHarrell", "metric" = metric, - "outcome_type" = outcome_type, - "object" = object), - .sanitise_dots( - "familiarMetricConcordanceIndexHarrell", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetricConcordanceIndexHarrell", ...) + ) + ) } else { metric_object <- do.call( @@ -318,9 +387,11 @@ as_metric <- function( list( "Class" = "familiarMetric", "metric" = metric, - "outcome_type" = outcome_type), - .sanitise_dots( - "familiarMetric", ...))) + "outcome_type" = outcome_type + ), + .sanitise_dots("familiarMetric", ...) + ) + ) } return(metric_object) @@ -361,18 +432,19 @@ setMethod( function(metric, dots) { return(do.call( as_metric, - args = c( - list("metric" = metric), - dots))) + args = c(list("metric" = metric), dots) + )) }, - dots = list(...)) + dots = list(...) + ) # Check that the metrics are available. if (!all(sapply(metric_object_list, is_available))) { - stop(paste0( + ..error(paste0( "is_higher_better: the following metrics are not available for ", - metric_object_list[[1]]@outcome_type, " outcomes: ", - paste_s(metric[!sapply(metric_object_list, is_available)]))) + metric_object_list[[1L]]@outcome_type, " outcomes: ", + paste_s(metric[!sapply(metric_object_list, is_available)]) + )) } # Determine which metrics have a higher value that is better. @@ -405,54 +477,55 @@ setMethod( setMethod( "compute_metric_score", signature(metric = "character"), - function(metric, data, object, ...) { - if (!is(object, "familiarModel") && !is(object, "familiarEnsemble")) { - stop(paste0( - "compute_metric_score: object should be a familiarModel ", - "or familiarEnsemble object.")) + function(metric, data, object = NULL, ...) { + if (is(data, "dataObject")) { + if (!is(object, "familiarModel") && !is(object, "familiarEnsemble")) { + ..error(paste0( + "compute_metric_score: object should be a familiarModel ", + "or familiarEnsemble object." + )) + } + + # Get outcome type. + outcome_type <- object@outcome_type + + # Compute prediction table. + data <- .predict( + object = object, + data = data, + ... + ) + + } else if (is(data, "familiarDataElementPredictionTable")) { + # Get outcome type. + outcome_type <- data@outcome_type + + } else { + ..error_reached_unreachable_code("data are neither a data object or a prediction table") } - + # Create metric objects. metric_object_list <- lapply( metric, as_metric, - object = object) + outcome_type = outcome_type + ) # Check that the metrics are available. if (!all(sapply(metric_object_list, is_available))) { - stop(paste0( + ..error(paste0( "compute_metric_score: the following metrics are not available for ", object@outcome_type, " outcomes: ", - paste_s(metric[!sapply(metric_object_list, is_available)]))) - } - - # Create prediction table, if one is absent. - if (is(data, "dataObject")) { - data <- do.call( - .predict, - args = c( - list( - "object" = object, - "data" = data), - list(...))) + paste_s(metric[!sapply(metric_object_list, is_available)]) + )) } # Compute metric values. metric_values <- lapply( metric_object_list, - function(metric, data, object, dots) { - do.call( - compute_metric_score, - args = c( - list( - "metric" = metric, - "data" = data, - "object" = object), - dots)) - }, + compute_metric_score, data = data, - object = object, - dots = list(...) + ... ) # Set names. @@ -474,12 +547,15 @@ setMethod( # Set the baseline value. metric <- set_metric_baseline_value( metric = metric, - data = data, ...) - + data = data, + ... + ) + # Check again if (is.null(metric@baseline_value)) { ..error_reached_unreachable_code( - "compute_objective_score: baseline_value was not set.") + "compute_objective_score: baseline_value was not set." + ) } } @@ -487,7 +563,8 @@ setMethod( if (is.null(value)) { value <- compute_metric_score( metric = metric, - data = data) + data = data + ) } # Get the baseline_value @@ -502,14 +579,16 @@ setMethod( optimal_value <- ifelse( is_higher_better(metric), max(metric@value_range), - min(metric@value_range)) - + min(metric@value_range) + ) + # If the baseline value is already perfect, use a small offset instead. if (baseline_value == optimal_value) { baseline_value <- ifelse( is_higher_better(metric), optimal_value - 1E-5, - optimal_value + 1E-5) + optimal_value + 1E-5 + ) } # Compute the objective_value @@ -523,12 +602,15 @@ setMethod( # Ensure that all objective scores fall in the [-1, 1] range. if (!is.finite(objective_value)) { objective_value <- NA_real_ + } else if (objective_value < -1.0) { objective_value <- -1.0 + } else if (objective_value > 1.0) { ..error_reached_unreachable_code(paste0( "compute_objective_score: objective value exceeds the maximum of 1.0: ", - objective_value)) + objective_value + )) } return(objective_value) @@ -546,7 +628,8 @@ setMethod( if ( is(object, "familiarModel") || is(object, "familiarVimpMethod") || - is(object, "familiarEnsemble")) { + is(object, "familiarEnsemble") + ) { outcome_info <- object@outcome_info } else if (is(data, "dataObject")) { @@ -556,58 +639,76 @@ setMethod( } else { # Compute outcome information from scratch. - outcome_info <- create_outcome_info_from_data(data = data@data) + outcome_info <- .create_outcome_info(data) outcome_info <- .compute_outcome_distribution_data( object = outcome_info, - data = data@data) + data = data@data + ) } } else if (data.table::is.data.table(data)) { # Compute outcome information from scratch. - outcome_info <- create_outcome_info_from_data(data = data) + outcome_info <- .create_outcome_info(data, outcome_type = metric@outcome_type) outcome_info <- .compute_outcome_distribution_data( object = outcome_info, - data = data) + data = data + ) } else { ..error_reached_unreachable_code(paste0( "set_metric_baseline_value: baseline_value could not be set ", - "using the provided data.")) + "using the provided data." + )) } - # Get a placeholder prediction table. - prediction_table <- get_placeholder_prediction_table( - object = outcome_info, - data = data) - # We need to identify the data source for determining baseline values. if (metric@outcome_type %in% c("binomial", "multinomial")) { # Get the frequency table and find the class with the majority. frequency_table <- outcome_info@distribution$frequency majority_class <- frequency_table$outcome[which.max(frequency_table$count)] - - # Fill the prediction_table. - prediction_table[, "predicted_class" := majority_class] - - # Define probabilities columns - outcome_probability_columns <- get_class_probability_name(object) - - for (ii in seq_along(outcome_probability_columns)) { + + # Get class levels. + class_levels <- get_outcome_class_levels(object) + + prediction_list <- list() + for (ii in seq_along(class_levels)) { # Update the predicted probabilities with 1.0 for the majority # class and 0.0 for minority classes. - if (outcome_probability_columns[ii] == get_class_probability_name(majority_class)) { - prediction_table[, (outcome_probability_columns[ii]) := 1.0] + if (class_levels[ii] == majority_class) { + prediction_list[[class_levels[ii]]] <- rep.int( + 1.0, + times = get_n_samples(data, "repetition", count_unique = FALSE) + ) + } else { - prediction_table[, (outcome_probability_columns[ii]) := 0.0] + prediction_list[[class_levels[ii]]] <- rep.int( + 0.0, + times = get_n_samples(data, "repetition", count_unique = FALSE) + ) } } - } else if (metric@outcome_type %in% c("count", "continuous")) { + prediction_table <- as_prediction_table( + x = prediction_list, + type = "classification", + data = data, + model_object = object + ) + + } else if (metric@outcome_type %in% c("continuous")) { # Baseline median value. median_value <- outcome_info@distribution$median - + # Fill the prediction_table. - prediction_table[, "predicted_outcome" := median_value] + prediction_table <- as_prediction_table( + x = rep.int( + median_value, + times = get_n_samples(data, "repetition", count_unique = FALSE) + ), + type = "regression", + data = data, + model_object = object + ) } else if (metric@outcome_type %in% c("survival")) { # Median baseline survival @@ -620,10 +721,18 @@ setMethod( } else { mean_survival_probability <- NA_real_ } - - # Fill the prediction_table. - prediction_table[, "predicted_outcome" := mean_survival_probability] + # Fill the prediction_table. + prediction_table <- as_prediction_table( + x = rep.int( + mean_survival_probability, + times = get_n_samples(data, "repetition", count_unique = FALSE) + ), + type = "survival_probability", + data = data, + model_object = object + ) + } else { ..error_outcome_type_not_implemented(metric@outcome_type) } @@ -631,15 +740,17 @@ setMethod( # Compute metric value metric@baseline_value <- compute_metric_score( metric = metric, - data = prediction_table) - + data = prediction_table + ) + # Check the baseline value is a finite value. If it isn't set the value to # the extreme value of the range. if (!is.finite(metric@baseline_value)) { metric@baseline_value <- ifelse( is_higher_better(metric), min(metric@value_range), - max(metric@value_range)) + max(metric@value_range) + ) } return(metric) @@ -652,7 +763,8 @@ setMethod( metric, object = NULL, outcome_type = NULL, - as_flag = FALSE) { + as_flag = FALSE +) { # Obtain outcome_type if (is.null(outcome_type) && !is.null(object)) { @@ -662,7 +774,8 @@ setMethod( # Initialise metric metric_object <- as_metric( metric = metric, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Check if the metric is available. metric_available <- is_available(metric_object) @@ -670,15 +783,17 @@ setMethod( if (as_flag) return(metric_available) # Check if the metric is available. - if (!is_subclass(class(metric_object)[1], "familiarMetric")) { - stop(paste0( + if (!is_subclass(class(metric_object)[1L], "familiarMetric")) { + ..error(paste0( metric, " is not a valid metric. ", - "Please check the vignette for available performance metrics.")) + "Please check the vignette for available performance metrics." + )) } else if (!metric_available) { - stop(paste0( + ..error(paste0( "The ", metric, " metric is not available for ", - outcome_type, " outcomes.")) + outcome_type, " outcomes." + )) } return(invisible(TRUE)) @@ -689,7 +804,8 @@ setMethod( .get_metric_default_range <- function( metric, object = NULL, - outcome_type = NULL) { + outcome_type = NULL +) { # Get default range of metric scores, e.g. for plotting metric values. # Obtain outcome_type @@ -700,7 +816,8 @@ setMethod( # Initialise metric object. metric_object <- as_metric( metric = metric, - outcome_type = outcome_type) + outcome_type = outcome_type + ) return(metric_object@value_range) } @@ -710,7 +827,8 @@ setMethod( .compute_metric_optimisation_score <- function( score_table, optimisation_function, - replace_na = TRUE) { + replace_na = TRUE +) { # Compute an optimisation score from validation and training scores. This # optimisation score is typically computed for each set of hyperparameters # (param_id) and subsample (run_id). @@ -722,7 +840,8 @@ setMethod( optimisation_score <- training <- validation <- NULL # Select the correct optimisation function. - optimisation_fun <- switch(optimisation_function, + optimisation_fun <- switch( + optimisation_function, "max_validation" = ..optimisation_score_max_validation, "validation" = ..optimisation_score_max_validation, "balanced" = ..optimisation_score_balanced, @@ -732,43 +851,52 @@ setMethod( "model_estimate" = ..optimisation_score_max_validation, "model_estimate_minus_sd" = ..optimisation_score_max_validation, "model_balanced_estimate" = ..optimisation_score_balanced, - "model_balanced_estimate_minus_sd" = ..optimisation_score_balanced) + "model_balanced_estimate_minus_sd" = ..optimisation_score_balanced + ) # Find identifier columns. - id_columns <- intersect( - colnames(score_table), - c("param_id", "run_id")) + id_columns <- intersect(colnames(score_table), c("param_id", "run_id")) # Create formula formula <- stats::reformulate( termlabels = "data_set", - response = paste0(c(id_columns, "metric"), collapse = " + ")) + response = paste0(c(id_columns, "metric"), collapse = " + ") + ) # Cast objective score wide by data_set. optimisation_table <- data.table::dcast( data = score_table[, mget(c(id_columns, "metric", "data_set", "objective_score"))], formula, - value.var = "objective_score") + value.var = "objective_score" + ) # Compute optimisation score based on objective scores. - optimisation_table <- optimisation_table[, list( - "optimisation_score" = optimisation_fun( - training = training, - validation = validation)), - by = c(id_columns, "metric")] + optimisation_table <- optimisation_table[ + , + list( + "optimisation_score" = optimisation_fun( + training = training, + validation = validation + ) + ), + by = c(id_columns, "metric") + ] # Replace NA entries with the minimum optimisation score. if (replace_na) { optimisation_table[ is.na(optimisation_score), - optimisation_score := ..get_replacement_optimisation_score()] + optimisation_score := ..get_replacement_optimisation_score() + ] } # Average optimisation score over metrics. - optimisation_table <- optimisation_table[, list( - "optimisation_score" = mean(optimisation_score, na.rm = TRUE)), - by = id_columns] - + optimisation_table <- optimisation_table[ + , + list("optimisation_score" = mean(optimisation_score, na.rm = TRUE)), + by = id_columns + ] + return(optimisation_table) } @@ -777,7 +905,8 @@ setMethod( .summarise_metric_optimisation_score <- function( score_table, method, - replace_na = TRUE) { + replace_na = TRUE +) { # Compute a summary score either directly from optimisation scores, or using a # model. This optimisation score is typically computed for each set of # hyperparameters. @@ -789,12 +918,11 @@ setMethod( optimisation_score <- NULL # Find identifier columns. - id_columns <- intersect( - colnames(score_table), - "param_id") + id_columns <- intersect(colnames(score_table), "param_id") # Obtain the aggregation method. - aggregation_method <- switch(method, + aggregation_method <- switch( + method, "improvement_empirical_probability" = stats::median, "improvement_probability" = mean, "expected_improvement" = mean, @@ -803,18 +931,24 @@ setMethod( "median" = stats::median, "mean" = mean, "max" = max, - "min" = min) + "min" = min + ) # Compute the mean optimisation score, overall, or per parameter id. - score_table <- score_table[, list( - "optimisation_score" = aggregation_method(optimisation_score, na.rm = TRUE)), - by = id_columns] + score_table <- score_table[ + , + list( + "optimisation_score" = aggregation_method(optimisation_score, na.rm = TRUE) + ), + by = id_columns + ] # Replace NA entries with the minimum optimisation score. if (replace_na) { score_table[ is.na(optimisation_score), - optimisation_score := ..get_replacement_optimisation_score()] + optimisation_score := ..get_replacement_optimisation_score() + ] } return(score_table) @@ -887,7 +1021,9 @@ setMethod( return(setdiff( all_optimisation_functions, c("model_estimate", "model_estimate_minus_sd", "model_balanced_estimate", - "model_balanced_estimate_minus_sd"))) + "model_balanced_estimate_minus_sd" + ) + )) } return(all_optimisation_functions) @@ -922,8 +1058,6 @@ setMethod( default_metric <- "auc_roc" } else if (outcome_type == "continuous") { default_metric <- "mse" - } else if (outcome_type == "count") { - default_metric <- "msle" } else if (outcome_type == "survival") { default_metric <- "concordance_index" } else if (outcome_type == "competing_risk") { diff --git a/R/MetricS4AUC.R b/R/MetricS4AUC.R index 1d37fbba..bb9bfc94 100644 --- a/R/MetricS4AUC.R +++ b/R/MetricS4AUC.R @@ -12,7 +12,9 @@ setClass( name = "Area under Receiver Operating Characteristic Curve", baseline_value = 0.5, value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -35,30 +37,31 @@ setMethod( # Suppress NOTES due to non-standard evaluation in data.table outcome <- NULL + if (is_empty(data)) return(callNextMethod()) + + if (!is(data, "predictionTableClassification")) { + ..error_data_not_prediction_table(data, "predictionTableClassification") + } + # Get the classes and number of classes in data. - outcome_classes <- get_outcome_class_levels( - data, - outcome_type = metric@outcome_type) + outcome_classes <- get_outcome_class_levels(data) n_classes <- length(outcome_classes) # Skip calculation if an AUC cannot be computed. - if (n_classes <= 1) return(callNextMethod()) + if (n_classes <= 1L) return(callNextMethod()) # Remove any entries that lack valid predictions. - data <- remove_nonvalid_predictions( - prediction_table = data, - outcome_type = metric@outcome_type) - + data <- remove_invalid_predictions(data) + # Remove any entries that lack observed values. - data <- remove_missing_outcomes( - data = data, - outcome_type = metric@outcome_type) - + data <- filter_missing_outcome(data) if (is_empty(data)) return(callNextMethod()) - if (nrow(data) <= 1) return(callNextMethod()) + + data <- .as_data_table(data) + if (nrow(data) <= 1L) return(callNextMethod()) # Define class combinations (>1 in case of multinomial outcomes) - class_combinations <- utils::combn(outcome_classes, 2) + class_combinations <- utils::combn(outcome_classes, 2L) n_class_combinations <- ncol(class_combinations) # Generate empty auc vector AUC of the ROC is calculated according to Hand, @@ -70,36 +73,27 @@ setMethod( # Iterate over combinations for (ii in seq_len(n_class_combinations)) { # Find the current positive and negative classes - positive_class <- class_combinations[1, ii] - negative_class <- class_combinations[2, ii] - - # Get the probability column name for the positive class. - class_probability_column <- get_class_probability_name(x = positive_class) - - # Get the probabilities that correspond to the positive and - # negative class in outcome (g and f in Hand et al.). - class_probability_positive <- data[outcome == positive_class, ][[class_probability_column]] - class_probability_negative <- data[outcome == negative_class, ][[class_probability_column]] - - # Get number of positive and negative class entries (n0 and n1 in Hand et - # al.). - n_positive <- length(class_probability_positive) - n_negative <- length(class_probability_negative) - - # Calculate AUC only when positive and negative classes are present. - if (n_positive > 0 & n_negative > 0) { - # Determine probability ranks - sample_rank <- data.table::frank( - x = c(class_probability_positive, class_probability_negative), - ties.method = "average") - - # Calculate AUC - auc_score[ii] <- (sum(sample_rank[seq_len(n_positive)]) - n_positive * (n_positive + 1) / 2) / - (n_positive * n_negative) - - } else { - auc_score[ii] <- NA_real_ - } + positive_class <- class_combinations[1L, ii] + negative_class <- class_combinations[2L, ii] + + # Get the probabilities that correspond to the positive and # negative + # class in outcome (g and f in Hand et al.). + class_probability_positive <- data[outcome == positive_class, ][[positive_class]] + class_probability_negative <- data[outcome == negative_class, ][[positive_class]] + + # Set x and y_obs + x <- c(class_probability_positive, class_probability_negative) + + y_obs <- c( + rep_len(TRUE, length(class_probability_positive)), + rep_len(FALSE, length(class_probability_negative)) + ) + + # Compute AUC value for the current combination. + auc_score[ii] <- ..compute_auc_roc( + x = x, + y_obs = y_obs + ) } # Calculate mean AUC (eq. 7 from Hand et al.). This has no effect for @@ -112,6 +106,77 @@ setMethod( ) +.compute_auc_roc <- function(x, y_obs) { + if (!is.factor(y_obs)) ..error("y_obs should be a categorical value") + # Called from functions other then compute_metric_score. + outcome_classes <- levels(y_obs) + + # Define class combinations (>1 in case of multinomial outcomes) + class_combinations <- utils::combn(outcome_classes, 2L) + n_class_combinations <- ncol(class_combinations) + + # Generate empty auc vector AUC of the ROC is calculated according to Hand, + # D.J, and Till, R.J. A simple generalisation of the area under the ROC + # curve for multiple class classification problems, Machine Learning 45 + # 171-186 (2001) + auc_score <- vector(mode = "numeric", length = n_class_combinations) + + # Iterate over combinations + for (ii in seq_len(n_class_combinations)) { + # Find the current positive and negative classes + positive_class <- class_combinations[1L, ii] + negative_class <- class_combinations[2L, ii] + + # Get the probabilities that correspond to the positive and # negative + # class in outcome (g and f in Hand et al.). + x_positive <- x[y_obs == positive_class] + x_negative <- x[y_obs == negative_class] + + # Compute AUC value for the current combination. + auc_score[ii] <- ..compute_auc_roc( + x = c(x_positive, x_negative), + y_obs = c( + rep_len(TRUE, length(x_positive)), + rep_len(FALSE, length(x_negative)) + ) + ) + } + + # Calculate mean AUC (eq. 7 from Hand et al.). This has no effect for + # binomial AUC. + if (!any(is.finite(auc_score))) return(NA_real_) + auc_score <- mean(auc_score, na.rm = TRUE) + + return(auc_score) +} + + +..compute_auc_roc <- function(x, y_obs) { + # Called directly from compute_metric_score + if (!is.logical(y_obs)) ..error("y_obs should contain only boolean values") + n_positive <- sum(y_obs) + n_negative <- length(y_obs) - n_positive + + if (n_positive > 0L & n_negative > 0L) { + + # Determine ranks + sample_rank <- data.table::frank( + x = x, + ties.method = "average" + ) + + # Calculate AUC + auc <- (sum(sample_rank[seq_len(n_positive)]) - n_positive * (n_positive + 1L) / 2.0) / + (n_positive * n_negative) + + } else { + auc <- NA_real_ + } + + return(auc) +} + + .get_available_auc_roc_metrics <- function() { return(c("auc", "auc_roc")) diff --git a/R/MetricS4Brier.R b/R/MetricS4Brier.R index b3b35efb..b9cd6049 100644 --- a/R/MetricS4Brier.R +++ b/R/MetricS4Brier.R @@ -13,7 +13,9 @@ setClass( outcome_type = NA_character_, name = "Brier Score", value_range = c(0.0, 1.0), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -33,30 +35,30 @@ setMethod( "compute_metric_score", signature(metric = "familiarMetricBrier"), function(metric, data, ...) { + + if (is_empty(data)) return(callNextMethod()) + + if (!is(data, "predictionTableClassification")) { + ..error_data_not_prediction_table(data, "predictionTableClassification") + } + # Get the classes and number of classes in data. - outcome_classes <- get_outcome_class_levels( - data, - outcome_type = metric@outcome_type) + outcome_classes <- get_outcome_class_levels(data) n_classes <- length(outcome_classes) # Skip calculation if there are no other classes. - if (n_classes <= 1) return(callNextMethod()) + if (n_classes <= 1L) return(callNextMethod()) # Remove any entries that lack valid predictions. - data <- remove_nonvalid_predictions( - prediction_table = data, - outcome_type = metric@outcome_type) + data <- remove_invalid_predictions(data) # Remove any entries that lack observed values. - data <- remove_missing_outcomes( - data = data, - outcome_type = metric@outcome_type) - - # Check that there is any data left. + data <- filter_missing_outcome(data) if (is_empty(data)) return(callNextMethod()) - + # Identify the outcome column. - outcome_column <- get_outcome_columns(x = metric@outcome_type) + outcome_column <- get_outcome_columns(x = data@outcome_type) + data <- .as_data_table(data) # Create empty brier score vector. brier_score <- vector(mode = "numeric", length = n_classes) @@ -66,18 +68,15 @@ setMethod( # Find the current positive class positive_class <- outcome_classes[ii] - # Get the probability column name for the positive class. - class_probability_column <- get_class_probability_name(x = positive_class) - # Prepare data to compute a Brier score. - brier_data <- data.table::copy(data[, mget(c(outcome_column, class_probability_column))]) + brier_data <- data.table::copy(data[, mget(c(outcome_column, positive_class))]) # Mark positive class as 1, and the rest as 0. - brier_data[, "positive_outcome" := 0] - brier_data[get(outcome_column) == positive_class, "positive_outcome" := 1] + brier_data[, "positive_outcome" := 0L] + brier_data[get(outcome_column) == positive_class, "positive_outcome" := 1L] # Calculate uncorrected brier score for the current positive class. - brier_score[ii] <- sum((brier_data[[class_probability_column]] - brier_data$positive_outcome)^2) + brier_score[ii] <- sum((brier_data[[positive_class]] - brier_data$positive_outcome)^2.0) } # Calculate overall brier score diff --git a/R/MetricS4ConcordanceIndex.R b/R/MetricS4ConcordanceIndex.R index 252251fd..5e1b33e1 100644 --- a/R/MetricS4ConcordanceIndex.R +++ b/R/MetricS4ConcordanceIndex.R @@ -8,12 +8,8 @@ NULL setClass( "familiarMetricConcordanceIndex", contains = "familiarMetric", - slots = list( - "time" = "numeric", - "prediction_type" = "character"), - prototype = list( - "time" = Inf, - "prediction_type" = "hazard_ratio") + slots = list("time" = "numeric"), + prototype = list("time" = Inf) ) @@ -26,7 +22,9 @@ setClass( name = "Concordance Index", baseline_value = 0.5, value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -39,7 +37,8 @@ setMethod( time = NULL, object = NULL, prediction_type = NULL, - ...) { + ... + ) { # Update with parent class first. .Object <- callNextMethod(.Object, ...) @@ -50,20 +49,12 @@ setMethod( } else if ( is(object, "familiarModel") || is(object, "familiarEnsemble") || - is(object, "familiarVimpMethod")) { + is(object, "familiarVimpMethod") + ) { # Obtain time from the outcome info. .Object@time <- object@outcome_info@time } - # Attempt to set the prediction type - if (!is.null(prediction_type)) { - .Object@prediction_type <- prediction_type - - } else if (is(object, "familiarModel") || is(object, "familiarEnsemble")) { - # Obtain prediction-type from the model or ensemble. - .Object@prediction_type <- get_prediction_type(object) - } - return(.Object) } ) @@ -89,13 +80,15 @@ setMethod( # Compute a standard concordance index. score <- .compute_concordance_index( metric = metric, - data = data) + data = data, + ... + ) # Invert the score for risk-like predictions. - if (metric@prediction_type %in% .get_available_risklike_prediction_types()) { + if (!is(data, "predictionTableSurvivalTime")) { score <- 1.0 - score } - + return(score) } ) @@ -105,48 +98,79 @@ setMethod( .compute_concordance_index <- function( metric, data, - weight_function = NULL) { + time = NULL, + weight_function = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table outcome_time <- outcome_event <- NULL + if (is_empty(data)) return(NA_real_) + + if (!is(data, "predictionTableSurvival")) { + ..error_data_not_prediction_table(data, "predictionTableSurvival") + } + # Remove any entries that lack valid predictions. - data <- remove_nonvalid_predictions( - prediction_table = data, - outcome_type = metric@outcome_type) - + data <- remove_invalid_predictions(data) + # Remove any entries that lack observed values. - data <- remove_missing_outcomes( - data = data, - outcome_type = metric@outcome_type) - + data <- filter_missing_outcome(data) if (is_empty(data)) return(NA_real_) + # Determine maximum time for censoring. There are multiple ways to obtain + # maximum time, in order of preference: + # + # 1. From function input. + # + # 2. From the metric object (metric), which may have inherited it from the + # model or model ensemble. + # + # 3. From the prediction table object (data). + # + # As fallback, max time is set to infinite. + max_time <- time + if (is.null(max_time) && is.finite(metric@time)) max_time <- metric@time + if (is.null(max_time) && methods::.hasSlot(data, "time")) { + if (is.finite(data@time)) max_time <- data@time + } + if (is.null(max_time)) max_time <- Inf + + # Check max_time + .check_number_in_valid_range( + x = max_time, + var_name = "time", + range = c(0.0, Inf), + closed = c(FALSE, TRUE) + ) + # Apply max time. Everything beyond max time is censored for the purpose of # computing a concordance index. - data[outcome_time > metric@time, "outcome_event" := 0] + data <- .as_data_table(data) + data[outcome_time > max_time, "outcome_event" := 0L] # All competing risks are treated as censoring for computing the concordance # index. - data[outcome_event > 1, "outcome_event" := 0] + data[outcome_event > 1L, "outcome_event" := 0L] # Check that there are any events. - if (nrow(data[outcome_event == 1]) == 0) return(NA_real_) + if (nrow(data[outcome_event == 1L]) == 0L) return(NA_real_) # Remove any samples that are censored prior to the first event. - earliest_event <- min(data[outcome_event == 1]$outcome_time) + earliest_event <- min(data[outcome_event == 1L]$outcome_time) # Keep only data from the earliest event onward. data <- data[outcome_time >= earliest_event] # Check that sufficient data is remaining. - if (nrow(data) < 2) return(NA_real_) + if (nrow(data) < 2L) return(NA_real_) # Compute a concordance index score score <- ..compute_concordance_index( x = data$predicted_outcome, time = data$outcome_time, event = data$outcome_event, - weight_function = weight_function) + weight_function = weight_function + ) return(score) } @@ -158,64 +182,17 @@ setMethod( time, event, weight_function = NULL, - ...) { - # Based on Pencina et al. 2004; doi:10.1002/sim.1802 - - # Suppress NOTES due to non-standard evaluation in data.table - id.x <- id.y <- event.x <- event.y <- time.x <- time.y <- pred.x <- pred.y <- NULL - - # Generate a combinatorial data set - dt <- data.table::data.table( - "id_join" = 1, - "id" = seq_along(x), - "pred" = x, - "time" = time, - "event" = event) - - dt <- merge( - x = dt, - y = dt, - by = "id_join", - allow.cartesian = TRUE) + ... +) { + # Compute using concordance in the survival package. + ci <- survival::concordance( + Surv(time, event) ~ x, + data = list("x" = x, "time" = time, "event" = event) + )$concordance - dt <- dt[id.x < id.y, ] - dt[, ":="( - "id_join" = NULL, - "id.x" = NULL, - "id.y" = NULL)] - - # Get only useful pairs (event-event with non-tied times; event-non-event with - # non-event surviving past event) - dt <- dt[ - (event.x == 1 & event.y == 1 & time.x != time.y) | - (event.x == 1 & time.x < time.y) | - (event.y == 1 & time.y < time.x), ] - - if (is.function(weight_function)) { - dt[, "weight" := weight_function( - time.x = time.x, - time.y = time.y, - event.x = event.x, - event.y = event.y, - ...)] - - } else { - dt[, "weight" := 1.0] - } - - # Calculate concordance index using Noethers method. - n_concord <- sum(dt[(pred.x > pred.y & time.x > time.y) | - (pred.x < pred.y & time.x < time.y)]$weight) - n_discord <- sum(dt[(pred.x > pred.y & time.x < time.y) | - (pred.x < pred.y & time.x > time.y)]$weight) - n_ties <- sum(dt[pred.x == pred.y]$weight) - - # Calculate concordance index - ci <- (n_concord + 0.5 * n_ties) / (n_concord + n_discord + n_ties) - # Check if the concordance index is valid if (!is.finite(ci)) ci <- NA_real_ - + return(ci) } diff --git a/R/MetricS4ConfusionMatrixMetrics.R b/R/MetricS4ConfusionMatrixMetrics.R index a2b22210..4d1cd305 100644 --- a/R/MetricS4ConfusionMatrixMetrics.R +++ b/R/MetricS4ConfusionMatrixMetrics.R @@ -5,7 +5,8 @@ NULL # familiarMetricCM ------------------------------------------------------------- setClass( "familiarMetricCM", - contains = "familiarMetric") + contains = "familiarMetric" +) @@ -14,7 +15,8 @@ setClass( "familiarMetricCMAveraging", contains = "familiarMetricCM", slots = list("averaging" = "character"), - prototype = list("averaging" = "macro")) + prototype = list("averaging" = "macro") +) # initialize ------------------------------------------------------------------- @@ -31,7 +33,8 @@ setMethod( x = metric, pattern = "_macro", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } else if (endsWith(x = metric, suffix = "_micro")) { .Object@averaging <- "micro" @@ -39,7 +42,8 @@ setMethod( x = metric, pattern = "_micro", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } else if (endsWith(x = metric, suffix = "_weighted")) { .Object@averaging <- "weighted" @@ -47,7 +51,8 @@ setMethod( x = metric, pattern = "_weighted", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } else { # Default setting. @@ -79,7 +84,9 @@ setClass( prototype = methods::prototype( name = "Accuracy", value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -89,9 +96,7 @@ setMethod( signature(metric = "familiarMetricAccuracy"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -109,7 +114,9 @@ setClass( prototype = methods::prototype( name = "Balanced Accuracy", value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -123,9 +130,7 @@ setMethod( # International Conference on Pattern Recognition 3121–3124 (2010).] # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -143,7 +148,9 @@ setClass( prototype = methods::prototype( name = "Balanced Error Rate", value_range = c(0.0, 1.0), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -153,9 +160,7 @@ setMethod( signature(metric = "familiarMetricBalancedErrorRate"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -173,7 +178,9 @@ setClass( prototype = methods::prototype( name = "Cohen's Kappa", value_range = c(-1.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -188,9 +195,7 @@ setMethod( # https://stats.stackexchange.com/questions/251165/cohens-kappa-with-three-categories-of-variable # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -198,7 +203,7 @@ setMethod( obs_agreement <- sum(cm$tp) / cm$n_samples # Agreement expected at random - rand_agreement <- sum((cm$tp + cm$fp) * (cm$tp + cm$fn)) / cm$n_samples^2 + rand_agreement <- sum((cm$tp + cm$fp) * (cm$tp + cm$fn)) / cm$n_samples^2.0 if (rand_agreement == 1.0 && obs_agreement == 1.0) { # Prevent division by zero for perfect predictions. @@ -219,7 +224,9 @@ setClass( prototype = methods::prototype( name = "F1 score", value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -229,9 +236,7 @@ setMethod( signature(metric = "familiarMetricF1Score"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -239,7 +244,8 @@ setMethod( cm <- ..aggregate_confusion_matrix( cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) # Compute score score <- 2.0 * cm$tp / (2.0 * cm$tp + cm$fp + cm$fn) @@ -249,7 +255,8 @@ setMethod( score = score, cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) return(score) } @@ -264,7 +271,9 @@ setClass( prototype = methods::prototype( name = "False Discovery Rate", value_range = c(0.0, 1.0), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -274,9 +283,7 @@ setMethod( signature(metric = "familiarMetricFDR"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -284,7 +291,8 @@ setMethod( cm <- ..aggregate_confusion_matrix( cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) # Compute score. score <- cm$fp / (cm$tp + cm$fp) @@ -294,8 +302,9 @@ setMethod( score = score, cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) - + outcome_type = metric@outcome_type + ) + return(score) } ) @@ -309,7 +318,9 @@ setClass( prototype = methods::prototype( name = "Informedness", value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -325,10 +336,8 @@ setMethod( # See equations 28, 42. # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) - + cm <- ..compute_confusion_matrix_data(data = data) + if (is.null(cm)) return(callNextMethod()) # Compute the score @@ -345,7 +354,9 @@ setClass( prototype = methods::prototype( name = "Markedness", value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -361,9 +372,7 @@ setMethod( # See equations 29, 43. # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -381,7 +390,9 @@ setClass( prototype = methods::prototype( name = "Matthews' Correlation Coefficient", value_range = c(-1.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -398,9 +409,7 @@ setMethod( # Mirrors scikit-learn implementation. # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -438,9 +447,7 @@ setMethod( signature(metric = "familiarMetricNPV"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -448,7 +455,8 @@ setMethod( cm <- ..aggregate_confusion_matrix( cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) # Compute NPV score <- cm$tn / (cm$tn + cm$fn) @@ -458,7 +466,8 @@ setMethod( score = score, cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) return(score) } @@ -473,8 +482,9 @@ setClass( prototype = methods::prototype( name = "Positive Predictive Value", value_range = c(0.0, 1.0), - higher_better = TRUE)) - + higher_better = TRUE + ) +) @@ -485,9 +495,7 @@ setMethod( signature(metric = "familiarMetricPPV"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -495,7 +503,8 @@ setMethod( cm <- ..aggregate_confusion_matrix( cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) # Compute PPV. score <- cm$tp / (cm$tp + cm$fp) @@ -505,8 +514,9 @@ setMethod( score = score, cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) - + outcome_type = metric@outcome_type + ) + return(score) } ) @@ -520,7 +530,9 @@ setClass( prototype = methods::prototype( name = "Sensitivity", value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -530,9 +542,7 @@ setMethod( signature(metric = "familiarMetricSensitivity"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -540,7 +550,8 @@ setMethod( cm <- ..aggregate_confusion_matrix( cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) # Compute sensitivity score <- cm$tp / (cm$tp + cm$fn) @@ -550,8 +561,9 @@ setMethod( score = score, cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) - + outcome_type = metric@outcome_type + ) + return(score) } ) @@ -565,7 +577,9 @@ setClass( prototype = methods::prototype( name = "Specificity", value_range = c(0.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -575,9 +589,7 @@ setMethod( signature(metric = "familiarMetricSpecificity"), function(metric, data, ...) { # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -585,8 +597,9 @@ setMethod( cm <- ..aggregate_confusion_matrix( cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) - + outcome_type = metric@outcome_type + ) + # Compute specificity. score <- cm$tn / (cm$tn + cm$fp) @@ -595,7 +608,8 @@ setMethod( score = score, cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) + outcome_type = metric@outcome_type + ) return(score) } @@ -609,7 +623,9 @@ setClass( prototype = methods::prototype( name = "Youden's J Statistic", value_range = c(-1.0, 1.0), - higher_better = TRUE)) + higher_better = TRUE + ) +) @@ -622,9 +638,7 @@ setMethod( # 3, 32–35 (1950).] # Compute data from the confusion metrics. - cm <- ..compute_confusion_matrix_data( - data = data, - outcome_type = metric@outcome_type) + cm <- ..compute_confusion_matrix_data(data = data) if (is.null(cm)) return(callNextMethod()) @@ -632,8 +646,9 @@ setMethod( cm <- ..aggregate_confusion_matrix( cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) - + outcome_type = metric@outcome_type + ) + # Compute Youden index. score <- cm$tp / (cm$tp + cm$fn) + cm$tn / (cm$tn + cm$fp) - 1.0 @@ -642,45 +657,49 @@ setMethod( score = score, cm = cm, averaging = metric@averaging, - outcome_type = metric@outcome_type) - + outcome_type = metric@outcome_type + ) + return(score) } ) -..compute_confusion_matrix_data <- function(data, outcome_type) { +..compute_confusion_matrix_data <- function(data) { # Suppress NOTES due to non-standard evaluation in data.table predicted_class <- NULL - + + if (is_empty(data)) return(NULL) + + if (!is(data, "predictionTableClassification")) { + ..error_data_not_prediction_table(data, "predictionTableClassification") + } + # Get the classes and number of classes in data. - outcome_classes <- get_outcome_class_levels( - data, - outcome_type = outcome_type) + outcome_classes <- get_outcome_class_levels(data) n_classes <- length(outcome_classes) + # Skip calculation if there are no other classes. + if (n_classes <= 1L) return(NULL) + # Remove any entries that lack valid predictions. - data <- remove_nonvalid_predictions( - prediction_table = data, - outcome_type = outcome_type) - + data <- remove_invalid_predictions(data) + # Remove any entries that lack observed values. - data <- remove_missing_outcomes( - data = data, - outcome_type = outcome_type) - + data <- filter_missing_outcome(data) if (is_empty(data)) return(NULL) - + + # Identify the outcome column. + outcome_column <- get_outcome_columns(x = data@outcome_type) + data <- .as_data_table(.complete(data)) + # Create empty scalars tp <- tn <- fp <- fn <- prevalence <- bias <- numeric(n_classes) # Total number of samples n_samples <- nrow(data) - # Get the outcome column. - outcome_column <- get_outcome_columns(outcome_type) - # Iterate over positive classes for (ii in seq_along(outcome_classes)) { # Determine true positives, true negatives, false positives and false negatives @@ -704,7 +723,8 @@ setMethod( "prevalence" = prevalence, "bias" = bias, "n_samples" = n_samples, - "n_classes" = n_classes)) + "n_classes" = n_classes + )) } @@ -713,14 +733,15 @@ setMethod( if (outcome_type == "binomial") { # Use second class as positive class return(list( - "tp" = cm$tp[2], - "tn" = cm$tn[2], - "fp" = cm$fp[2], - "fn" = cm$fn[2], + "tp" = cm$tp[2L], + "tn" = cm$tn[2L], + "fp" = cm$fp[2L], + "fn" = cm$fn[2L], "prevalence" = 1.0, "bias" = 1.0, "n_samples" = cm$n_samples, - "n_classes" = 1.0)) + "n_classes" = 1.0 + )) } else if (outcome_type == "multinomial") { if (averaging == "micro") { @@ -733,7 +754,8 @@ setMethod( "prevalence" = 1.0, "bias" = 1.0, "n_samples" = cm$n_classes * cm$n_samples, - "n_classes" = 1.0)) + "n_classes" = 1.0 + )) } else { # No changes are needed. @@ -769,7 +791,8 @@ setMethod( } else { ..error_reached_unreachable_code( - "..aggregate_confusion_matrix_score: encountered unknown averaging method.") + "..aggregate_confusion_matrix_score: encountered unknown averaging method." + ) } } @@ -793,7 +816,8 @@ setMethod( .get_available_ppv_metrics(), .get_available_sensitivity_metrics(), .get_available_specificity_metrics(), - .get_available_youden_metrics())) + .get_available_youden_metrics() + )) } @@ -821,7 +845,8 @@ setMethod( .get_available_fdr_metrics <- function() { return(c( paste0("fdr", c("", "_micro", "_macro", "_weighted")), - paste0("false_discovery_rate", c("", "_micro", "_macro", "_weighted")))) + paste0("false_discovery_rate", c("", "_micro", "_macro", "_weighted")) + )) } .get_available_informedness_metrics <- function() { @@ -839,14 +864,16 @@ setMethod( .get_available_npv_metrics <- function() { return(c( paste0("npv", c("", "_micro", "_macro", "_weighted")), - paste0("negative_predictive_value", c("", "_micro", "_macro", "_weighted")))) + paste0("negative_predictive_value", c("", "_micro", "_macro", "_weighted")) + )) } .get_available_ppv_metrics <- function() { return(c( paste0("ppv", c("", "_micro", "_macro", "_weighted")), paste0("positive_predictive_value", c("", "_micro", "_macro", "_weighted")), - paste0("precision", c("", "_micro", "_macro", "_weighted")))) + paste0("precision", c("", "_micro", "_macro", "_weighted")) + )) } .get_available_sensitivity_metrics <- function() { @@ -854,18 +881,21 @@ setMethod( paste0("sensitivity", c("", "_micro", "_macro", "_weighted")), paste0("recall", c("", "_micro", "_macro", "_weighted")), paste0("tpr", c("", "_micro", "_macro", "_weighted")), - paste0("true_positive_rate", c("", "_micro", "_macro", "_weighted")))) + paste0("true_positive_rate", c("", "_micro", "_macro", "_weighted")) + )) } .get_available_specificity_metrics <- function() { return(c( paste0("specificity", c("", "_micro", "_macro", "_weighted")), paste0("tnr", c("", "_micro", "_macro", "_weighted")), - paste0("true_negative_rate", c("", "_micro", "_macro", "_weighted")))) + paste0("true_negative_rate", c("", "_micro", "_macro", "_weighted")) + )) } .get_available_youden_metrics <- function() { return(c( paste0("youden_j", c("", "_micro", "_macro", "_weighted")), - paste0("youden_index", c("", "_micro", "_macro", "_weighted")))) + paste0("youden_index", c("", "_micro", "_macro", "_weighted")) + )) } diff --git a/R/MetricS4Regression.R b/R/MetricS4Regression.R index f60d5c16..7d63f326 100644 --- a/R/MetricS4Regression.R +++ b/R/MetricS4Regression.R @@ -8,7 +8,8 @@ setClass( "familiarMetricRegression", contains = "familiarMetric", slots = list("robust" = "character"), - prototype = list("robust" = "none")) + prototype = list("robust" = "none") +) @@ -26,7 +27,8 @@ setMethod( x = metric, pattern = "_trim", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } else if (endsWith(x = metric, suffix = "_winsor")) { .Object@robust <- "winsor" @@ -34,7 +36,8 @@ setMethod( x = metric, pattern = "_winsor", replacement = "", - fixed = TRUE) + fixed = TRUE + ) } else { # Default setting. @@ -53,7 +56,7 @@ setMethod( "is_available", signature(object = "familiarMetricRegression"), function(object, ...) { - return(object@outcome_type %in% c("count", "continuous")) + return(object@outcome_type %in% c("continuous")) } ) @@ -66,7 +69,9 @@ setClass( prototype = methods::prototype( name = "Mean Absolute Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -78,7 +83,8 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) @@ -97,7 +103,9 @@ setClass( prototype = methods::prototype( name = "Relative Absolute Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -109,7 +117,8 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) @@ -118,12 +127,14 @@ setMethod( denom <- sum(abs(y_mean - data$outcome)) # Check if denominator is not 0. - if (!denom == 0) { + if (!denom == 0.0) { # Denominator not 0 score <- nom / denom + } else if (nom == denom) { # Denominator and nominator are both 0. score <- 0.0 + } else { # Denominator = 0. Would be inf otherwise. return(callNextMethod()) @@ -142,7 +153,9 @@ setClass( prototype = methods::prototype( name = "Mean Log Absolute Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -154,7 +167,8 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) @@ -174,7 +188,9 @@ setClass( prototype = methods::prototype( name = "Mean Squared Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -186,12 +202,13 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) # Compute the mean squared error. - score <- sum((data$outcome - data$predicted_outcome)^2) / nrow(data) + score <- sum((data$outcome - data$predicted_outcome)^2.0) / nrow(data) return(score) } @@ -205,7 +222,9 @@ setClass( prototype = methods::prototype( name = "Relative Squared Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -217,22 +236,25 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) # Compute the mean squared error. y_mean <- mean(data$outcome) - nom <- sum((data$outcome - data$predicted_outcome)^2) - denom <- sum((y_mean - data$outcome)^2) + nom <- sum((data$outcome - data$predicted_outcome)^2.0) + denom <- sum((y_mean - data$outcome)^2.0) # Check if denominator is not 0. - if (!denom == 0) { + if (!denom == 0.0) { # Denominator not 0 score <- nom / denom + } else if (nom == denom) { # Denominator and nominator are both 0. score <- 0.0 + } else { # Denominator = 0. Would be inf otherwise. return(callNextMethod()) @@ -251,7 +273,9 @@ setClass( prototype = methods::prototype( name = "Mean Squared Log Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -263,12 +287,13 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) # Compute the mean squared log error. - score <- suppressWarnings(sum((log1p(data$outcome) - log1p(data$predicted_outcome))^2, na.rm = TRUE)) / nrow(data) + score <- suppressWarnings(sum((log1p(data$outcome) - log1p(data$predicted_outcome))^2.0, na.rm = TRUE)) / nrow(data) if (!is.finite(score)) return(callNextMethod()) @@ -285,7 +310,9 @@ setClass( prototype = methods::prototype( name = "Median Absolute Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -297,8 +324,9 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) - + data = data + ) + if (is_empty(data)) return(callNextMethod()) # Compute the median absolute error. @@ -317,7 +345,9 @@ setClass( prototype = methods::prototype( name = "Root Mean Square Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -329,12 +359,13 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) - + data = data + ) + if (is_empty(data)) return(callNextMethod()) # Compute the root mean square error. - score <- sqrt(sum((data$outcome - data$predicted_outcome)^2) / nrow(data)) + score <- sqrt(sum((data$outcome - data$predicted_outcome)^2.0) / nrow(data)) return(score) } @@ -349,7 +380,9 @@ setClass( prototype = methods::prototype( name = "Root Relative Squared Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -361,22 +394,25 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) # Compute the mean squared error. y_mean <- mean(data$outcome) - nom <- sum((data$outcome - data$predicted_outcome)^2) - denom <- sum((y_mean - data$outcome)^2) + nom <- sum((data$outcome - data$predicted_outcome)^2.0) + denom <- sum((y_mean - data$outcome)^2.0) # Check if denominator is not 0. - if (!denom == 0) { + if (!denom == 0.0) { # Denominator not 0 score <- sqrt(nom / denom) + } else if (nom == denom) { # Denominator and nominator are both 0. score <- 0.0 + } else { # Denominator = 0. Would be inf otherwise. return(callNextMethod()) @@ -395,7 +431,9 @@ setClass( prototype = methods::prototype( name = "Root Mean Square Log Error", value_range = c(0.0, Inf), - higher_better = FALSE)) + higher_better = FALSE + ) +) @@ -407,12 +445,13 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) # Compute the root mean square log error. - score <- sqrt(sum((log1p(data$outcome) - log1p(data$predicted_outcome))^2) / nrow(data)) + score <- sqrt(sum((log1p(data$outcome) - log1p(data$predicted_outcome))^2.0) / nrow(data)) if (!is.finite(score)) return(callNextMethod()) @@ -428,8 +467,10 @@ setClass( contains = "familiarMetricRegression", prototype = methods::prototype( name = "R squared", - value_range = c(-Inf, 1), - higher_better = TRUE)) + value_range = c(-Inf, 1.0), + higher_better = TRUE + ) +) @@ -441,21 +482,24 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) y_mean <- mean(data$outcome) - nom <- sum((data$outcome - data$predicted_outcome)^2) - denom <- sum((data$outcome - y_mean)^2) + nom <- sum((data$outcome - data$predicted_outcome)^2.0) + denom <- sum((data$outcome - y_mean)^2.0) # Check if denominator is not 0. - if (!denom == 0) { + if (!denom == 0.0) { # Denominator not 0 score <- 1.0 - nom / denom + } else if (nom == denom) { # Denominator and nominator are both 0. score <- 1.0 + } else { # Denominator = 0. Would be -inf otherwise. return(callNextMethod()) @@ -473,8 +517,10 @@ setClass( contains = "familiarMetricRegression", prototype = methods::prototype( name = "Explained Variance", - value_range = c(-Inf, 1), - higher_better = TRUE)) + value_range = c(-Inf, 1.0), + higher_better = TRUE + ) +) @@ -486,23 +532,26 @@ setMethod( # Prepare data for computing metric values. data <- ..process_data_for_regression_metrics( metric = metric, - data = data) + data = data + ) if (is_empty(data)) return(callNextMethod()) # Explained variance y_err_mean <- mean(data$outcome - data$predicted_outcome) y_mean <- mean(data$outcome) - nom <- sum((data$outcome - data$predicted_outcome - y_err_mean)^2) - denom <- sum((data$outcome - y_mean)^2) + nom <- sum((data$outcome - data$predicted_outcome - y_err_mean)^2.0) + denom <- sum((data$outcome - y_mean)^2.0) # Check if denominator is not 0. - if (!denom == 0) { + if (!denom == 0.0) { # Denominator not 0 score <- 1.0 - nom / denom + } else if (nom == denom) { # Denominator and nominator are both 0. score <- 1.0 + } else { # Denominator = 0. Would be -inf otherwise. return(callNextMethod()) @@ -521,18 +570,21 @@ setMethod( # Suppress NOTES due to non-standard evaluation in data.table outcome <- predicted_outcome <- NULL + if (is_empty(data)) return(NULL) + + if (!is(data, "predictionTableRegression")) { + ..error_data_not_prediction_table(data, "predictionTableRegression") + } + # Remove any entries that lack valid predictions. - data <- remove_nonvalid_predictions( - prediction_table = data, - outcome_type = metric@outcome_type) - + data <- remove_invalid_predictions(data) + # Remove any entries that lack observed values. - data <- remove_missing_outcomes( - data = data, - outcome_type = metric@outcome_type) - - if (is_empty(data)) return(data) - + data <- filter_missing_outcome(data) + if (is_empty(data)) return(NULL) + + data <- .as_data_table(data) + if (metric@robust == "trim") { # Compute absolute prediction error abs_error <- abs(data$outcome - data$predicted_outcome) @@ -540,11 +592,12 @@ setMethod( # Determine threshold for truncating the data. threshold <- stats::quantile( x = abs_error, - probs = 1 - fraction, - na.rm = TRUE) + probs = 1.0 - fraction, + na.rm = TRUE + ) # Set mask to identify instances that should be kept. - mask <- abs_error <= threshold[1] + mask <- abs_error <= threshold[1L] # Filter data to only include instances within the mask. data <- data[mask, ] @@ -556,17 +609,20 @@ setMethod( # Determine threshold for truncating the data. threshold <- stats::quantile( x = abs_error, - probs = 1 - fraction, - na.rm = TRUE) + probs = 1.0 - fraction, + na.rm = TRUE + ) # Set mask to identify instances that should be updated. - mask <- !(abs_error <= threshold[1]) + mask <- !(abs_error <= threshold[1L]) # Update data by winsorising outlier data. data[mask & outcome > predicted_outcome, "predicted_outcome" := outcome - threshold] data[mask & outcome < predicted_outcome, "predicted_outcome" := outcome + threshold] } + if (is_empty(data)) return(NULL) + return(data) } @@ -585,7 +641,8 @@ setMethod( .get_available_explained_variance_metrics(), .get_available_rse_metrics(), .get_available_rrse_metrics(), - .get_available_rae_metrics())) + .get_available_rae_metrics() + )) } .get_available_mae_metrics <- function() { diff --git a/R/ModelBuilding.R b/R/ModelBuilding.R deleted file mode 100644 index 4ab83cd7..00000000 --- a/R/ModelBuilding.R +++ /dev/null @@ -1,284 +0,0 @@ -run_model_development <- function( - cl, - project_list, - settings, - file_paths, - message_indent = 0L, - verbose = TRUE) { - # Model building - - # Check which data object is required for performing model building - mb_data_id <- .get_process_step_data_identifier( - project_info = project_list, - process_step = "mb") - - # Get runs - run_list <- .get_run_list( - iteration_list = project_list$iter_list, - data_id = mb_data_id) - - # Identify combinations of feature selection methods and learners - run_methods <- get_fs_learner_combinations(settings = settings) - - # Remove parallel clusters for model building in case these are not required. - cl_mb <- NULL - if (settings$mb$do_parallel) { - cl_mb <- cl - } - - # Create models by iterating over combination of feature selection methods and - # learners - for (iter_methods in run_methods) { - # Check which runs have been completed and skip if all methods were - # analysed. - iter_run_list <- add_model_data_to_run_list( - methods = iter_methods, - run_list = run_list, - project_list = project_list, - settings = settings, - file_paths = file_paths, - filter_existing = TRUE) - - # Skip if all learners were assessed - if (length(iter_run_list) == 0) next - - # Message - logger_message( - paste0( - "\nModel building: starting model building using \"", - iter_methods$learner, "\" learner, based on \"", - iter_methods$fs_method, "\" variable importance."), - indent = message_indent, - verbose = verbose - ) - - # Optimise hyperparameters of models used for model building - hpo_list <- run_hyperparameter_optimisation( - cl = cl, - project_list = project_list, - data_id = mb_data_id, - settings = settings, - file_paths = file_paths, - vimp_method = iter_methods$fs_method, - learner = iter_methods$learner, - message_indent = message_indent + 1L, - verbose = verbose) - - # Build models - fam_lapply_lb( - cl = cl_mb, - assign = "all", - X = iter_run_list, - FUN = build_model, - progress_bar = verbose, - hpo_list = hpo_list) - - logger_message( - paste0( - "Model building: model building using \"", - iter_methods$learner, "\" learner, based on \"", - iter_methods$fs_method, "\" variable importance, has been completed."), - indent = message_indent, - verbose = verbose - ) - } -} - - -build_model <- function(run, hpo_list) { - # Function for model building and data extraction - - # Load from the familiar or global environment - project_list <- get_project_list() - settings <- get_settings() - file_paths <- get_file_paths() - - # Data will be loaded at run time in .train - data <- methods::new("dataObject", - data = NULL, - preprocessing_level = "none", - outcome_type = settings$data$outcome_type, - delay_loading = TRUE, - perturb_level = tail(run$run_table, n = 1)$perturb_level, - load_validation = FALSE, - aggregate_on_load = FALSE, - outcome_info = create_outcome_info(settings = settings)) - - # Load feature_info_list - feature_info_list <- .get_feature_info_list(run = run) - - # Get hyper-parameters - hyperparameter_object <- .find_hyperparameters_for_run( - run = run, - hpo_list = hpo_list) - - # Read variable importance file and retrieve the variable importance table - # objects. - vimp_table_list <- .retrieve_feature_selection_data( - fs_method = run$fs_method, - project_list = project_list, - file_paths = file_paths - )[[run$fs_method]] - - # Collect all relevant variable importance - vimp_table_list <- collect_vimp_table( - x = vimp_table_list, - run_table = run$run_table) - - # Update using reference cluster table to ensure that the data are correct - # locally. - vimp_table_list <- update_vimp_table_to_reference( - x = vimp_table_list, - reference_cluster_table = .create_clustering_table( - feature_info_list = feature_info_list)) - - # Recluster the data according to the clustering table corresponding to the - # model. - vimp_table_list <- recluster_vimp_table(vimp_table_list) - - # Get feature ranks - vimp_table <- aggregate_vimp_table( - vimp_table_list, - aggregation_method = settings$fs$aggregation, - rank_threshold = settings$fs$aggr_rank_threshold) - - # Extract rank table. - rank_table <- get_vimp_table(vimp_table) - - # Create familiar model - fam_model <- methods::new("familiarModel", - outcome_type = settings$data$outcome_type, - learner = run$learner, - fs_method = run$fs_method, - run_table = run$run_table, - hyperparameters = hyperparameter_object@hyperparameters, - hyperparameter_data = hyperparameter_object@hyperparameter_data, - feature_info = feature_info_list, - outcome_info = .get_outcome_info(), - project_id = project_list$project_id, - settings = settings$eval) - - # Select features - fam_model <- set_signature( - object = fam_model, - rank_table = rank_table, - minimise_footprint = FALSE) - - # Add package version - fam_model <- add_package_version(object = fam_model) - - # Train model - fam_model <- .train( - object = fam_model, - data = data, - get_additional_info = TRUE) - - # Add novelty detector - fam_model <- .train_novelty_detector( - object = fam_model, - data = data, - detector = settings$mb$novelty_detector, - user_list = settings$mb$detector_parameters[[settings$mb$novelty_detector]]) - - # Add model name - fam_model <- set_object_name(fam_model) - - # Save model - save( - list = fam_model, - file = file_paths$mb_dir) -} - - - -add_model_data_to_run_list <- function( - methods, - run_list, - project_list, - settings, - file_paths, - filter_existing) { - # Suppress NOTES due to non-standard evaluation in data.table - data_id <- run_id <- NULL - - # Extract learner and fs_method from methods - fs_method <- methods$fs_method - learner <- methods$learner - - # Get table with data and run ids from run_list - run_data <- data.table::rbindlist(lapply( - run_list, - function(run) (tail(run$run_table, n = 1)))) - - # Construct file names - run_data[, "mb_file" := get_object_file_name( - learner = learner, - fs_method = fs_method, - project_id = project_list$project_id, - data_id = data_id, - run_id = run_id, - object_type = "familiarModel" - )] - - # Add file names and methods to run_list - run_list <- mapply( - function(run_list, file_path, fs_method, learner) { - return(c( - run_list, - list( - "mb_file" = file_path, - "fs_method" = fs_method, - "learner" = learner))) - }, - run_list, - run_data$mb_file, - MoreArgs = list( - "fs_method" = fs_method, - "learner" = learner), - SIMPLIFY = FALSE - ) - - # Filter runs corresponding to existing models from the run list - if (filter_existing == TRUE) { - # Find the model directory - mb_dir <- get_object_dir_path( - dir_path = file_paths$mb_dir, - object_type = "familiarModel", - learner = learner, - fs_method = fs_method) - - # Determine which files already exist in the model building directory - file_list <- list.files( - path = mb_dir, - pattern = paste0(project_list$project_id, "_", learner), - full.names = FALSE) - - # Select only those runs which have not been completed - run_list <- run_list[!run_data$mb_file %in% file_list] - } - - return(run_list) -} - - - -get_fs_learner_combinations <- function(settings) { - # Generate all combinations - combination_data <- data.table::as.data.table(expand.grid( - fs_method = settings$fs$fs_methods, - learner = settings$mb$learners, - KEEP.OUT.ATTRS = FALSE, - stringsAsFactors = FALSE)) - - # Parse methods to a list of lists - run_methods <- lapply( - seq_len(nrow(combination_data)), - function(ii, data) { - list( - "fs_method" = data$fs_method[ii], - "learner" = data$learner[ii]) - }, - data = combination_data) - - return(run_methods) -} diff --git a/R/Normalisation.R b/R/Normalisation.R index eb8eabf3..7fb1af7e 100644 --- a/R/Normalisation.R +++ b/R/Normalisation.R @@ -9,11 +9,14 @@ setClass( slots = list( "method" = "character", "batch" = "ANY", - "reason" = "ANY"), + "reason" = "ANY" + ), prototype = list( "method" = "none", "batch" = NULL, - "reason" = NULL)) + "reason" = NULL + ) +) @@ -24,11 +27,14 @@ setClass( slots = list( "batch" = "ANY", "shift" = "numeric", - "scale" = "numeric"), + "scale" = "numeric" + ), prototype = list( "batch" = NULL, "shift" = NA_real_, - "scale" = NA_real_)) + "scale" = NA_real_ + ) +) @@ -38,10 +44,13 @@ setClass( contains = "featureInfoParameters", slots = list( "batch" = "ANY", - "shift" = "numeric"), + "shift" = "numeric" + ), prototype = list( "batch" = NULL, - "shift" = NA_real_)) + "shift" = NA_real_ + ) +) @@ -50,7 +59,8 @@ setClass( "featureInfoParametersNormalisationStandardisation", contains = "featureInfoParametersNormalisationShiftScale", slots = list("method" = "character"), - prototype = list("method" = NA_character_)) + prototype = list("method" = NA_character_) +) @@ -59,7 +69,8 @@ setClass( "featureInfoParametersNormalisationQuantile", contains = "featureInfoParametersNormalisationShiftScale", slots = list("method" = "character"), - prototype = list("method" = NA_character_)) + prototype = list("method" = NA_character_) +) @@ -68,7 +79,8 @@ setClass( "featureInfoParametersNormalisationNormalisation", contains = "featureInfoParametersNormalisationShiftScale", slots = list("method" = "character"), - prototype = list("method" = NA_character_)) + prototype = list("method" = NA_character_) +) @@ -77,7 +89,8 @@ setClass( "featureInfoParametersNormalisationMeanCentering", contains = "featureInfoParametersNormalisationShift", slots = list("method" = "character"), - prototype = list("method" = NA_character_)) + prototype = list("method" = NA_character_) +) @@ -86,8 +99,10 @@ setClass( } .get_available_standardisation_normalisation_methods <- function() { - return(c("standardisation", "standardisation_trim", - "standardisation_winsor", "standardisation_robust")) + return(c( + "standardisation", "standardisation_trim", + "standardisation_winsor", "standardisation_robust" + )) } .get_available_quantile_normalisation_methods <- function() { @@ -108,31 +123,36 @@ setClass( if (type %in% c("none", "all")) { available_normalisation_method <- c( available_normalisation_method, - .get_available_none_normalisation_methods()) + .get_available_none_normalisation_methods() + ) } if (type %in% c("all", "standardisation")) { available_normalisation_method <- c( available_normalisation_method, - .get_available_standardisation_normalisation_methods()) + .get_available_standardisation_normalisation_methods() + ) } if (type %in% c("all", "quantile")) { available_normalisation_method <- c( available_normalisation_method, - .get_available_quantile_normalisation_methods()) + .get_available_quantile_normalisation_methods() + ) } if (type %in% c("all", "mean_centering")) { available_normalisation_method <- c( available_normalisation_method, - .get_available_mean_centering_normalisation_methods()) + .get_available_mean_centering_normalisation_methods() + ) } if (type %in% c("all", "normalisation")) { available_normalisation_method <- c( available_normalisation_method, - .get_available_normalisation_normalisation_methods()) + .get_available_normalisation_normalisation_methods() + ) } return(available_normalisation_method) @@ -147,7 +167,8 @@ create_normalisation_parameter_skeleton <- function( normalisation_method, normalisation_shift = NULL, normalisation_scale = NULL, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Creates a skeleton for the provided normalisation method. If # normalisation_shift and / or normalisation_scale are provided (typically # not), these values are updated as well. @@ -165,14 +186,16 @@ create_normalisation_parameter_skeleton <- function( .check_parameter_value_is_valid( x = normalisation_method, var_name = "normalisation_method", - values = .get_available_normalisation_methods()) + values = .get_available_normalisation_methods() + ) # Check that normalisation_shift is numeric. if (!is.null(normalisation_shift)) { .check_number_in_valid_range( x = normalisation_shift, var_name = "normalisation_shift", - range = c(-Inf, Inf)) + range = c(-Inf, Inf) + ) } # Check that normalisation_scale is numeric. @@ -180,7 +203,8 @@ create_normalisation_parameter_skeleton <- function( .check_number_in_valid_range( x = normalisation_scale, var_name = "normalisation_scale", - range = c(-Inf, Inf)) + range = c(-Inf, Inf) + ) } # Update familiar info objects with a feature normalisation skeleton. @@ -191,7 +215,8 @@ create_normalisation_parameter_skeleton <- function( batch = batch, shift = normalisation_shift, scale = normalisation_scale, - .override_existing = .override_existing) + .override_existing = .override_existing + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -210,7 +235,8 @@ create_normalisation_parameter_skeleton <- function( batch = NULL, shift = NULL, scale = NULL, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Check if normalisation data was already completed, and does not require # being determined anew. if (feature_info_complete(feature_info@normalisation_parameters) && !.override_existing) { @@ -225,7 +251,8 @@ create_normalisation_parameter_skeleton <- function( method = method, batch = batch, shift = shift, - scale = scale) + scale = scale + ) # Update normalisation_parameters slot. feature_info@normalisation_parameters <- object @@ -242,7 +269,8 @@ create_normalisation_parameter_skeleton <- function( method, batch = NULL, shift = NULL, - scale = NULL) { + scale = NULL +) { # This is the lowest level function for creating normalisation parameter # skeletons. @@ -250,12 +278,14 @@ create_normalisation_parameter_skeleton <- function( if (feature_type != "numeric") { object <- methods::new( "featureInfoParametersNormalisationNone", - reason = "not a numeric feature") + reason = "not a numeric feature" + ) } else if (!available) { object <- methods::new( "featureInfoParametersNormalisationNone", - reason = "feature was omitted prior to transformation") + reason = "feature was omitted prior to transformation" + ) } else if (method %in% .get_available_none_normalisation_methods()) { object <- methods::new("featureInfoParametersNormalisationNone") @@ -265,35 +295,42 @@ create_normalisation_parameter_skeleton <- function( "featureInfoParametersNormalisationStandardisation", "method" = method ) + } else if (method %in% .get_available_quantile_normalisation_methods()) { object <- methods::new( "featureInfoParametersNormalisationQuantile", "method" = method ) + } else if (method %in% .get_available_normalisation_normalisation_methods()) { object <- methods::new( "featureInfoParametersNormalisationNormalisation", "method" = method ) + } else if (method %in% .get_available_mean_centering_normalisation_methods()) { object <- methods::new( "featureInfoParametersNormalisationMeanCentering", "method" = method ) + } else if (method %in% .get_available_combat_parametric_normalisation_methods()) { object <- methods::new( "featureInfoParametersNormalisationParametricCombat", "method" = method ) + } else if (method %in% .get_available_combat_non_parametric_normalisation_methods()) { object <- methods::new( "featureInfoParametersNormalisationNonParametricCombat", "method" = method ) + } else { ..error_reached_unreachable_code(paste0( "..create_normalisation_parameter_skeleton: encountered an unknown ", - "normalisation method: ", paste_s(method))) + "normalisation method: ", paste_s(method) + )) } # Set the name of the object. @@ -304,11 +341,13 @@ create_normalisation_parameter_skeleton <- function( # Add shift and/or scale, when provided. if (!is.null(shift) || !is.null(scale)) { - object <- add_feature_info_parameters(object, + object <- add_feature_info_parameters( + object, data = NULL, batch = batch, shift = shift, - scale = scale) + scale = scale + ) } # Update the familiar version. @@ -323,7 +362,8 @@ add_normalisation_parameters <- function( cl = NULL, feature_info_list, data, - verbose = FALSE) { + verbose = FALSE +) { # Determine normalisation parameters and add them to the feature_info_list. # Find feature columns. @@ -333,7 +373,8 @@ add_normalisation_parameters <- function( if (!(setequal(feature_names, get_available_features(feature_info_list = feature_info_list)))) { ..error_reached_unreachable_code(paste0( "add_normalisation_parameters: features in data and the feature info list ", - "are expect to be the same, but were not.")) + "are expect to be the same, but were not." + )) } # Iterate over features. @@ -343,7 +384,8 @@ add_normalisation_parameters <- function( feature_info = feature_info_list[feature_names], data = data@data[, mget(feature_names)], progress_bar = verbose, - chopchop = TRUE) + chopchop = TRUE + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -358,11 +400,13 @@ add_normalisation_parameters <- function( .add_normalisation_parameters <- function( feature_info, - data) { + data +) { # Pass to underlying function that adds the feature info. object <- add_feature_info_parameters( object = feature_info@normalisation_parameters, - data = data) + data = data + ) # Update normalisation_parameters slot. feature_info@normalisation_parameters <- object @@ -395,12 +439,14 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationNone", - data = "NULL"), + data = "NULL" + ), function( object, data, batch = NULL, - ...) { + ... + ) { if (!is.null(batch)) object@batch <- batch @@ -415,13 +461,15 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShift", - data = "NULL"), + data = "NULL" + ), function( object, data, batch = NULL, shift = NULL, - ...) { + ... + ) { if (!is.null(batch)) { object@batch <- batch @@ -446,7 +494,8 @@ setMethod( object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, batch = batch, - method = "none") + method = "none" + ) object@reason <- "shift was NA or infinite" @@ -459,7 +508,8 @@ setMethod( object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, batch = batch, - method = "none") + method = "none" + ) object@reason <- "insufficient data to determine shift" @@ -473,7 +523,8 @@ setMethod( object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, batch = batch, - method = "none") + method = "none" + ) object@reason <- "shift was NA" @@ -484,7 +535,8 @@ setMethod( object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, batch = batch, - method = "none") + method = "none" + ) object@reason <- "shift could not be determined for an unknown reason" @@ -499,11 +551,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShift", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # This method is targeted when directly determining the normalisation # parameters. It is usually called from the child functions. @@ -526,13 +580,13 @@ setMethod( } # Check that at least three unique values are present. - if (length(unique(data)) <= 3) { + if (length(unique(data)) <= 3L) { return(add_feature_info_parameters(object = object, data = NULL)) } # For batch normalisation, check that at least five instances are present. if (!is.null(object@batch)) { - if (length(data) < 5) { + if (length(data) < 5L) { return(add_feature_info_parameters(object = object, data = NULL)) } } @@ -548,14 +602,16 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShiftScale", - data = "NULL"), + data = "NULL" + ), function( object, data, batch = NULL, shift = NULL, scale = NULL, - ...) { + ... + ) { if (!is.null(batch)) { object@batch <- batch } else if (!is.null(object@batch)) { @@ -581,7 +637,8 @@ setMethod( object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, batch = batch, - method = "none") + method = "none" + ) object@reason <- "shift or scale were NA or infinite" @@ -595,7 +652,8 @@ setMethod( object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, batch = batch, - method = "none") + method = "none" + ) object@reason <- "insufficient data to determine shift and scale" @@ -609,7 +667,8 @@ setMethod( object <- ..create_normalisation_parameter_skeleton( feature_name = object@name, batch = batch, - method = "none") + method = "none" + ) object@reason <- "shift or scale were NA" @@ -636,11 +695,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShiftScale", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # This method is targeted when directly determining the normalisation # parameters. It is usually called from the child functions. @@ -663,13 +724,13 @@ setMethod( } # Check that at least three unique values are present. - if (length(unique(data)) <= 3) { + if (length(unique(data)) <= 3L) { return(add_feature_info_parameters(object = object, data = NULL)) } # For batch normalisation, check that at least five instances are present. if (!is.null(object@batch)) { - if (length(data) < 5) { + if (length(data) < 5L) { return(add_feature_info_parameters(object = object, data = NULL)) } } @@ -685,16 +746,19 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationStandardisation", - data = "data.table"), + data = "data.table" + ), function( object, data, - ...) { + ... + ) { # Pass to non-data.table method. return(add_feature_info_parameters( object = object, data = data[[object@name]], - ...)) + ... + )) } ) @@ -705,11 +769,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationStandardisation", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # Check if all required parameters have been set. if (feature_info_complete(object)) return(object) @@ -736,6 +802,7 @@ setMethod( # Trimming and winsoring of input data. if (object@method %in% c("standardisation_trim")) { data <- trim(data, fraction = 0.05) + } else if (object@method %in% c("standardisation_winsor")) { data <- winsor(data, fraction = 0.05) } @@ -747,10 +814,11 @@ setMethod( shift <- robust_estimates$mu scale <- robust_estimates$sigma + } else { # Using conventional estimators. shift <- mean(data) - scale <- sqrt(sum((data - shift)^2) / length(data)) + scale <- sqrt(sum((data - shift)^2.0) / length(data)) } # Check for scales which are close to 0, or could not be computed. @@ -773,16 +841,19 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationQuantile", - data = "data.table"), + data = "data.table" + ), function( object, data, - ...) { + ... + ) { # Pass to non-data.table method. return(add_feature_info_parameters( object = object, data = data[[object@name]], - ...)) + ... + )) } ) @@ -793,11 +864,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationQuantile", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # Check if all required parameters have been set. if (feature_info_complete(object)) return(object) @@ -844,16 +917,19 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationNormalisation", - data = "data.table"), + data = "data.table" + ), function( object, data, - ...) { + ... + ) { # Pass to non-data.table method. return(add_feature_info_parameters( object = object, data = data[[object@name]], - ...)) + ... + )) } ) @@ -864,11 +940,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationNormalisation", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # Check if all required parameters have been set. if (feature_info_complete(object)) return(object) @@ -895,6 +973,7 @@ setMethod( # Trimming and winsoring of input data. if (object@method %in% c("normalisation_trim")) { data <- trim(data, fraction = 0.05) + } else if (object@method %in% c("normalisation_winsor")) { data <- winsor(data, fraction = 0.05) } @@ -926,16 +1005,19 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationMeanCentering", - data = "data.table"), + data = "data.table" + ), function( object, data, - ...) { + ... + ) { # Pass to non-data.table method. return(add_feature_info_parameters( object = object, data = data[[object@name]], - ...)) + ... + )) } ) @@ -946,11 +1028,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersNormalisationMeanCentering", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # Check if all required parameters have been set. if (feature_info_complete(object)) return(object) @@ -993,11 +1077,13 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShiftScale", - data = "data.table"), + data = "data.table" + ), function( object, data, - ...) { + ... + ) { # Pass to method with signature data="ANY" to perform the normalisation. y <- apply_feature_info_parameters(object = object, data[[object@name]], ...) @@ -1018,12 +1104,14 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShiftScale", - data = "ANY"), + data = "ANY" + ), function( object, data, invert = FALSE, - ...) { + ... + ) { if (invert) { # Invert normalisation by multiplying input x by the scale and adding the # shift. @@ -1044,11 +1132,13 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShift", - data = "data.table"), + data = "data.table" + ), function( object, data, - ...) { + ... + ) { # Pass to method with signature data="ANY" to perform the normalisation. y <- apply_feature_info_parameters(object = object, data[[object@name]], ...) @@ -1069,12 +1159,14 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersNormalisationShift", - data = "ANY"), + data = "ANY" + ), function( object, data, invert = FALSE, - ...) { + ... + ) { if (invert) { # Invert normalisation by adding the shift. return(data + object@shift) @@ -1112,8 +1204,8 @@ setMethod( # Output to certain range (if provided). if (!is.null(range)) { - y[y < range[1]] <- range[1] - y[y > range[2]] <- range[2] + y[y < range[1L]] <- range[1L] + y[y > range[2L]] <- range[2L] } return(y) @@ -1125,20 +1217,30 @@ setMethod( # Find a default range for normalised values during plotting. if (norm_method == "none") { return(c(NA, NA)) + } else if (norm_method == "mean_centering") { return(c(NA, NA)) + } else if (norm_method == "quantile") { return(c(-1.5, 0.0, 1.5)) - } else if (norm_method %in% c( - "standardisation", "standardisation_trim", "standardisation_winsor", "standardisation_robust")) { + + } else if ( + norm_method %in% c( + "standardisation", "standardisation_trim", + "standardisation_winsor", "standardisation_robust" + ) + ) { return(c(-3.0, 0.0, 3.0)) - } else if (norm_method %in% c( - "normalisation", "normalisation_trim", "normalisation_winsor")) { + } else if ( + norm_method %in% c("normalisation", "normalisation_trim", "normalisation_winsor") + ) { return(c(0.0, 1.0)) + } else { ..error_reached_unreachable_code(paste0( ".get_default_normalisation_range_for_plotting: unknown ", - "normalisation method: ", norm_method)) + "normalisation method: ", norm_method + )) } } @@ -1147,16 +1249,19 @@ setMethod( ..collect_and_aggregate_normalisation_info <- function( feature_info_list, instance_mask, - feature_name) { + feature_name +) { # Aggregate normalisation parameters. This function exists so that it can be # tested as part of a unit test. return(...collect_and_aggregate_normalisation_info( object_list = lapply( feature_info_list, - function(x) (x@normalisation_parameters)), + function(x) (x@normalisation_parameters) + ), instance_mask = instance_mask, - feature_name = feature_name)) + feature_name = feature_name + )) } @@ -1164,7 +1269,8 @@ setMethod( ...collect_and_aggregate_normalisation_info <- function( object_list, instance_mask, - feature_name) { + feature_name +) { # This is used to collect from a list of objects. It serves both to aggregate # data for the ensemble and when creating replacement data for batch # normalisation. @@ -1176,33 +1282,39 @@ setMethod( return(list( "parameters" = ..create_normalisation_parameter_skeleton( feature_name = feature_name, - method = "none"), - "instance_mask" = instance_mask)) + method = "none" + ), + "instance_mask" = instance_mask + )) } # Check the class of the transformation objects. - object_class <- sapply(object_list, function(x) (class(x)[1])) + object_class <- sapply(object_list, function(x) (class(x)[1L])) # Determine if there are any objects that are not NULL or # featureInfoParametersNormalisationNone. - if (all(object_class[instance_mask] %in% - c("NULL", "featureInfoParametersNormalisationNone"))) { + if ( + all(object_class[instance_mask] %in% c("NULL", "featureInfoParametersNormalisationNone")) + ) { return(list( "parameters" = ..create_normalisation_parameter_skeleton( feature_name = feature_name, - method = "none"), - "instance_mask" = instance_mask)) + method = "none" + ), + "instance_mask" = instance_mask + )) } # For the remaining objects, check which class occurs most. class_table <- data.table::data.table( - "class" = object_class[instance_mask])[, list("n" = .N), by = "class"] + "class" = object_class[instance_mask] + )[, list("n" = .N), by = "class"] # Drop NULL and none transformations. class_table <- class_table[!class %in% c("NULL", "featureInfoParametersNormalisationNone")] # Select the object that occurs most often. - most_common_class <- class_table[n == max(class_table$n), ]$class[1] + most_common_class <- class_table[n == max(class_table$n), ]$class[1L] # Update the instance mask. instance_mask <- instance_mask & object_class == most_common_class @@ -1223,7 +1335,7 @@ setMethod( selected_scale <- stats::median(all_scale) # Identify the first method -- its not that crucial. - selected_method <- sapply(object_list[instance_mask], function(x) (x@method))[1] + selected_method <- sapply(object_list[instance_mask], function(x) (x@method))[1L] } else if (most_common_class %in% c("featureInfoParametersNormalisationMeanCentering")) { # Aggregate shift values, and select median value. @@ -1231,12 +1343,13 @@ setMethod( selected_shift <- stats::median(all_shift) # Identify the first method -- its not that crucial. - selected_method <- sapply(object_list[instance_mask], function(x) (x@method))[1] + selected_method <- sapply(object_list[instance_mask], function(x) (x@method))[1L] } else { ..error_reached_unreachable_code(paste0( "..collect_and_aggregate_normalisation_info: encountered ", - "an unknown class of objects: ", paste_s(most_common_class))) + "an unknown class of objects: ", paste_s(most_common_class) + )) } return(list( @@ -1244,6 +1357,8 @@ setMethod( feature_name = feature_name, method = unname(selected_method), shift = unname(selected_shift), - scale = unname(selected_scale)), - "instance_mask" = instance_mask)) + scale = unname(selected_scale) + ), + "instance_mask" = instance_mask + )) } diff --git a/R/NoveltyDetectorMain.R b/R/NoveltyDetectorMain.R index c91e4f6e..cebbbdd3 100644 --- a/R/NoveltyDetectorMain.R +++ b/R/NoveltyDetectorMain.R @@ -1,6 +1,5 @@ #' @include FamiliarS4Generics.R #' @include FamiliarS4Classes.R -#' @include NoveltyDetectorS4IsolationTree.R NULL @@ -32,11 +31,13 @@ setMethod( .get_detector_hyperparameters <- function( data, detector, - names_only = FALSE) { + names_only = FALSE +) { # Create familiarNoveltyDetector fam_detector <- methods::new( "familiarNoveltyDetector", - learner = detector) + learner = detector + ) # Set up the specific model. fam_detector <- promote_detector(object = fam_detector) @@ -44,7 +45,8 @@ setMethod( # Model hyperparameters detector_hyperparameters <- get_default_hyperparameters( object = fam_detector, - data = data) + data = data + ) # Extract names from parameter list if (names_only) detector_hyperparameters <- names(detector_hyperparameters) @@ -58,7 +60,8 @@ setMethod( # Create familiarNoveltyDetector fam_detector <- methods::new( "familiarNoveltyDetector", - learner = detector) + learner = detector + ) # Set up the specific novelty detector fam_detector <- promote_detector(fam_detector) @@ -69,10 +72,14 @@ setMethod( if (as_flag) return(detector_available) # Check if the familiar model has been successfully promoted. - if (!is_subclass(class(fam_detector)[1], "familiarNoveltyDetector")) { - stop(paste0( - detector, " is not a valid novelty detector. ", - "Please check the documentation for available novelty detectors.")) + if (!is_subclass(class(fam_detector)[1L], "familiarNoveltyDetector")) { + ..error( + paste0( + detector, " is not a valid novelty detector. ", + "Please check the documentation for available novelty detectors." + ), + error_class = "input_argument_error" + ) } # Check that the required package can be loaded. diff --git a/R/NoveltyDetectorS4IsolationTree.R b/R/NoveltyDetectorS4IsolationTree.R index 96b80ddd..7f06ee83 100644 --- a/R/NoveltyDetectorS4IsolationTree.R +++ b/R/NoveltyDetectorS4IsolationTree.R @@ -5,7 +5,8 @@ NULL # familiarIsolationForest ------------------------------------------------------ setClass( "familiarIsolationForest", - contains = "familiarNoveltyDetector") + contains = "familiarNoveltyDetector" +) # initialize ------------------------------------------------------------------- @@ -41,7 +42,11 @@ setMethod( setMethod( "get_default_hyperparameters", signature(object = "familiarIsolationForest"), - function(object, data = NULL, ...) { + function( + object, + data = NULL, + ... + ) { # Initialise list and declare hyperparameter entries. param <- list() param$n_tree <- list() @@ -63,7 +68,7 @@ setMethod( # number of trees ---------------------------------------------------------- # We limit the number of trees to limit memory footprint. - default_n_trees <- log2(max(c(64, ceiling(sqrt(n_samples))))) + default_n_trees <- log2(max(c(64L, ceiling(sqrt(n_samples))))) # Note that the number of trees is defined in powers of 2, based on Oshiro, # T. M., Perez, P. S., & Baranauskas, J. A. (2012, July). How many trees in @@ -71,15 +76,16 @@ setMethod( param$n_tree <- .set_hyperparameter( default = default_n_trees, type = "integer", - range = c(4, 10), - valid_range = c(0, Inf), - randomise = FALSE) + range = c(4L, 10L), + valid_range = c(0L, Inf), + randomise = FALSE + ) # sample size -------------------------------------------------------------- # We limit the number of samples in each tree to limit memory footprint. - default_sample_size <- max(c(128, ceiling(sqrt(n_samples)))) + default_sample_size <- max(c(128L, ceiling(sqrt(n_samples)))) if (n_samples < default_sample_size) default_sample_size <- n_samples # Express as fraction. @@ -90,13 +96,14 @@ setMethod( param$sample_size <- .set_hyperparameter( default = default_sample_size, type = "numeric", - range = c(2 / n_samples, 1.0), - valid_range = c(0, 1), - randomise = FALSE) + range = c(2.0 / n_samples, 1.0), + valid_range = c(0.0, 1.0), + randomise = FALSE + ) # number of candidate features selected at node ---------------------------- - default_m_try <- 3 / n_features + default_m_try <- 3.0 / n_features if (default_m_try > 1.0) default_m_try <- 1.0 # Note that the number of features is here noted as a fraction, but is used @@ -106,41 +113,44 @@ setMethod( default = default_m_try, type = "numeric", range = c(0.0, 1.0), - randomise = FALSE) + randomise = FALSE + ) # maximum tree depth ------------------------------------------------------- - default_tree_depth <- ceiling(log2(default_sample_size * n_samples)) - if (default_tree_depth < 1) default_tree_depth <- 1 + default_tree_depth <- as.integer(ceiling(log2(default_sample_size * n_samples))) + if (default_tree_depth < 1L) default_tree_depth <- 1L # Determines the depth trees are allowed to grow to. Larger depths increase # the risk of overfitting. param$tree_depth <- .set_hyperparameter( default = default_tree_depth, type = "integer", - range = c(1, 10), - valid_range = c(1, Inf), - randomise = FALSE) + range = c(1L, 10L), + valid_range = c(1L, Inf), + randomise = FALSE + ) # number of splitting dimensions ------------------------------------------- # Switch between extended and conventional isolation trees. if (object@learner %in% c("isolation_forest", "extended_isolation_forest")) { - default_n_dim <- 3 + default_n_dim <- 3L } else if (object@learner %in% c("simple_isolation_forest")) { - default_n_dim <- 1 + default_n_dim <- 1L } # The number of splitting dimensions cannot be larger than the number of # features. - if (default_n_dim > n_features && n_features > 0) default_n_dim <- n_features + if (default_n_dim > n_features && n_features > 0L) default_n_dim <- n_features param$n_dim <- .set_hyperparameter( default = default_n_dim, type = "integer", - range = c(1, 3), - valid_range = c(1, Inf), - randomise = FALSE) + range = c(1L, 3L), + valid_range = c(1L, Inf), + randomise = FALSE + ) return(param) } @@ -153,7 +163,8 @@ setMethod( "..train", signature( object = "familiarIsolationForest", - data = "dataObject"), + data = "dataObject" + ), function(object, data, ...) { # Check if the training data is ok. if (has_bad_training_data(object = object, data = data)) return(callNextMethod()) @@ -172,25 +183,34 @@ setMethod( data@data[[current_feature]] <- factor( x = data@data[[current_feature]], levels = levels(data@data[[current_feature]]), - ordered = FALSE) + ordered = FALSE + ) } - + + # Check that the current ndim parameter is not larger than the number of + # features. + features <- get_feature_columns(data) + if (object@hyperparameters$n_dim > length(features)) { + object@hyperparameters$n_dim <- length(features) + } + # Extract hyperparameters from the object. param <- object@hyperparameters - + # Create an isolation forest. Note that in addition to specifying the number # of trees and the number of samples assessed for each tree, missing_action # is set to "fail" -- this decreases model footprint and is not necessary as # familiar has its own imputation routines. detector <- isotree::isolation.forest( - data = data@data[, mget(get_feature_columns(data))], + data = data@data[, mget(features)], sample_size = ceiling(param$sample_size * nrow(data@data)), - ntrees = ceiling(2^(param$n_tree)), + ntrees = as.integer(ceiling(2.0^(param$n_tree))), ndim = param$n_dim, - ntry = max(c(1, ceiling(param$m_try * get_n_features(x = data)))), + ntry = max(c(1L, as.integer(ceiling(param$m_try * length(features))))), max_depth = param$tree_depth, nthreads = 1L, - missing_action = "fail") + missing_action = "fail" + ) # Add model object@model <- detector @@ -209,8 +229,14 @@ setMethod( "..predict", signature( object = "familiarIsolationForest", - data = "dataObject"), - function(object, data, type = "novelty", ...) { + data = "dataObject" + ), + function( + object, + data, + type = "novelty", + ... + ) { # Check that required packages are loaded and installed. require_package(object, "predict") @@ -220,28 +246,29 @@ setMethod( # Check if the data is empty. if (is_empty(data)) return(callNextMethod()) - # Get a placeholder prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "novelty") - # Find and replace ordered features. ordered_features <- colnames(data@data)[sapply(data@data, is.ordered)] for (current_feature in ordered_features) { data@data[[current_feature]] <- factor( x = data@data[[current_feature]], levels = levels(data@data[[current_feature]]), - ordered = FALSE) + ordered = FALSE + ) } # Find novelty values. novelty_values <- predict( object = object@model, - newdata = data@data) - - # Store the novelty values in the table. - prediction_table[, "novelty" := novelty_values] + newdata = data@data, + nthreads = 1L + ) + + prediction_table <- as_prediction_table( + x = novelty_values, + type = "novelty", + data = data, + model_object = object + ) return(prediction_table) } @@ -272,12 +299,14 @@ setMethod( "has_bad_training_data", signature( object = "familiarNoveltyDetector", - data = "dataObject"), + data = "dataObject" + ), function( object, data, allow_no_features = FALSE, - ...) { + ... + ) { # Checks the data for consistency and usability. Any errors are passed as # attributes @@ -285,10 +314,11 @@ setMethod( return_value <- callNextMethod() if (return_value) return(return_value) - if (nrow(data@data) < 3) { + if (nrow(data@data) < 3L) { return_value <- TRUE attr(return_value, "error") <- paste0( - "Too few samples were available to train the isolation forest.") + "Too few samples were available to train the isolation forest." + ) return(return_value) } diff --git a/R/NoveltyDetectorS4NoneNoveltyDetector.R b/R/NoveltyDetectorS4NoneNoveltyDetector.R index fc4763af..2c5d04d4 100644 --- a/R/NoveltyDetectorS4NoneNoveltyDetector.R +++ b/R/NoveltyDetectorS4NoneNoveltyDetector.R @@ -6,7 +6,8 @@ NULL # familiarNoneNoveltyDetector -------------------------------------------------- setClass( "familiarNoneNoveltyDetector", - contains = "familiarNoveltyDetector") + contains = "familiarNoveltyDetector" +) diff --git a/R/OutcomeInfo.R b/R/OutcomeInfo.R index d027b89a..5794140e 100644 --- a/R/OutcomeInfo.R +++ b/R/OutcomeInfo.R @@ -18,7 +18,7 @@ create_outcome_info <- function(settings) { outcome_info@ordered <- FALSE # Set reference level of the outcome - outcome_info@reference <- settings$data$class_levels[1] + outcome_info@reference <- settings$data$class_levels[1L] } if (outcome_info@outcome_type %in% c("survival", "competing_risk")) { @@ -37,50 +37,159 @@ create_outcome_info <- function(settings) { outcome_info@competing_risk <- as.character(settings$data$competing_risk_indicator) } + # Add familiar version. + outcome_info <- add_package_version(outcome_info) + return(outcome_info) } +# .create_outcome_info (model, ensemble) --------------------------------------- +setMethod( + ".create_outcome_info", + signature(object = "familiarModelUnion"), + function(object, ...) { + return(object@outcome_info) + } +) -create_outcome_info_from_data <- function(data) { - # This is typically an outcomeInfo object created at runtime, without access - # to outcome_info in the global backend, or attached to an object. - - outcome_info <- methods::new("outcomeInfo", - name = character(0L), - outcome_type = data@outcome_type, - outcome_column = get_outcome_columns(x = data)) - - if (outcome_info@outcome_type %in% c("binomial", "multinomial")) { - # Set class levels - outcome_info@levels <- get_outcome_class_levels(x = data) - - # Set flag indicating that the outcome is ordinal (currently not enabled) - outcome_info@ordered <- is.ordered(data@data[[outcome_info@outcome_column]]) - # Set reference level of the outcome - outcome_info@reference <- outcome_info@levels[1] +# .create_outcome_info (data object) ------------------------------------------- +setMethod( + ".create_outcome_info", + signature(object = "dataObject"), + function(object, ...) { + + outcome_info <- methods::new( + "outcomeInfo", + name = character(0L), + outcome_type = object@outcome_type, + outcome_column = get_outcome_columns(x = object) + ) + + if (outcome_info@outcome_type %in% c("binomial", "multinomial")) { + # Set class levels + outcome_info@levels <- get_outcome_class_levels(x = object) + + # Set flag indicating that the outcome is ordinal (currently not enabled) + outcome_info@ordered <- is.ordered(object@data[[outcome_info@outcome_column]]) + + # Set reference level of the outcome + outcome_info@reference <- outcome_info@levels[1L] + } + + if (outcome_info@outcome_type %in% c("survival", "competing_risk")) { + # Set maximum time + outcome_info@time <- Inf + + # Set indicator for censoring + outcome_info@censored <- "0" + + # Set indicator for events + outcome_info@event <- "1" + } + + if (outcome_info@outcome_type %in% c("competing_risk")) { + # Set indicator for competing risks + outcome_info@competing_risk <- as.character(setdiff( + unique_na(object@data[[outcome_info@outcome_column[2L]]]), c(0L, 1L) + )) + } + + # Add familiar version. + outcome_info <- add_package_version(outcome_info) + + return(outcome_info) } +) - if (outcome_info@outcome_type %in% c("survival", "competing_risk")) { - # Set maximum time - outcome_info@time <- Inf - # Set indicator for censoring - outcome_info@censored <- "0" - # Set indicator for events - outcome_info@event <- "1" +# .create_outcome_info (data.table) -------------------------------------------- +setMethod( + ".create_outcome_info", + signature(object = "data.table"), + function(object, outcome_type, ...) { + outcome_info <- methods::new( + "outcomeInfo", + name = character(0L), + outcome_type = outcome_type, + outcome_column = get_outcome_columns(outcome_type = outcome_type) + ) + + if (outcome_info@outcome_type %in% c("binomial", "multinomial")) { + # Set class levels + outcome_info@levels <- get_outcome_class_levels(x = object, outcome_type = outcome_info@outcome_type) + + # Set flag indicating that the outcome is ordinal (currently not enabled) + outcome_info@ordered <- is.ordered(object[[outcome_info@outcome_column]]) + + # Set reference level of the outcome + outcome_info@reference <- outcome_info@levels[1L] + } + + if (outcome_info@outcome_type %in% c("survival", "competing_risk")) { + # Set maximum time + outcome_info@time <- Inf + + # Set indicator for censoring + outcome_info@censored <- "0" + + # Set indicator for events + outcome_info@event <- "1" + } + + if (outcome_info@outcome_type %in% c("competing_risk")) { + # Set indicator for competing risks + outcome_info@competing_risk <- as.character(setdiff( + unique_na(object[[outcome_info@outcome_column[2L]]]), c(0L, 1L) + )) + } + + # Add familiar version. + outcome_info <- add_package_version(outcome_info) + + return(outcome_info) } +) - if (outcome_info@outcome_type %in% c("competing_risk")) { - # Set indicator for competing risks - outcome_info@competing_risk <- as.character(setdiff( - unique_na(data@data[[outcome_info@outcome_column[2]]]), c(0, 1))) - } - return(outcome_info) -} +# .create_outcome_info (prediction table) -------------------------------------- +setMethod( + ".create_outcome_info", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + outcome_info <- methods::new( + "outcomeInfo", + name = character(0L), + outcome_type = object@outcome_type, + outcome_column = get_outcome_columns(object@outcome_type) + ) + + if (.hasSlot(object, "classes")) { + outcome_info@levels <- object@classes + outcome_info@ordered <- is.ordered(object@classes) + outcome_info@reference <- outcome_info@levels[1L] + } + + if (.hasSlot(object, "time")) { + outcome_info@time <- object@time + } + + if (.hasSlot(object, "event")) { + outcome_info@event <- object@event + } + + if (.hasSlot(object, "censored")) { + outcome_info@censored <- object@censored + } + + # Add familiar version. + outcome_info <- add_package_version(outcome_info) + + return(outcome_info) + } +) @@ -99,12 +208,12 @@ get_outcome_info_from_backend <- function() { } else if (exists("outcome_info", where = .GlobalEnv)) { data_env <- .GlobalEnv } else { - stop("The outcomeInfo object was not found in backend environment.") + ..error("The outcomeInfo object was not found in backend environment.") } } else if (exists("outcome_info", where = .GlobalEnv)) { data_env <- .GlobalEnv } else { - stop("The outcomeInfo object was not found in backend environment.") + ..error("The outcomeInfo object was not found in backend environment.") } return(get("outcome_info", envir = data_env)) @@ -128,7 +237,8 @@ get_outcome_info_from_backend <- function() { # Second attempt to get from backend outcome_info <- tryCatch( get_outcome_info_from_backend(), - error = identity) + error = identity + ) if (!inherits(outcome_info, "error")) { return(outcome_info) @@ -137,7 +247,8 @@ get_outcome_info_from_backend <- function() { # Third, attempt to infer from settings. settings <- tryCatch( get_settings(), - error = identity) + error = identity + ) if (!inherits(settings, "error")) { return(create_outcome_info(settings = settings)) @@ -145,11 +256,11 @@ get_outcome_info_from_backend <- function() { # Finally, attempt to infer from dataObject if (inherits(x, "dataObject")) { - return(create_outcome_info_from_data(data = x)) + return(.create_outcome_info(x)) } if (is.null(outcome_info)) { - stop("The requested outcomeInfo object could not be read or created on the fly.") + ..error("The requested outcomeInfo object could not be read or created on the fly.") } } @@ -160,8 +271,12 @@ get_outcome_info_from_backend <- function() { min <- Q1 <- median <- Q3 <- max <- count <- incidence <- NULL survival_probability <- survival_probability <- NULL + # Remove empty elements from x. + x <- x[!sapply(x, is.null)] + if (length(x) == 0L) return(NULL) + # Copy the first outcome info object - outcome_info <- x[[1]] + outcome_info <- x[[1L]] # Find distribution items distribution_items <- names(outcome_info@distribution) @@ -179,7 +294,8 @@ get_outcome_info_from_backend <- function() { function(outcome_info_object, item) { outcome_info_object@distribution[[item]] }, - item = item) + item = item + ) # Combine all the data.tables fivenum_values <- data.table::rbindlist(fivenum_values) @@ -205,7 +321,8 @@ get_outcome_info_from_backend <- function() { function(outcome_info_object, item) { outcome_info_object@distribution[[item]] }, - item = item) + item = item + ) # Combine all the data.tables frequency_values <- data.table::rbindlist(frequency_values) @@ -222,7 +339,8 @@ get_outcome_info_from_backend <- function() { function(outcome_info_object, item) { outcome_info_object@distribution[[item]]$time }, - item = item)))) + item = item + )))) # Interpolate at the unique times. incidence_table <- lapply( @@ -234,7 +352,7 @@ get_outcome_info_from_backend <- function() { } # Check that there is at least unique times. - if (data.table::uniqueN(outcome_info_object@distribution[[item]]$time) < 2) { + if (data.table::uniqueN(outcome_info_object@distribution[[item]]$time) < 2L) { return(NULL) } @@ -244,16 +362,18 @@ get_outcome_info_from_backend <- function() { y = outcome_info_object@distribution[[item]][[item]], xout = unique_times, method = "linear", - rule = 2, + rule = 2L, yleft = 0.0 )$y return(data.table::data.table( "time" = unique_times, - "incidence" = incidence)) + "incidence" = incidence + )) }, item = item, - unique_times = unique_times) + unique_times = unique_times + ) # Aggregate the incidence table. incidence_table <- data.table::rbindlist(incidence_table) @@ -265,7 +385,8 @@ get_outcome_info_from_backend <- function() { data.table::setnames( x = incidence_table, old = "incidence", - new = item) + new = item + ) # Add to list distr_list[[item]] <- incidence_table @@ -277,7 +398,8 @@ get_outcome_info_from_backend <- function() { function(outcome_info_object, item) { outcome_info_object@distribution[[item]]$time }, - item = item)))) + item = item + )))) # Interpolate at the unique times. survival_table <- lapply( @@ -289,7 +411,7 @@ get_outcome_info_from_backend <- function() { } # Check that there is at least unique times. - if (data.table::uniqueN(outcome_info_object@distribution[[item]]$time) < 2) { + if (data.table::uniqueN(outcome_info_object@distribution[[item]]$time) < 2L) { return(NULL) } @@ -299,13 +421,14 @@ get_outcome_info_from_backend <- function() { y = outcome_info_object@distribution[[item]][[item]], xout = unique_times, method = "linear", - rule = 2, + rule = 2L, yleft = 1.0 )$y return(data.table::data.table( "time" = unique_times, - "survival_probability" = survival_probability)) + "survival_probability" = survival_probability + )) }, item = item, unique_times = unique_times @@ -315,22 +438,27 @@ get_outcome_info_from_backend <- function() { survival_table <- data.table::rbindlist(survival_table) # Compute the mean survival prob by each time point. - survival_table <- survival_table[, list( - "survival_probability" = mean(survival_probability)), - by = "time"] + survival_table <- survival_table[ + , + list("survival_probability" = mean(survival_probability)), + by = "time" + ] # Update the column name. data.table::setnames( x = survival_table, old = "survival_probability", - new = item) + new = item + ) # Add to list distr_list[[item]] <- survival_table + } else { # Find mean value distr_list[[item]] <- mean(unlist(extract_from_slot( - x, "distribution", item, na.rm = TRUE))) + x, "distribution", item, na.rm = TRUE + ))) } } @@ -343,15 +471,18 @@ get_outcome_info_from_backend <- function() { transform_method <- get_mode(extract_from_slot( object_list = x, slot_name = "transformation_parameters", - slot_element = "transform_method")) + slot_element = "transform_method" + )) transform_lambda <- get_mode(extract_from_slot( object_list = x, slot_name = "transformation_parameters", - slot_element = "transform_lambda")) + slot_element = "transform_lambda" + )) outcome_info@transformation_parameters <- list( "transform_method" = transform_method, - "transform_lambda" = transform_lambda) + "transform_lambda" = transform_lambda + ) } # Update normalisation parameters @@ -359,20 +490,24 @@ get_outcome_info_from_backend <- function() { normalisation_method <- get_mode(extract_from_slot( object_list = x, slot_name = "normalisation_parameters", - slot_element = "norm_method")) + slot_element = "norm_method" + )) normalisation_shift <- mean(extract_from_slot( object_list = x, slot_name = "normalisation_parameters", - slot_element = "norm_shift")) + slot_element = "norm_shift" + )) normalisation_scale <- mean(extract_from_slot( object_list = x, slot_name = "normalisation_parameters", - slot_element = "norm_scale")) + slot_element = "norm_scale" + )) outcome_info@normalisation_parameters <- list( "norm_method" = normalisation_method, "norm_shift" = normalisation_shift, - "norm_scale" = normalisation_scale) + "norm_scale" = normalisation_scale + ) } return(outcome_info) @@ -395,7 +530,8 @@ get_outcome_info_from_backend <- function() { # Find outcome data x <- data.table::copy(unique( data@data, - by = get_id_columns(id_depth = "series"))) + by = get_id_columns(id_depth = "series") + )) if (object@outcome_type %in% c("binomial", "multinomial")) { # Number of samples @@ -404,7 +540,7 @@ get_outcome_info_from_backend <- function() { # Number of instances for each class distr_list[["frequency"]] <- x[, list("count" = .N), by = "outcome"] - } else if (object@outcome_type %in% c("continuous", "count")) { + } else if (object@outcome_type %in% c("continuous")) { # Number of samples distr_list[["n"]] <- nrow(x) @@ -421,48 +557,59 @@ get_outcome_info_from_backend <- function() { surv_group <- data.table::copy(x) # Count events and censoring at each time point. - surv_group <- surv_group[, list( - "event" = sum(outcome_event == 1), - "censored" = sum(outcome_event == 0), - "competing" = sum(outcome_event > 1)), - by = "outcome_time" + surv_group <- surv_group[ + , + list( + "event" = sum(outcome_event == 1L), + "censored" = sum(outcome_event == 0L), + "competing" = sum(outcome_event > 1L) + ), + by = "outcome_time" ][order(outcome_time)] # Add group sizes at the start of each interval. surv_group[, "n" := nrow(x) - data.table::shift( cumsum(event + censored + competing), - n = 1, - fill = 0, - type = "lag")] + n = 1L, + fill = 0L, + type = "lag" + )] # Compute the incidence and censoring rates in the interval surv_group[, ":="( "interval_survival" = 1.0 - (event + competing) / n, "interval_incidence_rate" = event / n, - "interval_non_censoring_rate" = 1.0 - censored / n)] + "interval_non_censoring_rate" = 1.0 - censored / n + )] # Compute the Kaplan-Meier survival estimator and censoring estimator. surv_group[, ":="( "survival_probability" = cumprod(interval_survival), - "cumulative_censoring" = 1.0 - cumprod(interval_non_censoring_rate))] + "cumulative_censoring" = 1.0 - cumprod(interval_non_censoring_rate) + )] # Compute cumulative incidence and censoring rates. - surv_group[, ":="( - "cumulative_incidence" = cumsum(data.table::shift( + surv_group[ + , + ":="("cumulative_incidence" = cumsum(data.table::shift( survival_probability, n = 1L, fill = 1.0, - type = "lag") * interval_incidence_rate))] + type = "lag" + ) * interval_incidence_rate)) + ] # Rename the outcome_time column. data.table::setnames( x = surv_group, old = "outcome_time", - new = "time") + new = "time" + ) # Retain only import surv_group <- surv_group[, c( - "time", "survival_probability", "cumulative_incidence", "cumulative_censoring")] + "time", "survival_probability", "cumulative_incidence", "cumulative_censoring" + )] if (!any(surv_group$time == 0.0)) { surv_group <- rbind( @@ -470,7 +617,8 @@ get_outcome_info_from_backend <- function() { "time" = 0.0, "survival_probability" = 1.0, "cumulative_incidence" = 0.0, - "cumulative_censoring" = 0.0), + "cumulative_censoring" = 0.0 + ), surv_group ) } @@ -479,13 +627,13 @@ get_outcome_info_from_backend <- function() { distr_list[["n"]] <- nrow(x) # Number of events - distr_list[["n_event"]] <- sum(x$outcome_event == 1, na.rm = TRUE) + distr_list[["n_event"]] <- sum(x$outcome_event == 1L, na.rm = TRUE) # Five-number summary of follow-up distr_list[["follow_up_fivenum"]] <- fivenum_summary(x$outcome_time, na.rm = TRUE) # Five-number summary of event - distr_list[["event_fivenum"]] <- fivenum_summary(x[outcome_event == 1, ]$outcome_time, na.rm = TRUE) + distr_list[["event_fivenum"]] <- fivenum_summary(x[outcome_event == 1L, ]$outcome_time, na.rm = TRUE) # Survival probability distr_list[["survival_probability"]] <- unique(surv_group[, c("time", "survival_probability")]) @@ -513,7 +661,7 @@ setMethod( function(object) { # Basic outcome information. outcome_name <- object@name - if (length(outcome_name) == 0) outcome_name <- "outcome" + if (length(outcome_name) == 0L) outcome_name <- "outcome" # Form basic string. outcome_str <- paste0(outcome_name, " (", object@outcome_type, ")") @@ -522,56 +670,62 @@ setMethod( if (object@outcome_type %in% c("binomial")) { # Show the reference class. outcome_classes <- object@levels - outcome_classes[1] <- paste0(outcome_classes[1], " (reference)") + outcome_classes[1L] <- paste0(outcome_classes[1L], " (reference)") # Add to the outcome string. outcome_str <- paste0( outcome_str, ", with classes: ", - paste_s(outcome_classes), ".\n") + paste_s(outcome_classes), ".\n" + ) } else if (object@outcome_type %in% c("multinomial")) { # Show the outcome classes. outcome_str <- paste0( outcome_str, ", with classes: ", - paste_s(object@levels), ".\n") + paste_s(object@levels), ".\n" + ) - } else if (object@outcome_type %in% c("count", "continuous")) { + } else if (object@outcome_type %in% c("continuous")) { # No further details provided. outcome_str <- paste0(outcome_str, ".\n") } else if (object@outcome_type %in% c("survival")) { # Show the censoring and event values. - if (length(object@censored) > 0) { + if (length(object@censored) > 0L) { censoring_str <- paste0("censoring: ", paste_s(object@censored)) event_str <- paste0("event: ", paste_s(object@event)) # Add to outcome string. outcome_str <- paste0( outcome_str, ", with ", censoring_str, - "; and ", event_str, ".\n") + "; and ", event_str, ".\n" + ) } else { event_str <- paste0("event: ", paste_s(object@event)) # Add to outcome string. outcome_str <- paste0( - outcome_str, ", without censoring; and ", event_str, ".\n") + outcome_str, ", without censoring; and ", event_str, ".\n" + ) } } else if (object@outcome_type %in% c("competing_risk")) { - if (length(object@censored) > 0) { + if (length(object@censored) > 0L) { censoring_str <- paste0("with censoring: ", paste_s(object@censored)) } else { censoring_str <- "without censoring" } - if (length(object@competing_risk) > 0) { + if (length(object@competing_risk) > 0L) { competing_risk_str <- paste0( ifelse( - length(object@competing_risk) > 1, + length(object@competing_risk) > 1L, "competing risks: ", - "competing risk: "), - paste_s(object@competing_risk)) + "competing risk: " + ), + paste_s(object@competing_risk) + ) } else { competing_risk_str <- "no competing risks" @@ -584,7 +738,12 @@ setMethod( outcome_str, ", ", censoring_str, "; ", event_str, "; and ", - competing_risk_str, ".\n") + competing_risk_str, ".\n" + ) + + } else if (object@outcome_type == "unsupervised") { + # No further details provided. + outcome_str <- paste0(outcome_str, ".\n") } else { ..error_no_known_outcome_type(object@outcome_type) @@ -594,3 +753,15 @@ setMethod( cat(paste0(outcome_str)) } ) + + + +# add_package_version (outcomeInfo) -------------------------------------------- +setMethod( + "add_package_version", + signature(object = "outcomeInfo"), + function(object) { + # Set version of familiar + return(.add_package_version(object = object)) + } +) diff --git a/R/PairwiseSimilarity.R b/R/PairwiseSimilarity.R index c948488d..98afe50a 100644 --- a/R/PairwiseSimilarity.R +++ b/R/PairwiseSimilarity.R @@ -11,13 +11,16 @@ setClass( "range" = "numeric", "distance" = "logical", "require_normalisation" = "logical", - "highly_similar_threshold" = "numeric"), + "highly_similar_threshold" = "numeric" + ), prototype = list( "similarity_metric" = character(), "range" = NA_real_, "distance" = logical(), "require_normalisation" = logical(), - "highly_similar_threshold" = NA_real_)) + "highly_similar_threshold" = NA_real_ + ) +) @@ -29,7 +32,9 @@ setClass( "range" = c(0.0, 1.0), "distance" = FALSE, "require_normalisation" = FALSE, - "highly_similar_threshold" = 0.80)) + "highly_similar_threshold" = 0.80 + ) +) @@ -41,7 +46,9 @@ setClass( "range" = c(-1.0, 0.0, 1.0), "distance" = FALSE, "require_normalisation" = FALSE, - "highly_similar_threshold" = 0.90)) + "highly_similar_threshold" = 0.90 + ) +) @@ -53,7 +60,9 @@ setClass( "range" = c(0.0, 1.0), "distance" = FALSE, "require_normalisation" = FALSE, - "highly_similar_threshold" = 0.45)) + "highly_similar_threshold" = 0.45 + ) +) @@ -65,7 +74,9 @@ setClass( "range" = c(0.0, Inf), "distance" = TRUE, "require_normalisation" = TRUE, - "highly_similar_threshold" = 0.01)) + "highly_similar_threshold" = 0.01 + ) +) @@ -97,37 +108,45 @@ setMethod( x = similarity_metric, pattern = "_trim", replacement = "", - fixed = TRUE) + fixed = TRUE + ) similarity_metric <- gsub( x = similarity_metric, pattern = "_winsor", replacement = "", - fixed = TRUE) + fixed = TRUE + ) if (similarity_metric %in% c("cox_snell_r2", "nagelkerke_r2", "mcfadden_r2")) { object <- methods::new( "familiarSimilarityMetricPseudoR2", - similarity_metric = similarity_metric) + similarity_metric = similarity_metric + ) } else if (similarity_metric %in% c("pearson", "kendall", "spearman")) { object <- methods::new( "familiarSimilarityMetricCorrelation", - similarity_metric = similarity_metric) + similarity_metric = similarity_metric + ) } else if (similarity_metric %in% c("mutual_information")) { object <- methods::new( "familiarSimilarityMetricMutualInformation", - similarity_metric = similarity_metric) + similarity_metric = similarity_metric + ) } else if (similarity_metric %in% c( - "gower", "euclidean", "manhattan", "chebyshev", "cosine", "canberra", "bray_curtis")) { + "gower", "euclidean", "manhattan", "chebyshev", "cosine", "canberra", "bray_curtis" + )) { object <- methods::new( "familiarSimilarityMetricDistance", - similarity_metric = similarity_metric) + similarity_metric = similarity_metric + ) } else { ..error_reached_unreachable_code( - "compute_similarity_metric: encountered unknown similarity metric") + "compute_similarity_metric: encountered unknown similarity metric" + ) } return(object) @@ -142,7 +161,8 @@ setMethod( "encode_categorical_variables", signature( object = "familiarSimilarityMetric", - data = "ANY"), + data = "ANY" + ), function(object, data, ...) { # Extract data table with contrasts. @@ -150,7 +170,8 @@ setMethod( data = data, object = NULL, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) return(data$encoded_data) } @@ -163,7 +184,8 @@ setMethod( "encode_categorical_variables", signature( object = "familiarSimilarityMetricDistance", - data = "ANY"), + data = "ANY" + ), function(object, data, ...) { # Leave data as is. @@ -180,7 +202,8 @@ compute_feature_similarity_metric <- function( similarity_metric, feature_info_list, cl = NULL, - verbose = FALSE) { + verbose = FALSE +) { if (is_empty(data)) return(NULL) if (!is(data, "dataObject")) ..error_reached_unreachable_code("data should be dataObject.") @@ -190,12 +213,14 @@ compute_feature_similarity_metric <- function( x = similarity_metric, pattern = "_trim", replacement = "", - fixed = TRUE) + fixed = TRUE + ) similarity_metric_type <- gsub( x = similarity_metric_type, pattern = "_winsor", replacement = "", - fixed = TRUE) + fixed = TRUE + ) # Find similarity object. object <- .create_similarity_metric_object(similarity_metric = similarity_metric_type) @@ -205,19 +230,22 @@ compute_feature_similarity_metric <- function( # Check that the number of features is at least two. This is more of technical # requirement than anything else. - if (length(feature_columns) < 2) return(NULL) + if (length(feature_columns) < 2L) return(NULL) # Set the categorical mask. categorical_mask <- sapply( feature_info_list[feature_columns], - function(x) (x@feature_type == "factor")) + function(x) (x@feature_type == "factor") + ) if (!is_available(object = object, any_categorical = any(categorical_mask))) { - rlang::warn( + ..warning( message = paste0( "The ", similarity_metric, " metric can not be used to assess similarity between ", - "categorical variables. We will use mutual_information instead."), - class = "parameter_replacement_warning") + "categorical variables. We will use mutual_information instead." + ), + warning_class = "parameter_replacement_warning" + ) # Replace metric by mutual_information. object <- .create_similarity_metric_object(similarity_metric = "mutual_information") @@ -244,12 +272,13 @@ compute_feature_similarity_metric <- function( data.table::set(data@data, j = ii, value = .normalise( x = data@data[[ii]], normalisation_method = norm_method, - range = c(0, 1))) + range = c(0.0, 1.0) + )) } } # Generate all combinations of features - combinations <- utils::combn(sort(feature_columns), 2) + combinations <- utils::combn(sort(feature_columns), 2L) # Determine similarity measures for each feature pair. similarity <- fam_sapply( @@ -259,8 +288,8 @@ compute_feature_similarity_metric <- function( function(ii, combinations, data, object, categorical_mask) { # Identify features that are being compared. - feature_1 <- combinations[1, ii] - feature_2 <- combinations[2, ii] + feature_1 <- combinations[1L, ii] + feature_2 <- combinations[2L, ii] # Compute pairwise similarity similarity <- .compute_feature_similarity( @@ -268,7 +297,8 @@ compute_feature_similarity_metric <- function( x = data[[feature_1]], y = data[[feature_2]], x_categorical = categorical_mask[feature_1], - y_categorical = categorical_mask[feature_2]) + y_categorical = categorical_mask[feature_2] + ) return(similarity) }, @@ -277,13 +307,15 @@ compute_feature_similarity_metric <- function( data = droplevels(data@data), object = object, categorical_mask = categorical_mask, - chopchop = TRUE) + chopchop = TRUE + ) # Transform similarity scores into a data.table. similarity_data <- data.table::data.table( - "feature_name_1" = combinations[1, ], - "feature_name_2" = combinations[2, ], - "value" = similarity) + "feature_name_1" = combinations[1L, ], + "feature_name_2" = combinations[2L, ], + "value" = similarity + ) return(similarity_data) } @@ -293,7 +325,10 @@ compute_feature_similarity_metric <- function( ## .compute_feature_similarity (generic) --------------------------------------- -setGeneric(".compute_feature_similarity", function(object, ...) standardGeneric(".compute_feature_similarity")) +setGeneric( + ".compute_feature_similarity", + function(object, ...) standardGeneric(".compute_feature_similarity") +) @@ -319,12 +354,14 @@ setMethod( x_categorical, y_categorical, type = "approximate", - ...) { + ... + ) { .check_parameter_value_is_valid( x = type, var_name = "type", - values = c("exact", "approximate")) + values = c("exact", "approximate") + ) ..encode_variable_to_list <- function(x, is_categorical, insert_intercept = FALSE) { if (is_categorical) { @@ -339,9 +376,10 @@ setMethod( level_count <- nlevels(x) x <- lapply( - level_names[2:level_count], + level_names[2L:level_count], function(ii, x) (as.numeric(x == ii)), - x = x) + x = x + ) } } else { # Numeric variables are only stored as a list. @@ -360,21 +398,21 @@ setMethod( # Remove missing elements. valid_elements <- is.finite(x) & is.finite(y) - if (sum(valid_elements) <= 1) return(callNextMethod()) + if (sum(valid_elements) <= 1L) return(callNextMethod()) # Keep only valid elements. x <- x[valid_elements] y <- y[valid_elements] # Check if x and y are both invariant. - x_invariant <- all(x == x[1]) - y_invariant <- all(y == y[1]) + x_invariant <- all(x == x[1L]) + y_invariant <- all(y == y[1L]) if (x_invariant && y_invariant) return(1.0) if (x_invariant || y_invariant) return(0.0) if (type == "approximate") { # Select the number of samples for the computing approximate distances. - n_samples <- min(c(length(x), ceiling(1000^0.3 * length(x)^0.7))) + n_samples <- as.integer(min(c(length(x), ceiling(1000.0^0.3 * length(x)^0.7)))) # Set sample indices - avoid selecting samples randomly, as that is a # somewhat costly operation. @@ -387,8 +425,8 @@ setMethod( if (y_categorical) y <- droplevels(y) # Check if x and y are now both invariant. - x_invariant <- all(x == x[1]) - y_invariant <- all(y == y[1]) + x_invariant <- all(x == x[1L]) + y_invariant <- all(y == y[1L]) if (x_invariant && y_invariant) return(1.0) if (x_invariant || y_invariant) return(0.0) } @@ -399,7 +437,8 @@ setMethod( x = x, y = y, x_categorical = x_categorical, - y_categorical = y_categorical) + y_categorical = y_categorical + ) x <- analysis_info$x y <- analysis_info$y @@ -418,18 +457,20 @@ setMethod( predictors <- ..encode_variable_to_list( x = x, is_categorical = x_categorical, - insert_intercept = TRUE) + insert_intercept = TRUE + ) # Fit informative model. model <- fastglm::fastglm( x = as.matrix(predictors), y = y, family = fitting_family, - method = 3L) + method = 3L + ) predictor_names <- setdiff(names(model$coefficients), "intercept__") - if (any(!is.finite(model$coefficients[predictor_names]))) return(0.0) + if (!all(is.finite(model$coefficients[predictor_names]))) return(0.0) if (all(approximately(model$coefficients[predictor_names], 0.0))) return(0.0) if (approximately(model$deviance, 0.0)) return(1.0) @@ -438,31 +479,34 @@ setMethod( x = as.matrix(numeric(length(y)), ncol = 1L), y = y, family = fitting_family, - method = 3L) + method = 3L + ) } else { # Fit informative model. model <- stats::glm( "y ~ x", data = data.table::data.table("x" = x, "y" = y), - family = fitting_family) + family = fitting_family + ) predictor_names <- setdiff(names(coef(model)), "(Intercept)") - if (any(!is.finite(model$coefficients[predictor_names]))) return(0.0) - if (all(near(model$coefficients[predictor_names], 0.0, df = 2 * length(x)))) return(0.0) + if (!all(is.finite(model$coefficients[predictor_names]))) return(0.0) + if (all(near(model$coefficients[predictor_names], 0.0, df = 2L * length(x)))) return(0.0) if (approximately(model$deviance, 0.0)) return(1.0) # Fit uninformative model. null_model <- stats::glm( "y ~ 1", data = data.table::data.table("x" = x, "y" = y), - family = fitting_family) + family = fitting_family + ) } # Compute log-likelihoods - model_loglik <- stats::logLik(model)[1] - null_loglik <- stats::logLik(null_model)[1] + model_loglik <- stats::logLik(model)[1L] + null_loglik <- stats::logLik(null_model)[1L] } else if (analysis_info$type == "multinomial") { @@ -470,46 +514,53 @@ setMethod( x = "nnet", purpose = paste0( "to compute log-likelihood pseudo R2 similarity using the ", - object@similarity_metric, " metric")) + object@similarity_metric, " metric" + ) + ) # Set predictors and response. predictors <- ..encode_variable_to_list( x = x, - is_categorical = x_categorical) + is_categorical = x_categorical + ) response <- data.table::data.table("response" = y) # Set model formula. model_formula <- stats::reformulate( termlabels = names(predictors), - response = quote(response)) + response = quote(response) + ) null_formula <- stats::as.formula("response ~ 1") quiet(model <- nnet::multinom( model_formula, data = cbind(predictors, response), maxit = ifelse(type == "approximate", 100L, 500L), - MaxNWts = Inf)) + MaxNWts = Inf + )) model_coefficients <- stats::coef(model) predictor_names <- setdiff(colnames(model_coefficients), "(Intercept)") - if (any(!is.finite(model_coefficients[, predictor_names]))) return(0.0) - if (all(near(as.vector(model_coefficients[, predictor_names]), 0.0, df = 2 * length(x)))) return(0.0) + if (!all(is.finite(model_coefficients[, predictor_names]))) return(0.0) + if (all(near(as.vector(model_coefficients[, predictor_names]), 0.0, df = 2L * length(x)))) return(0.0) if (approximately(model$deviance, 0.0)) return(1.0) quiet(null_model <- nnet::multinom( null_formula, data = cbind(predictors, response), - maxit = ifelse(type == "approximate", 100L, 500L))) + maxit = ifelse(type == "approximate", 100L, 500L) + )) # Compute log-likelihoods - model_loglik <- stats::logLik(model)[1] - null_loglik <- stats::logLik(null_model)[1] + model_loglik <- stats::logLik(model)[1L] + null_loglik <- stats::logLik(null_model)[1L] } else { ..error_reached_unreachable_code(paste0( ".compute_similarity,familiarSimilarityMetricPseudoR2: ", - "encountered unknown analysis type")) + "encountered unknown analysis type" + )) } # Compute pseudo R-squared values from log-likelihoods @@ -528,8 +579,9 @@ setMethod( } else { ..error_reached_unreachable_code(paste0( - ".compute_similarity,familiarSimilarityMetricPseudoR2: ", - "encountered unknown similarity metric")) + ".compute_similarity,familiarSimilarityMetricPseudoR2: ", + "encountered unknown similarity metric" + )) } # Check if similarity is NaN or infinite. @@ -562,7 +614,8 @@ setMethod( y, x_categorical, y_categorical, - ...) { + ... + ) { ..dummy_encode <- function(x) { # Dummy encoding of categorical variable. @@ -570,9 +623,10 @@ setMethod( level_count <- nlevels(x) return(lapply( - level_names[2:level_count], + level_names[2L:level_count], function(ii, x) (as.numeric(x == ii)), - x = x)) + x = x + )) } ..encode_variable_to_list <- function(x, is_categorical) { @@ -581,9 +635,11 @@ setMethod( # one-hot-encoding (nominal). if (is.ordered(x)) { x <- list(as.numeric(x)) + } else { x <- ..dummy_encode(x) } + } else { # Numeric variables are only stored as a list. x <- list(x) @@ -602,7 +658,8 @@ setMethod( ii = seq_along(x), jj = seq_along(y), KEEP.OUT.ATTRS = FALSE, - stringsAsFactors = FALSE) + stringsAsFactors = FALSE + ) # Calculate correlation coefficients correlation_coef <- sapply( @@ -612,12 +669,14 @@ setMethod( x = x[[combinations$ii[kk]]], y = y[[combinations$jj[kk]]], use = "na.or.complete", - method = method) + method = method + ) }, combinations = combinations, x = x, y = y, - method = object@similarity_metric) + method = object@similarity_metric + ) if (x_categorical || y_categorical) { correlation_coef <- abs(correlation_coef) @@ -646,18 +705,21 @@ setMethod( y, x_categorical, y_categorical, - ...) { + ... + ) { + # mutual information can be mapped to spearman: + # log(mi) = -5.244 + 4.183 * sp # Remove missing elements. valid_elements <- is.finite(x) & is.finite(y) - if (sum(valid_elements) <= 1) return(callNextMethod()) + if (sum(valid_elements) <= 1L) return(callNextMethod()) # Keep only valid elements. x <- x[valid_elements] y <- y[valid_elements] # Check if there are more than one unique values in x and or y. - if (length(unique(x)) == 1 && length(unique(y)) == 1) return(1.0) + if (all(x == x[1L]) && all(y == y[1L])) return(1.0) # Ensure that numeric values are actually encoded as numeric, because # praznik handles integers as categorical variables. This is not the @@ -665,14 +727,18 @@ setMethod( if (!x_categorical && is.integer(x)) x <- as.numeric(x) if (!y_categorical && is.integer(y)) y <- as.numeric(y) - require_package( - x = "praznik", - purpose = paste0( - "to compute similarity using the ", - object@similarity_metric, " metric")) + # require_package( + # x = "praznik", + # purpose = paste0( + # "to compute similarity using the ", + # object@similarity_metric, " metric" + # ) + # ) # Compute normalised mutual information. - return(praznik::miScores(x, y, threads = 1L) / praznik::jhScores(x, y, threads = 1L)) + return( + praznik::miScores(x, y, threads = 1L) / praznik::jhScores(x, y, threads = 1L) + ) } ) @@ -688,7 +754,8 @@ setMethod( y, x_categorical, y_categorical, - ...) { + ... + ) { # For feature-wise comparison, the presence of categorical features is # problematic, because they don't have a "distance". @@ -699,8 +766,9 @@ setMethod( object = object, x = x, y = y, - categorical = logical(length(x))), - ...) + categorical = logical(length(x)), + ... + )) } ) @@ -711,7 +779,8 @@ compute_sample_similarity_metric <- function( similarity_metric, feature_info_list, cl = NULL, - verbose = FALSE) { + verbose = FALSE +) { if (is_empty(data)) return(NULL) if (!is(data, "dataObject")) ..error_reached_unreachable_code("data should be dataObject.") @@ -721,15 +790,19 @@ compute_sample_similarity_metric <- function( x = similarity_metric, pattern = "_trim", replacement = "", - fixed = TRUE) + fixed = TRUE + ) similarity_metric_type <- gsub( x = similarity_metric_type, pattern = "_winsor", replacement = "", - fixed = TRUE) + fixed = TRUE + ) # Find similarity object. - object <- .create_similarity_metric_object(similarity_metric = similarity_metric_type) + object <- .create_similarity_metric_object( + similarity_metric = similarity_metric_type + ) # Set feature columns. feature_columns <- get_feature_columns(data) @@ -737,7 +810,8 @@ compute_sample_similarity_metric <- function( # Set the categorical mask. categorical_mask <- sapply( feature_info_list[feature_columns], - function(x) (x@feature_type == "factor")) + function(x) (x@feature_type == "factor") + ) # Normalise data, if required. if (object@require_normalisation) { @@ -760,26 +834,17 @@ compute_sample_similarity_metric <- function( data.table::set(data@data, j = ii, value = .normalise( x = data@data[[ii]], normalisation_method = norm_method, - range = c(0, 1))) + range = c(0.0, 1.0) + )) } } # Check that the number of rows is at least two. This is more # of technical requirement than anything else. - if (nrow(data@data) < 2) return(NULL) + if (nrow(data@data) < 2L) return(NULL) # Generate all combinations of samples - combinations <- utils::combn(seq_len(nrow(data@data)), 2) - - # # Encode data -- this has no effect for distance-based metrics. - # data <- encode_categorical_variables(object = object, data = data) - # - # # Find feature columns and categorical mask from encoded data. - # feature_columns <- get_feature_columns(data) - # categorical_mask <- sapply( - # feature_columns, - # function(feature, x) (is.factor(x[[feature]])), - # ) + combinations <- utils::combn(seq_len(nrow(data@data)), 2L) # Determine similarity measures for each sample pair. similarity <- fam_sapply( @@ -789,15 +854,16 @@ compute_sample_similarity_metric <- function( function(ii, combinations, data, object, categorical_mask) { # Identify features that are being compared. - row_1 <- combinations[1, ii] - row_2 <- combinations[2, ii] + row_1 <- combinations[1L, ii] + row_2 <- combinations[2L, ii] # Compute pairwise similarity similarity <- .compute_sample_similarity( object = object, x = as.numeric(data[row_1, ]), y = as.numeric(data[row_2, ]), - categorical = categorical_mask) + categorical = categorical_mask + ) return(similarity) }, @@ -806,16 +872,18 @@ compute_sample_similarity_metric <- function( data = data@data[, mget(feature_columns)], object = object, categorical_mask = categorical_mask, - chopchop = TRUE) + chopchop = TRUE + ) # Create unique row names. row_names <- get_unique_row_names(x = data) # Transform similarity scores into a data.table. similarity_data <- data.table::data.table( - "sample_1" = row_names[combinations[1, ]], - "sample_2" = row_names[combinations[2, ]], - "value" = similarity) + "sample_1" = row_names[combinations[1L, ]], + "sample_2" = row_names[combinations[2L, ]], + "value" = similarity + ) return(similarity_data) } @@ -823,7 +891,10 @@ compute_sample_similarity_metric <- function( # .compute_sample_similarity (generic) ----------------------------------------- -setGeneric(".compute_sample_similarity", function(object, ...) standardGeneric(".compute_sample_similarity")) +setGeneric( + ".compute_sample_similarity", + function(object, ...) standardGeneric(".compute_sample_similarity") +) @@ -847,7 +918,8 @@ setMethod( x, y, categorical, - ...) { + ... + ) { # The presence of categorical variables is problematic for computing # pseudo R2, because we can only correlation @@ -861,7 +933,8 @@ setMethod( y = y, categorical_x = FALSE, categorical_y = FALSE, - ...)) + ... + )) } ) @@ -876,7 +949,8 @@ setMethod( x, y, categorical, - ...) { + ... + ) { # The presence of categorical variables is problematic for computing # sample-wise similarity, because we can only correlation @@ -890,7 +964,8 @@ setMethod( y = y, categorical_x = FALSE, categorical_y = FALSE, - ...)) + ... + )) } ) @@ -905,7 +980,8 @@ setMethod( x, y, categorical, - ...) { + ... + ) { # The presence of categorical variables is problematic for computing # sample-wise similarity, because we can only compute mutual information @@ -919,7 +995,8 @@ setMethod( y = y, categorical_x = FALSE, categorical_y = FALSE, - ...)) + ... + )) } ) @@ -934,7 +1011,8 @@ setMethod( x, y, categorical, - ...) { + ... + ) { # Ensure that data presented as numeric values. if (!is.numeric(x)) x <- as.numeric(x) @@ -942,7 +1020,7 @@ setMethod( # Remove missing elements. valid_elements <- is.finite(x) & is.finite(y) - if (sum(valid_elements) < 1) return(callNextMethod()) + if (sum(valid_elements) < 1.0) return(callNextMethod()) # Keep only valid elements. x <- x[valid_elements] @@ -967,13 +1045,13 @@ setMethod( if (object@similarity_metric == "gower") { distance <- sum(abs(x - y)) / length(x) } else if (object@similarity_metric == "euclidean") { - distance <- sqrt(sum((x - y)^2)) + distance <- sqrt(sum((x - y)^2.0)) } else if (object@similarity_metric == "manhattan") { distance <- sum(abs(x - y)) } else if (object@similarity_metric == "chebyshev") { distance <- max(abs(x - y)) } else if (object@similarity_metric == "cosine") { - distance <- 1 - sum(x * y) / (sqrt(sum(x^2)) * sqrt(sum(y^2))) + distance <- 1.0 - sum(x * y) / (sqrt(sum(x^2.0)) * sqrt(sum(y^2.0))) } else if (object@similarity_metric == "canberra") { distance <- sum(abs(x - y) / (abs(x) + abs(y))) } else if (object@similarity_metric == "bray_curtis") { @@ -1002,7 +1080,7 @@ setMethod( # Case 1: Both x and y are categorical variables. # Determine analysis type. - analysis_type <- ifelse(min(c(n_x, n_y)) <= 2, "binomial", "multinomial") + analysis_type <- ifelse(min(c(n_x, n_y)) <= 2L, "binomial", "multinomial") # Determine if swapping is required. requires_swap <- n_x < n_y @@ -1011,7 +1089,7 @@ setMethod( # Case 2: x is a categorical variable, and y numerical. # Determine analysis type. - analysis_type <- ifelse(n_x <= 2, "binomial", "multinomial") + analysis_type <- ifelse(n_x <= 2L, "binomial", "multinomial") # Swapping is required. requires_swap <- TRUE @@ -1020,7 +1098,7 @@ setMethod( # Case 3: x is a numerical variable, and y categorical. # Determine analysis type. - analysis_type <- ifelse(n_y <= 2, "binomial", "multinomial") + analysis_type <- ifelse(n_y <= 2L, "binomial", "multinomial") # Swapping is not required. requires_swap <- FALSE @@ -1050,7 +1128,8 @@ setMethod( "x" = x_out, "y" = y_out, "x_categorical" = x_categorical_out, - "y_categorical" = y_categorical_out)) + "y_categorical" = y_categorical_out + )) } @@ -1064,13 +1143,17 @@ convert_similarity_to_distance <- function(x, similarity_metric) { return(.similarity_to_distance( object = object, - x = x)) + x = x + )) } ## .similarity_to_distance (generic) ------------------------------------------- -setGeneric(".similarity_to_distance", function(object, ...) standardGeneric(".similarity_to_distance")) +setGeneric( + ".similarity_to_distance", + function(object, ...) standardGeneric(".similarity_to_distance") +) @@ -1079,7 +1162,7 @@ setMethod( ".similarity_to_distance", signature(object = "familiarSimilarityMetricPseudoR2"), function(object, x, ...) { - return(1 - sqrt(x)) + return(1.0 - sqrt(x)) } ) @@ -1090,7 +1173,7 @@ setMethod( ".similarity_to_distance", signature(object = "familiarSimilarityMetricCorrelation"), function(object, x, ...) { - return(1 - abs(x)) + return(1.0 - abs(x)) } ) @@ -1101,7 +1184,7 @@ setMethod( ".similarity_to_distance", signature(object = "familiarSimilarityMetricMutualInformation"), function(object, x, ...) { - return(1 - x) + return(1.0 - x) } ) @@ -1128,13 +1211,17 @@ convert_distance_to_similarity <- function(x, similarity_metric) { return(.distance_to_similarity( object = object, - x = x)) + x = x + )) } ## .distance_to_similarity (generic) ------------------------------------------- -setGeneric(".distance_to_similarity", function(object, ...) standardGeneric(".distance_to_similarity")) +setGeneric( + ".distance_to_similarity", + function(object, ...) standardGeneric(".distance_to_similarity") +) @@ -1143,7 +1230,7 @@ setMethod( ".distance_to_similarity", signature(object = "familiarSimilarityMetricPseudoR2"), function(object, x, ...) { - return((1 - x)^2) + return((1.0 - x)^2.0) } ) @@ -1155,7 +1242,7 @@ setMethod( signature(object = "familiarSimilarityMetricCorrelation"), function(object, x, ...) { # Note that the sign is lost at conversion back to similarity. - return(1 - abs(x)) + return(1.0 - abs(x)) } ) @@ -1166,7 +1253,7 @@ setMethod( ".distance_to_similarity", signature(object = "familiarSimilarityMetricMutualInformation"), function(object, x, ...) { - return(1 - x) + return(1.0 - x) } ) @@ -1204,7 +1291,8 @@ get_similarity_range <- function(similarity_metric, as_distance = FALSE) { if (as_distance) { value_range <- .similarity_to_distance( object = object, - x = value_range) + x = value_range + ) value_range <- sort(unique(value_range)) } @@ -1228,7 +1316,8 @@ is_default_distance <- function(similarity_metric) { # Pair-wise comparison between features. return(c( "mcfadden_r2", "cox_snell_r2", "nagelkerke_r2", "spearman", - "kendall", "pearson", "mutual_information")) + "kendall", "pearson", "mutual_information" + )) } else { # Pair-wise comparison between samples. diff --git a/R/ParallelFunctions.R b/R/ParallelFunctions.R index ab79c34e..a9690b55 100644 --- a/R/ParallelFunctions.R +++ b/R/ParallelFunctions.R @@ -12,25 +12,27 @@ # Find the number of available cores. n_available_cores <- parallel::detectCores() - n_cores <- max(c(1, min(c(n_available_cores - 1, n_cores)))) + n_cores <- max(c(1L, min(c(n_available_cores - 1L, n_cores)))) - if (n_available_connections < 2 && n_cores > 2 && cluster_type %in% c("psock", "sock", "fork")) { - stop(paste0( + if (n_available_connections < 2L && n_cores > 2L && cluster_type %in% c("psock", "sock", "fork")) { + ..error(paste0( "R has insufficient available connections to perform parallel processing. ", "You may close connections using closeAllConnections() to free up connections. ", - "If this does not resolve the issue, disable parallelisation for familiar.")) + "If this does not resolve the issue, disable parallelisation for familiar." + )) - } else if (n_cores > 2 && n_available_connections < n_cores) { - warning(paste0( + } else if (n_cores > 2L && n_available_connections < n_cores) { + ..warning(paste0( "R has insufficient available connections to use all available cores for parallel processing. ", - n_available_connections, " are used instead.")) + n_available_connections, " are used instead." + )) # Update the number of cores. n_cores <- n_available_connections } # Return NULL if the number of cores is 1 or less. - if (n_cores <= 1) return(NULL) + if (n_cores <= 1L) return(NULL) # Start cluster. if (cluster_type == "psock") { @@ -38,7 +40,7 @@ } else if (cluster_type == "fork") { cl <- parallel::makeForkCluster(n_cores) } else if (cluster_type %in% c("mpi", "nws", "sock")) { - cl <- parallel::makeCluster(type = toupper(cluster_type), 2) + cl <- parallel::makeCluster(type = toupper(cluster_type), 2L) } return(cl) @@ -65,12 +67,12 @@ # The standard is that R allows 128 connections. 3 are in standard use by R. # Another socket is used by the default socket_server data backend. - R_available <- 124 + R_available <- 124L # Find the number of currently available connections. n_available_connections <- R_available - nrow(showConnections()) - if (n_available_connections < 0) n_available_connections <- 0 + if (n_available_connections < 0L) n_available_connections <- 0L return(n_available_connections) } @@ -81,17 +83,17 @@ # Check if the provided cluster type is available. if (get_os() == "windows" && cluster_type == "fork") { - stop("FORK clusters are not available for windows OS.") + ..error("FORK clusters are not available for windows OS.") } - installed_libs <- utils::installed.packages()[, 1] + installed_libs <- utils::installed.packages()[, 1L] if (!"snow" %in% installed_libs && cluster_type %in% c("mpi", "nws", "sock")) { - stop("The parallel package requires the snow package to work with MPI, NWS or SOCK clusters.") + ..error("The parallel package requires the snow package to work with MPI, NWS or SOCK clusters.") } if (!"Rmpi" %in% installed_libs && cluster_type == "mpi") { - stop("The parallel packages requires the Rmpi package to work with MPI clusters.") + ..error("The parallel packages requires the Rmpi package to work with MPI clusters.") } return(invisible(TRUE)) @@ -103,7 +105,8 @@ is_external_cluster = FALSE, restart_cluster = FALSE, n_cores = NULL, - cluster_type = NULL) { + cluster_type = NULL +) { # We don't need a backend if the cluster is external. if (is.null(cluster_type) && !is_external_cluster) cluster_type <- "psock" @@ -202,9 +205,11 @@ parallel::clusterEvalQ(cl = cl, library(data.table)) # Set options on each cluster node. - parallel::clusterEvalQ(cl = cl, options(rf.cores = as.integer(1))) + parallel::clusterEvalQ(cl = cl, options(rf.cores = 1L)) parallel::clusterEvalQ(cl = cl, data.table::setDTthreads(1L)) + if ("none" %in% assign) return(cl) + # Check if anything needs to be loaded if (any(c("all", "data") %in% assign)) { # Only add master data to the global environment of the clusters when @@ -251,7 +256,8 @@ if (any(c("all", "feature_info") %in% assign)) { if ( backend_type == "none" && - exists("master_feature_info_list", envir = familiar_global_env)) { + exists("master_feature_info_list", envir = familiar_global_env) + ) { parallel::clusterExport(cl = cl, varlist = "master_feature_info_list", envir = familiar_global_env) } } @@ -274,12 +280,13 @@ fam_sapply <- function( chopchop = FALSE, overhead_time = NULL, process_time = NULL, - MEASURE.TIME = FALSE) { + MEASURE.TIME = FALSE +) { # Determine the output format. output_format <- ifelse(SIMPLIFY, "vector", "list") # Get the name of the initial argument. - initial_argument_name <- head(names(formals(FUN)), n = 1) + initial_argument_name <- head(names(formals(FUN)), n = 1L) # Upgrade X to a named list. X <- list(X) @@ -324,12 +331,13 @@ fam_lapply <- function( chopchop = FALSE, overhead_time = NULL, process_time = NULL, - MEASURE.TIME = FALSE) { + MEASURE.TIME = FALSE +) { # Determine the output format. output_format <- ifelse(SIMPLIFY, "vector", "list") # Get the name of the initial argument. - initial_argument_name <- head(names(formals(FUN)), n = 1) + initial_argument_name <- head(names(formals(FUN)), n = 1L) # Upgrade X to a named list. X <- list(X) @@ -374,7 +382,8 @@ fam_mapply <- function( chopchop = FALSE, overhead_time = NULL, process_time = NULL, - MEASURE.TIME = FALSE) { + MEASURE.TIME = FALSE +) { # Determine the output format. output_format <- ifelse(SIMPLIFY, "vector", "list") @@ -414,12 +423,13 @@ fam_sapply_lb <- function( progress_bar = FALSE, SIMPLIFY = TRUE, USE.NAMES = TRUE, - MEASURE.TIME = FALSE) { + MEASURE.TIME = FALSE +) { # Determine the output format. output_format <- ifelse(SIMPLIFY, "vector", "list") # Get the name of the initial argument. - initial_argument_name <- head(names(formals(FUN)), n = 1) + initial_argument_name <- head(names(formals(FUN)), n = 1L) # Upgrade X to a named list. X <- list(X) @@ -457,12 +467,13 @@ fam_lapply_lb <- function( ..., progress_bar = FALSE, SIMPLIFY = FALSE, - MEASURE.TIME = FALSE) { + MEASURE.TIME = FALSE +) { # Determine the output format. output_format <- ifelse(SIMPLIFY, "vector", "list") # Get the name of the initial argument. - initial_argument_name <- head(names(formals(FUN)), n = 1) + initial_argument_name <- head(names(formals(FUN)), n = 1L) # Upgrade X to a named list. X <- list(X) @@ -499,7 +510,8 @@ fam_mapply_lb <- function( MoreArgs = NULL, SIMPLIFY = FALSE, USE.NAMES = TRUE, - MEASURE.TIME = FALSE) { + MEASURE.TIME = FALSE +) { # Determine the output format. output_format <- ifelse(SIMPLIFY, "vector", "list") @@ -540,7 +552,8 @@ fam_mapply_lb <- function( measure_time = FALSE, process_scheduling = "static", output_format = "list", - use_names = TRUE) { + use_names = TRUE +) { .check_parameter_value_is_valid( x = process_scheduling, var_name = "process_scheduling", @@ -555,18 +568,18 @@ fam_mapply_lb <- function( # Check the length of the dots argument. n_x <- .dots_arg_length(...) - if (n_x == 0) { + if (n_x == 0L) { return(list()) } # Adapt cl to the iterable data in ... if (inherits(cl, "cluster")) { - if (n_x == 1) cl <- NULL + if (n_x == 1L) cl <- NULL } # Check that there is more than one node. if (inherits(cl, "cluster")) { - if (length(cl) == 1) cl <- NULL + if (length(cl) == 1L) cl <- NULL } if ((chopchop || measure_time) && inherits(cl, "cluster")) { @@ -613,13 +626,13 @@ fam_mapply_lb <- function( # Setup initial cluster. if (.needs_cluster_restart() && !.is_external_cluster()) { cl_test <- .restart_cluster( - cl = cl[1], + cl = cl[1L], assign = assign, n_nodes = 1L ) } else { cl_test <- .update_info_on_cluster( - cl = cl[1], + cl = cl[1L], assign = assign ) } @@ -650,17 +663,17 @@ fam_mapply_lb <- function( # Compute overhead and process times. Overhead time is computed from the # time passed minus the time of the longest subprocess. - overhead_time <- (overhead_end - overhead_start) / 1E9 - y$process_time_total + overhead_time <- (overhead_end - overhead_start) / 1.0E9 - y$process_time_total # Obtain initial y_initial <- y # Skip analysis of the first iterable element. skip_element <- 1L - n_x <- n_x - 1 + n_x <- n_x - 1L # Update the first node that was used to run the test. - cl[1] <- cl_test + cl[1L] <- cl_test } else if (require_process_stacking) { # Determine how to optimally stack the processes. @@ -684,28 +697,30 @@ fam_mapply_lb <- function( # derivative of the process time curve, and determining the optima. Here t # = f(n, m) = m * overhead_time + n / m * process_time, with n the number # of processes and m the number of available nodes. - n_nodes_optimal <- floor(sqrt(n_x * stats::median(c(process_time, y$process_time)) / overhead_time)) + n_nodes_optimal <- as.integer( + floor(sqrt(n_x * stats::median(c(process_time, y$process_time)) / overhead_time)) + ) } # Select the required nodes. - if (n_nodes_optimal <= 1) { + if (n_nodes_optimal <= 1L) { cl <- NULL } else if (n_nodes_optimal < length(cl)) { - cl <- cl[1:n_nodes_optimal] + cl <- cl[1L:n_nodes_optimal] } } # Adapt cl based on the number of iterable elements. if (inherits(cl, "cluster")) { - if (n_x < length(cl)) cl <- cl[1:n_x] + if (n_x < length(cl)) cl <- cl[1L:n_x] if (measure_time) startup_overhead_start <- microbenchmark::get_nanotime() # Update and restart clusters. if (.needs_cluster_restart() && !.is_external_cluster()) { if (require_optimisation) { - cl[-1] <- .restart_cluster( - cl = cl[-1], + cl[-1L] <- .restart_cluster( + cl = cl[-1L], assign = assign ) } else { @@ -720,8 +735,8 @@ fam_mapply_lb <- function( } else { if (require_optimisation) { - cl[-1] <- .update_info_on_cluster( - cl = cl[-1], + cl[-1L] <- .update_info_on_cluster( + cl = cl[-1L], assign = assign ) } else { @@ -734,7 +749,8 @@ fam_mapply_lb <- function( if (measure_time) { startup_overhead_end <- microbenchmark::get_nanotime() - startup_overhead_time <- (startup_overhead_end - startup_overhead_start) / 1E9 + startup_overhead_time <- (startup_overhead_end - startup_overhead_start) / 1.0E9 + } else { startup_overhead_time <- 0.0 } @@ -748,7 +764,7 @@ fam_mapply_lb <- function( # Start progress bar. if (progress_bar && !inherits(cl, "cluster")) { - pb_conn <- utils::txtProgressBar(min = 0, max = n_x, style = 3) + pb_conn <- utils::txtProgressBar(min = 0L, max = n_x, style = 3L) } else { pb_conn <- NULL } @@ -758,7 +774,7 @@ fam_mapply_lb <- function( # present initially. For simplicity, we recompute the first element, as the # lack of cluster indicates that the time spent by the process is # negligible. - if (require_optimisation) n_x <- n_x + 1 + if (require_optimisation) n_x <- n_x + 1L # Perform the sequential apply as mapply. y <- do.call( @@ -812,8 +828,10 @@ fam_mapply_lb <- function( if (measure_time) { # Compute overhead and process times. Overhead time is computed from the # time passed minus the time of the longest subprocess. - overhead_time <- (startup_overhead_time + (overhead_end - overhead_start) / 1E9 - - sum(y$process_time) / length(cl)) / length(cl) + overhead_time <- ( + startup_overhead_time + (overhead_end - overhead_start) / 1.0E9 - sum(y$process_time) / length(cl) + ) / length(cl) + } } else if (inherits(cl, "cluster") && chopchop) { # Send to a chunking function for chopping into a list with up to n_cl @@ -864,8 +882,9 @@ fam_mapply_lb <- function( if (measure_time) { # Compute overhead and process times. Overhead time is computed from the # time passed minus the time of the longest subprocess. - overhead_time <- (startup_overhead_time + (overhead_end - overhead_start) / - 1E9 - max(y$process_time_total)) / length(cl) + overhead_time <- ( + startup_overhead_time + (overhead_end - overhead_start) / 1.0E9 - max(y$process_time_total) + ) / length(cl) } # Add in initial list. @@ -909,7 +928,13 @@ fam_mapply_lb <- function( -.wrapper_fun <- function(FUN2, II = NULL, pb_conn = NULL, ..., MoreArgs = NULL) { +.wrapper_fun <- function( + FUN2, + II = NULL, + pb_conn = NULL, + ..., + MoreArgs = NULL +) { # Execute function y <- do.call(FUN2, args = c( list(...), @@ -921,7 +946,12 @@ fam_mapply_lb <- function( -.wrapper_fun_time <- function(FUN2, II = NULL, pb_conn = NULL, ..., MoreArgs = NULL) { +.wrapper_fun_time <- function( + FUN2, + II = NULL, + pb_conn = NULL, + ..., + MoreArgs = NULL) { # Get process start time. process_start <- microbenchmark::get_nanotime() @@ -936,13 +966,19 @@ fam_mapply_lb <- function( return(list( "results" = y, - "process_time" = (process_end - process_start) / 1E9 + "process_time" = (process_end - process_start) / 1.0E9 )) } -.wrapper_fun_progress <- function(FUN2, II = NULL, pb_conn = NULL, ..., MoreArgs = NULL) { +.wrapper_fun_progress <- function( + FUN2, + II = NULL, + pb_conn = NULL, + ..., + MoreArgs = NULL +) { # Execute function y <- do.call(FUN2, args = c( list(...), @@ -957,7 +993,13 @@ fam_mapply_lb <- function( -.wrapper_fun_time_progress <- function(FUN2, II = NULL, pb_conn = NULL, ..., MoreArgs = NULL) { +.wrapper_fun_time_progress <- function( + FUN2, + II = NULL, + pb_conn = NULL, + ..., + MoreArgs = NULL +) { # Get process start time. process_start <- microbenchmark::get_nanotime() @@ -975,18 +1017,20 @@ fam_mapply_lb <- function( return(list( "results" = y, - "process_time" = (process_end - process_start) / 1E9)) + "process_time" = (process_end - process_start) / 1.0E9 + )) } .dots_arg_length <- function(...) { # Get the length of the dots argument. - n_x <- unique(sapply(list(...), length)) + n_x <- unique(lengths(list(...))) - if (length(n_x) != 1) { + if (length(n_x) != 1L) { ..error_reached_unreachable_code( - ".dots_arg_length: iterable arguments do not have the same length.") + ".dots_arg_length: iterable arguments do not have the same length." + ) } return(n_x) @@ -999,7 +1043,8 @@ fam_mapply_lb <- function( FUN2, dots, additional_arguments = NULL, - measure_time = FALSE) { + measure_time = FALSE +) { if (measure_time) process_total_start <- microbenchmark::get_nanotime() # Perform the sequential apply as mapply. @@ -1022,7 +1067,7 @@ fam_mapply_lb <- function( if (measure_time) process_total_end <- microbenchmark::get_nanotime() # Set total process time (which may vary between nodes.) - if (measure_time) y[[1]]$process_time_total <- (process_total_end - process_total_start) / 1E9 + if (measure_time) y[[1L]]$process_time_total <- (process_total_end - process_total_start) / 1.0E9 return(y) } @@ -1045,12 +1090,13 @@ fam_mapply_lb <- function( n_cl, n_x = NULL, skip_elements = NULL, - stacking_data = NULL) { + stacking_data = NULL +) { # Determine n_x if not provided. n_x may be provided when we attempt to # determine process and overhead time. - if (is.null(n_x)) n_x <- unique(sapply(args, length)) + if (is.null(n_x)) n_x <- unique(lengths(args)) - if (length(n_x) != 1) ..error_reached_unreachable_code(".chop_args: arguments do not have the same length.") + if (length(n_x) != 1L) ..error_reached_unreachable_code(".chop_args: arguments do not have the same length.") # Set up the sequence of values. n_x <- seq_len(n_x) @@ -1063,36 +1109,43 @@ fam_mapply_lb <- function( # only be up to the number of available elements. if (n_cl > length(n_x)) n_cl <- length(n_x) - if (length(n_x) == 0 || n_cl == 0) { + if (length(n_x) == 0L || n_cl == 0L) { index <- list() - } else if (length(n_x) == 1 || n_cl == 1) { + } else if (length(n_x) == 1L || n_cl == 1L) { index <- list(n_x) } else if (!is.null(stacking_data)) { index <- unname(lapply( split(stacking_data, by = "node_id", sorted = TRUE), - function(list_element) (list_element$original_index))) + function(list_element) (list_element$original_index) + )) } else { index <- structure( split(n_x, cut(n_x, n_cl)), - names = NULL) + names = NULL + ) } # Split arguments internally. chopped_args <- lapply( index, function(ii, x) { - return(lapply(x, function(x, ii) { - if (data.table::is.data.table(x)) { - column_names <- colnames(x)[ii] - return(x[, mget(column_names)]) - } else { - return(x[ii]) - } - }, - ii = ii)) + return( + lapply( + x, + function(x, ii) { + if (data.table::is.data.table(x)) { + column_names <- colnames(x)[ii] + return(x[, mget(column_names)]) + } else { + return(x[ii]) + } + }, + ii = ii + ) + ) }, x = args ) @@ -1106,12 +1159,13 @@ fam_mapply_lb <- function( n_nodes, overhead_time, process_time, - min_decrease = 0.05) { + min_decrease = 0.05 +) { # Check if there are fewer processes than nodes. if (n_nodes > length(process_time)) n_nodes <- length(process_time) # Check if there is any reason to parallellise. - if (n_nodes < 2) return(NULL) + if (n_nodes < 2L) return(NULL) # Determine the baseline time. baseline_time <- sum(process_time) @@ -1140,8 +1194,10 @@ fam_mapply_lb <- function( # Check that an increase in nodes does not negatively affect the time spent # processing. Also, ensure that the achieved decrease is at least # min_decrease with regard to the previous time. - if (previous_time <= current_stacking_data$node_time || - previous_time - current_stacking_data$node_time < min_decrease) { + if ( + previous_time <= current_stacking_data$node_time || + previous_time - current_stacking_data$node_time < min_decrease + ) { break } @@ -1189,5 +1245,6 @@ fam_mapply_lb <- function( # Return the maximum node time (which is of course) return(list( "node_time" = max(node_time) + overhead_time * n_nodes, - "process_data" = process_data)) + "process_data" = process_data + )) } diff --git a/R/ParseData.R b/R/ParseData.R index 2b119a60..7bffffa7 100644 --- a/R/ParseData.R +++ b/R/ParseData.R @@ -3,7 +3,8 @@ sample_id_column = NULL, batch_id_column = NULL, series_id_column = NULL, - ...) { + ... +) { # Parse the input sample_id_column if (!is.null(sample_id_column)) { sample_id_column <- .replace_illegal_column_name(sample_id_column) @@ -32,11 +33,11 @@ # Update column names using a fixed routine data.table::setnames(data, .replace_illegal_column_name(colnames(data))) - } else if (is.character(data) && length(data) == 1) { + } else if (is.character(data) && length(data) == 1L) { # Read from path if (!file.exists(data)) { - stop(paste0("The requested data file does not exist: ", data)) + ..error(paste0("The requested data file does not exist: ", data)) } # Load data based on file extension @@ -49,20 +50,21 @@ } else if (file_extension == "rds") { data <- .load_rds(data) } else { - stop(paste( + ..error(paste( "File extension", file_extension, "was not recognised as a loadable data type. Please load the", - "data manually.")) + "data manually." + )) } # Update column names using a fixed routine data.table::setnames(data, .replace_illegal_column_name(colnames(data))) - } else if ((is.atomic(data) && length(data) > 1) || (is.list(data))) { + } else if ((is.atomic(data) && length(data) > 1L) || (is.list(data))) { # Read data to a list by calling the function recursively data_list <- lapply(data, .load_data) - if (length(data_list) > 1) { + if (length(data_list) > 1L) { new_data_list <- list() joined_id <- integer() @@ -75,7 +77,7 @@ current_data <- data_list[[ii]] # Iterate over remaining datasets - for (jj in seq(ii + 1, length(data_list))) { + for (jj in seq(ii + 1L, length(data_list))) { # Check that index jj does not access non-existing data if (jj > length(data_list)) break @@ -110,62 +112,68 @@ } }, x = current_data, - y = data_list[[jj]]) + y = data_list[[jj]] + ) # Throw an error if any class is not consistent. - if (any(!matching_types)) { - stop(paste0( + if (!all(matching_types)) { + ..error(paste0( "Mismatching column classes were found between datasets ", ii, " and ", jj, ". Differences were found in columns:", - paste_s(overlap_cols[!matching_types]))) + paste_s(overlap_cols[!matching_types]) + )) } # Bind the datasets together current_data <- data.table::rbindlist( list(current_data, data_list[[jj]]), use.names = TRUE, - fill = TRUE) + fill = TRUE + ) # Mark the dataset as joined to prevent double usage. - joined_id <- append(joined_id, jj) + joined_id <- c(joined_id, jj) } # Append new data list with current_data - new_data_list <- append(new_data_list, list(current_data)) + new_data_list <- c(new_data_list, list(current_data)) } # Replace data_list with new_data_list data_list <- new_data_list # Check if it makes sense to attempt to join datasets by index. - if (length(data_list) > 1) { + if (length(data_list) > 1L) { # Get the left-hand dataset for merging data < data_list[[ii]] # Iterate over remaining datasets - for (ii in seq(2, length(data_list))) { + for (ii in seq(2L, length(data_list))) { if (is.null(sample_id_column)) { # Attempt cbind if both datasets have the same number of rows and # non-overlapping column names if (nrow(data) != nrow(data_list[[ii]])) { - stop(paste( + ..error(paste( "datasets could not be joined row-wise because the number of samples is different.", - "Please provide a sample id column or merge the datasets yourself prior to input.")) + "Please provide a sample id column or merge the datasets yourself prior to input." + )) } # Check for column overlap overlap_cols <- intersect(colnames(data), colnames(data_list[[ii]])) - if (length(overlap_cols) > 0) { - stop(paste( + if (length(overlap_cols) > 0L) { + ..error(paste( "datasets could not be joined row-wise as one or more columns with the same name", - "appear in both the left and right-hand datasets:", paste_s(overlap_cols))) + "appear in both the left and right-hand datasets:", paste_s(overlap_cols) + )) } # Throw a warning, as row-wise binding is dangerous - warning(paste( + ..warning(paste( "datasets could be joined row-wise. Integrity of the data could not be ensured.", "Please ensure that each sample occupies same row for consistency. Alternatively,", - "provide a sample id column or merge the datasets yourself prior to input.")) + "provide a sample id column or merge the datasets yourself prior to input." + )) # Combine row-wise data <- cbind(data, data_list[[ii]]) @@ -173,46 +181,56 @@ } else if ( !is.null(sample_id_column) && !is.null(batch_id_column) && - is.null(series_id_column)) { + is.null(series_id_column) + ) { # Attempt full join on sample_id_column and batch_id_column, # provided that other column names are not overlapping, and all # sample_ids for a batch are unique. # Check if the sample identifier columns is presents in the data - if (!sample_id_column %in% colnames(data) || - !sample_id_column %in% colnames(data_list[[ii]])) { - stop(paste( + if ( + !sample_id_column %in% colnames(data) || + !sample_id_column %in% colnames(data_list[[ii]]) + ) { + ..error(paste( "The specified column of sample identifiers", sample_id_column, - "was not found in one or more of the datasets.")) + "was not found in one or more of the datasets." + )) } # Check if the batch identifier column is present in the data if (!batch_id_column %in% colnames(data) || !batch_id_column %in% colnames(data_list[[ii]])) { - stop(paste( + ..error(paste( "The specified column of batch identifiers", batch_id_column, - "was not found in one or more of the datasets.")) + "was not found in one or more of the datasets." + )) } # Check uniqueness of identifiers - if (anyDuplicated(data[, mget(sample_id_column, batch_id_column)]) > 0 || - anyDuplicated(data_list[[ii]][, mget(sample_id_column, batch_id_column)]) > 0) { - stop(paste( + if ( + anyDuplicated(data[, mget(sample_id_column, batch_id_column)]) > 0L || + anyDuplicated(data_list[[ii]][, mget(sample_id_column, batch_id_column)]) > 0L + ) { + ..error(paste( "Sample identifiers were not uniquely specified within each batch.", "In case this is intentional, i.e. for repeated measurements, please merge the", - "datasets yourself prior to input.")) + "datasets yourself prior to input." + )) } # Check for column overlap overlap_cols <- setdiff( intersect(colnames(data), colnames(data_list[[ii]])), - c(sample_id_column, batch_id_column)) + c(sample_id_column, batch_id_column) + ) - if (length(overlap_cols) > 0) { - stop(paste( + if (length(overlap_cols) > 0L) { + ..error(paste( "datasets could not be merged by sample and batch identifiers", "as one or more columns with the same name appear in both the left and", - "right-hand datasets:", paste_s(overlap_cols))) + "right-hand datasets:", paste_s(overlap_cols) + )) } # Perform full join @@ -220,59 +238,76 @@ x = data, y = data_list[[ii]], on = c(sample_id_column, batch_id_column), - all = TRUE) + all = TRUE + ) - } else if (!is.null(sample_id_column) && - !is.null(batch_id_column) && - !is.null(series_id_column)) { + } else if ( + !is.null(sample_id_column) && + !is.null(batch_id_column) && + !is.null(series_id_column) + ) { # Attempt full join on sample_id_column, batch_id_column, and # series_id_column provided that other column names are not # overlapping, and all sample_ids and series_ids for a batch are # unique. # Check if the sample identifier columns is presents in the data. - if (!sample_id_column %in% colnames(data) || - !sample_id_column %in% colnames(data_list[[ii]])) { - stop(paste( + if ( + !sample_id_column %in% colnames(data) || + !sample_id_column %in% colnames(data_list[[ii]]) + ) { + ..error(paste( "The specified column of sample identifiers", sample_id_column, - "was not found in one or more of the datasets.")) + "was not found in one or more of the datasets." + )) } # Check if the batch identifier column is present in the data. - if (!batch_id_column %in% colnames(data) || - !batch_id_column %in% colnames(data_list[[ii]])) { - stop(paste( + if ( + !batch_id_column %in% colnames(data) || + !batch_id_column %in% colnames(data_list[[ii]]) + ) { + ..error(paste( "The specified column of batch identifiers", batch_id_column, - "was not found in one or more of the datasets.")) + "was not found in one or more of the datasets." + )) } # Check if the series identifier column is present in the data. - if (!series_id_column %in% colnames(data) || - !series_id_column %in% colnames(data_list[[ii]])) { - stop(paste( + if ( + !series_id_column %in% colnames(data) || + !series_id_column %in% colnames(data_list[[ii]]) + ) { + ..error(paste( "The specified column of series identifiers", series_id_column, - "was not found in one or more of the datasets.")) + "was not found in one or more of the datasets." + )) } # Check uniqueness of identifiers - if (anyDuplicated(data[, mget(sample_id_column, batch_id_column, series_id_column)]) > 0 || - anyDuplicated(data_list[[ii]][, mget(sample_id_column, batch_id_column, series_id_column)]) > 0) { - stop(paste( + if ( + anyDuplicated(data[, mget(sample_id_column, batch_id_column, series_id_column)]) > 0L || + anyDuplicated(data_list[[ii]][, mget(sample_id_column, batch_id_column, series_id_column)]) > 0L + ) { + ..error(paste( "Sample identifiers were not uniquely specified within each batch.", "In case this is intentional, i.e. for repeated measurements, please merge the", - "datasets yourself prior to input.")) + "datasets yourself prior to input." + )) } # Check for column overlap overlap_cols <- setdiff( intersect(colnames(data), colnames(data_list[[ii]])), - c(sample_id_column, batch_id_column, series_id_column)) + c(sample_id_column, batch_id_column, series_id_column) + ) - if (length(overlap_cols) > 0) { - stop(paste( + if (length(overlap_cols) > 0L) { + ..error(paste( "datasets could not be merged by sample, batch and series identifiers", "as one or more columns with the same name appear in both the left and", - "right-hand datasets:", paste_s(overlap_cols))) + "right-hand datasets:", paste_s(overlap_cols) + )) } # Perform full join @@ -280,38 +315,47 @@ x = data, y = data_list[[ii]], on = c(sample_id_column, batch_id_column, series_id_column), - all = TRUE) + all = TRUE + ) } else { # Attempt full join on sample_id_column, provided that other column # names do not overlap, and all sample ids are unique. # Check if the sample identifier columns is presents in the data - if (!sample_id_column %in% colnames(data) || - !sample_id_column %in% colnames(data_list[[ii]])) { - stop(paste( + if ( + !sample_id_column %in% colnames(data) || + !sample_id_column %in% colnames(data_list[[ii]]) + ) { + ..error(paste( "The specified column of sample identifiers", sample_id_column, - "was not found in one or more of the datasets.")) + "was not found in one or more of the datasets." + )) } # Determine if all sample identifiers are unique - if (anyDuplicated(data[, sample_id_column, with = FALSE]) > 0 || - anyDuplicated(data_list[[ii]][, sample_id_column, with = FALSE]) > 0) { - stop(paste0( + if ( + anyDuplicated(data[, mget(sample_id_column)]) > 0L || + anyDuplicated(data_list[[ii]][, mget(sample_id_column)]) > 0L + ) { + ..error(paste0( "Sample identifiers were not uniquely specified. In case this is intentional, ", - "i.e. for repeated measurements, please merge the datasets yourself prior to input.")) + "i.e. for repeated measurements, please merge the datasets yourself prior to input." + )) } # Check for column overlap. overlap_cols <- setdiff( intersect(colnames(data), colnames(data_list[[ii]])), - sample_id_column) + sample_id_column + ) - if (length(overlap_cols) > 0) { - stop(paste0( + if (length(overlap_cols) > 0L) { + ..error(paste0( "Datasets could not be merged by sample identifiers as one or more ", "columns with the same name appear in both the left and ", - "right-hand datasets: ", paste_s(overlap_cols))) + "right-hand datasets: ", paste_s(overlap_cols) + )) } # Perform full join. @@ -319,17 +363,23 @@ x = data, y = data_list[[ii]], on = sample_id_column, - all = TRUE) + all = TRUE + ) } } + } else { - data <- data_list[[1]] + data <- data_list[[1L]] } + } else { - data <- data_list[[1]] + data <- data_list[[1L]] } } else { - stop("Data is expected to be a data.table, data.frame, a path towards a file or a vector or list of the above.") + ..error(paste0( + "Data is expected to be a data.table, data.frame, ", + "a path towards a file or a vector or list of the above." + )) } if (is_empty(data)) ..error_data_set_is_empty() @@ -395,7 +445,9 @@ event_indicator, competing_risk_indicator, check_stringency = "strict", - reference_method = "auto") { + reference_method = "auto", + .no_features_required = FALSE +) { # Suppress NOTES due to non-standard evaluation in data.table sample_id <- batch_id <- n <- NULL @@ -411,13 +463,15 @@ id_column = sample_id_column, data = data, include_features = include_features, - col_type = "sample") + col_type = "sample" + ) # Rename column data.table::setnames( x = data, old = sample_id_column, - new = "sample_id") + new = "sample_id" + ) } else { # Create new column with sample ids. @@ -438,7 +492,8 @@ data.table::setnames( x = data, old = batch_id_column, - new = "batch_id") + new = "batch_id" + ) # Check data type of the batch_id column and change to character. Cohort # names are parsed as characters, not integers. @@ -459,7 +514,8 @@ censoring_indicator = censoring_indicator, event_indicator = event_indicator, competing_risk_indicator = competing_risk_indicator, - check_stringency = check_stringency) + check_stringency = check_stringency + ) if (outcome_type %in% c("survival")) { # Add survival columns @@ -472,7 +528,8 @@ data = data, censoring_indicator = censoring_indicator, event_indicator = event_indicator, - competing_risk_indicator = competing_risk_indicator) + competing_risk_indicator = competing_risk_indicator + ) # The plausibility already took care of consistency checking. This means # that there is one and only one event status column and the other @@ -484,22 +541,24 @@ # For other stringency levels, outcome columns are assumed to be # extracted from familiarModel or familiarEnsemble objects, which # already contain ordered values. - time_column <- outcome_column[1] - event_column <- outcome_column[2] + time_column <- outcome_column[1L] + event_column <- outcome_column[2L] } # Rename columns data.table::setnames( x = data, old = c(time_column, event_column), - new = get_outcome_columns(x = outcome_type)) + new = get_outcome_columns(x = outcome_type) + ) } else { # Rename outcome column data.table::setnames( x = data, old = outcome_column, - new = get_outcome_columns(x = outcome_type)) + new = get_outcome_columns(x = outcome_type) + ) } } else if (outcome_type %in% c("survival", "competing_risk")) { @@ -510,7 +569,7 @@ # Create new columns and set to NA for (current_outcome_col in outcome_column) { - data[, (current_outcome_col) := NA] + data[, (current_outcome_col) := NA_real_] } } else if (outcome_type %in% c("binomial", "multinomial")) { @@ -520,7 +579,7 @@ # Generate outcome column with NA values data[, (outcome_column) := NA_character_] - } else if (outcome_type %in% c("count", "continuous")) { + } else if (outcome_type %in% c("continuous")) { # Find outcome column names outcome_column <- get_outcome_columns(x = outcome_type) @@ -544,43 +603,47 @@ outcome_type = outcome_type, outcome_column = "outcome", class_levels = class_levels, - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Set class levels. This may involve reordering class levels in case the # outcome already was a factor. data$outcome <- factor( x = data$outcome, levels = class_levels, - exclude = NA) + exclude = NA + ) } else if (!is.factor(data$outcome)) { # Convert to factors data$outcome <- factor( x = data$outcome, levels = unique(data$outcome), - exclude = c(NA, "NA", "NAN", "na", "nan", "NaN")) + exclude = c(NA, "NA", "NAN", "na", "nan", "NaN") + ) } } # Check survival time for positivity. if (outcome_type %in% c("survival", "competing_risk")) { - time_column <- get_outcome_columns(x = outcome_type)[1] + time_column <- get_outcome_columns(x = outcome_type)[1L] .check_survival_time_plausibility( data = data, outcome_column = time_column, outcome_type = outcome_type, - check_stringency = check_stringency) + check_stringency = check_stringency + ) # Convert outcome_event to 0s and 1s. replacement_outcome_event <- numeric(length(data$outcome_event)) - replacement_outcome_event[data$outcome_event %in% censoring_indicator] <- 0 - replacement_outcome_event[data$outcome_event %in% event_indicator] <- 1 + replacement_outcome_event[data$outcome_event %in% censoring_indicator] <- 0L + replacement_outcome_event[data$outcome_event %in% event_indicator] <- 1L # Update competing risk indicators. - if (length(competing_risk_indicator) > 0) { + if (length(competing_risk_indicator) > 0L) { for (ii in seq_along(competing_risk_indicator)) { - replacement_outcome_event[data$outcome_event %in% competing_risk_indicator[ii]] <- ii + 1 + replacement_outcome_event[data$outcome_event %in% competing_risk_indicator[ii]] <- ii + 1L } } @@ -598,13 +661,15 @@ id_column = series_id_column, data = data, include_features = include_features, - col_type = "series") + col_type = "series" + ) # Rename column data.table::setnames( x = data, old = series_id_column, - new = "series_id") + new = "series_id" + ) # Check data type of the series_id column and change to character. Series # identifiers are parsed as characters, not integers. @@ -619,24 +684,29 @@ data <- merge( x = data, y = temp_data, - by = c("sample_id", "batch_id", outcome_cols)) + by = c("sample_id", "batch_id", outcome_cols) + ) } # Add repetition identifiers - data[, "repetition_id" := seq_len(.N), - by = c("sample_id", "batch_id", "series_id", outcome_cols)] + data[ + , + "repetition_id" := seq_len(.N), + by = c("sample_id", "batch_id", "series_id", outcome_cols) + ] # Check that there are all combinations of sample_id, batch_id and series_id # have the same outcome. single_outcome_samples <- unique(data, by = c("sample_id", "batch_id", "series_id", outcome_cols)) single_outcome_samples <- single_outcome_samples[, list("n" = .N), by = c("sample_id", "batch_id", "series_id")] - if (any(single_outcome_samples$n > 1)) { - single_outcome_samples <- single_outcome_samples[n > 1] + if (any(single_outcome_samples$n > 1L)) { + single_outcome_samples <- single_outcome_samples[n > 1L] single_outcome_samples[, "descriptor" := paste0(sample_id, " (", batch_id, ")")] - stop(paste0( + ..error(paste0( "One or more samples with the same identifier do not have the same outcome value: ", - paste_s(single_outcome_samples$descriptor))) + paste_s(single_outcome_samples$descriptor) + )) } # Determine which columns to maintain @@ -644,32 +714,146 @@ # Check presence of features in include_features in the data .check_feature_availability( data = data, - feature = include_features) + feature = include_features + ) # Select only features marked for inclusion, as well as identifier and outcome columns data <- data[, mget(c(get_non_feature_columns(x = outcome_type), include_features))] } - # Check if the data actually contains any features at this point - if (!has_feature_data(x = data, outcome_type = outcome_type)) { - ..error_data_set_has_no_features() + # Perform feature processing and checks. Skip if features are not required + # to be present. + if (!.no_features_required) { + # Check if the data actually contains any features at this point + if (!has_feature_data(x = data, outcome_type = outcome_type)) { + ..error_data_set_has_no_features() + } + + # Convert data to categorical features + data <- .parse_categorical_features( + data = data, + outcome_type = outcome_type, + reference_method = reference_method + ) + + # Convert integer data to double. This prevents rare errors later e.g., + # when aggregating data by computing a median value (that is not guaranteed to + # be an integer). + data <- .parse_integer_features( + data = data, + outcome_type = outcome_type + ) } + + return(data) +} - # Convert data to categorical features - data <- .parse_categorical_features( - data = data, - outcome_type = outcome_type, - reference_method = reference_method) - # Convert integer data to double. This prevents rare errors later e.g., - # when aggregating data by computing a median value (that is not guaranteed to - # be an integer). - data <- .parse_integer_features( + +.check_data_plausibility <- function( + data, + settings, + message_indent = 0L, + verbose = TRUE, + cl = NULL +) { + # Avoid CRAN NOTE due to non-standard evaluation in data.table. + score <- NULL + + logger_message( + "Setup report: Preliminary data-checks.", + indent = message_indent, + verbose = verbose + ) + + feature_cols <- get_feature_columns(data, outcome_type = settings$data$outcome_type) + outcome_cols <- get_outcome_columns(settings$data$outcome_type) + + # Plausibility checks: duplicate rows. + if (anyDuplicated(data[, mget(c(feature_cols, outcome_cols))]) > 0L) { + logger_warning( + paste0( + "Ignoring identifiers, one or more rows in the dataset may contain duplicated data. ", + "This means the same combination of feature values and outcome appears multiple times." + ), + warn_class = "familiar_data_check" + ) + } + + + # Plausibility checks: invariant features. + invariant_features <- fam_sapply( + cl = cl, + assign = NULL, + X = data[, mget(feature_cols)], + FUN = is_singular_data, + progress_bar = FALSE, + chopchop = TRUE + ) + + invariant_features <- feature_cols[invariant_features] + if (length(invariant_features) > 0L) { + logger_warning( + paste0( + "The following features are invariant: ", + paste_s(invariant_features), + "." + ), + warn_class = "familiar_data_check" + ) + } + + + # Plausibility checks: one-to-one predictors + + # Convert to dataObject. We pretend that the data are preprocessed up to + # clustering. + data <- methods::new( + "dataObject", data = data, - outcome_type = outcome_type + preprocessing_level = "clustering", + outcome_type = settings$data$outcome_type, + outcome_info = create_outcome_info(settings = settings), + data_column_info = create_data_column_info(settings = settings) ) - return(data) + # Add generic feature information. + generic_feature_info_task <- new("familiarTaskGenericFeatureInfo") + generic_feature_info <- .perform_task( + object = generic_feature_info_task, + data = data + ) + + # Set up vimp object and promote to concordance. + vimp_object <- promote_vimp_method(methods::new( + "familiarVimpMethod", + outcome_type = data@outcome_type, + outcome_info = data@outcome_info, + feature_info = generic_feature_info, + vimp_method = "concordance" + )) + + # Compute concordance. + vimp_table <- suppressWarnings(get_vimp_table(.vimp( + object = vimp_object, + data = data, + cl = cl + ))) + + # Identify features with perfect concordance (1.0) or discordance (also 1.0), + # and warn. + if (any(vimp_table$score == 1.0)) { + logger_warning( + paste0( + "The following features are perfect predictors for the outcome: ", + paste_s(vimp_table[score == 1.0]$name), + ". Please ensure that there are no outcome data included as features." + ), + warn_class = "familiar_data_check" + ) + } + + return(invisible(TRUE)) } @@ -737,7 +921,8 @@ .parse_categorical_features <- function( data, outcome_type, - reference_method = "auto") { + reference_method = "auto" +) { # Replace columns types so that only numeric and categorical features remain # Check presence of feature columns @@ -750,18 +935,20 @@ column_class <- lapply( feature_columns, function(ii, data) (class(data[[ii]])), - data = data) + data = data + ) # Identify categorical columns categorical_columns <- sapply( column_class, function(selected_column_class) { any(selected_column_class %in% c("logical", "character", "factor")) - }) + } + ) categorical_columns <- feature_columns[categorical_columns] # Do not update data if there are no columns for categorical data - if (length(categorical_columns) == 0) return(data) + if (length(categorical_columns) == 0L) return(data) # Generate a list of warnings. warning_list <- list() @@ -799,8 +986,8 @@ } # Raise an error in case there are missing class levels for any feature. - if (length(warning_list) > 0) { - stop(paste(warning_list, collapse = "\n")) + if (length(warning_list) > 0L) { + ..error(paste(warning_list, collapse = "\n")) } return(data) @@ -859,15 +1046,18 @@ update_data_set <- function(data, object) { # Check if the classes of the input is correct. if (!data.table::is.data.table(data)) { - stop("update_data_set: data is not a data.table") + ..error("update_data_set: data is not a data.table") } - if (!(is(object, "familiarModel") || - is(object, "familiarEnsemble") || - is(object, "familiarNoveltyDetector"))) { - stop(paste0( + if (!( + is(object, "familiarModel") || + is(object, "familiarEnsemble") || + is(object, "familiarNoveltyDetector") + )) { + ..error(paste0( "update_data_set: object is not a familiarModel, familiarNoveltyDetector ", - "or a familiarEnsemble.")) + "or a familiarEnsemble." + )) } # Find the outcome type. @@ -892,44 +1082,52 @@ update_data_set <- function(data, object) { if (object@outcome_info@ordered && !is.ordered(data[[outcome_column]])) { data[[outcome_column]] <- ordered( x = data[[outcome_column]], - levels = object@outcome_info@levels) + levels = object@outcome_info@levels + ) } else if (!object@outcome_info@ordered && !is.factor(data[[outcome_column]])) { data[[outcome_column]] <- factor( x = data[[outcome_column]], - levels = object@outcome_info@levels) + levels = object@outcome_info@levels + ) } # Check that the data does not have extra levels. extra_levels <- setdiff( levels(data[[outcome_column]]), - object@outcome_info@levels) + object@outcome_info@levels + ) - if (length(extra_levels > 0)) { + if (length(extra_levels) > 0L) { warning_list <- c( warning_list, paste0( "The outcome column contains the following ", - ifelse(length(extra_levels) > 1, "levels", "level"), + ifelse(length(extra_levels) > 1L, "levels", "level"), " that were not found in the original dataset: ", - paste_s(extra_levels), "; original: ", paste_s(object@outcome_info@levels))) + paste_s(extra_levels), "; original: ", paste_s(object@outcome_info@levels) + ) + ) } else { # Ensure that order is correct. data[[outcome_column]] <- factor( x = data[[outcome_column]], levels = object@outcome_info@levels, - ordered = object@outcome_info@ordered) + ordered = object@outcome_info@ordered + ) } } } # TODO: When we start supporting transformation and normalisation # parameters for outcome, process the data here. - if (outcome_type %in% c("count", "continuous")) { + if (outcome_type %in% c("continuous")) { if (is(object@outcome_info, "outcomeInfo")) { - if (!is.null(object@outcome_info@transformation_parameters) || - !is.null(object@outcome_info@normalisation_parameters)) { + if ( + !is.null(object@outcome_info@transformation_parameters) || + !is.null(object@outcome_info@normalisation_parameters) + ) { browser() } } @@ -944,14 +1142,16 @@ update_data_set <- function(data, object) { non_feature_columns <- get_non_feature_columns(outcome_type) missing_non_feature_columns <- setdiff(non_feature_columns, all_columns) - if (length(missing_non_feature_columns) > 0) { + if (length(missing_non_feature_columns) > 0L) { warning_list <- c( warning_list, paste0( "The following non-feature ", - ifelse(length(missing_non_feature_columns) > 1, "columns are", "column is"), + ifelse(length(missing_non_feature_columns) > 1L, "columns are", "column is"), " missing in the dataset: ", - paste_s(missing_non_feature_columns))) + paste_s(missing_non_feature_columns) + ) + ) } # Remove non-feature columns from the check. @@ -969,7 +1169,7 @@ update_data_set <- function(data, object) { } # Check presence of features. - if (length(required_features) > 0 && length(model_and_novelty_features) > 0) { + if (length(required_features) > 0L && length(model_and_novelty_features) > 0L) { if (all(required_features %in% all_columns)) { available_features <- required_features @@ -984,20 +1184,22 @@ update_data_set <- function(data, object) { warning_list, paste0( "The following feature ", - ifelse(length(missing_feature_columns) > 1, "columns are", "column is"), + ifelse(length(missing_feature_columns) > 1L, "columns are", "column is"), " missing in the dataset: ", - paste_s(missing_feature_columns)) + paste_s(missing_feature_columns) + ) ) # Select features that are available. available_features <- intersect(model_and_novelty_features, all_columns) - if (length(available_features) == 0) { + if (length(available_features) == 0L) { warning_list <- c( warning_list, paste0( "No additional feature-specific details could be assessed because ", - "none of the features appear in the dataset.") + "none of the features appear in the dataset." + ) ) } } @@ -1020,7 +1222,8 @@ update_data_set <- function(data, object) { warning_list, paste0( "The ", feature, " column contain a numeric feature. Found: ", - typeof(data[[feature]])) + typeof(data[[feature]]) + ) ) } @@ -1036,30 +1239,34 @@ update_data_set <- function(data, object) { # Check for extra levels. Note that fewer levels is fine. extra_levels <- setdiff(levels_present, feature_info@levels) - if (length(extra_levels > 0)) { + if (length(extra_levels) > 0L) { warning_list <- c( warning_list, paste0( "The ", feature, " column contains the following ", - ifelse(length(extra_levels) > 1, "levels", "level"), + ifelse(length(extra_levels) > 1L, "levels", "level"), " that were not found in the original dataset: ", - paste_s(extra_levels), "; original: ", paste_s(feature_info@levels))) + paste_s(extra_levels), "; original: ", paste_s(feature_info@levels) + ) + ) } else { # Ensure that order of levels in the data is correct. data[[feature]] <- factor(data[[feature]], levels = feature_info@levels, - ordered = feature_info@ordered) + ordered = feature_info@ordered + ) } } else { ..error_reached_unreachable_code(paste0( "update_data_set: unknown feature type encountered: ", - feature_info@feature_type)) + feature_info@feature_type + )) } } # Raise an error in case there was any error for any feature. - if (length(warning_list) > 0) stop(paste(warning_list, collapse = "\n\n")) + if (length(warning_list) > 0L) ..error(paste(warning_list, collapse = "\n\n")) return(data) } diff --git a/R/ParseSettings.R b/R/ParseSettings.R index 01383c59..5e150e4a 100644 --- a/R/ParseSettings.R +++ b/R/ParseSettings.R @@ -56,7 +56,8 @@ experiment_dir = waiver(), data_file = waiver(), verbose = TRUE, - ...) { + ... +) { # Initialise list of file paths file_paths <- list() @@ -68,7 +69,8 @@ var_name = "project_dir", type = "character", optional = TRUE, - default = NULL) + default = NULL + ) # Read experiment directory path and create the directory if required experiment_dir <- .parse_arg( @@ -77,7 +79,8 @@ var_name = "experiment_dir", type = "character", optional = TRUE, - default = NULL) + default = NULL + ) # Set temporary directory flag to FALSE by default. file_paths$is_temporary <- FALSE @@ -100,8 +103,8 @@ } else { # Case 3. project_dir exists and experiment_dir is a subdirectory. experiment_dir <- normalizePath( - file.path(project_dir, experiment_dir), mustWork = FALSE) - + file.path(project_dir, experiment_dir), mustWork = FALSE + ) } } else { @@ -138,48 +141,66 @@ # Log file - set as global variable as well if (!file_paths$is_temporary) { - file_paths$log_file <- normalizePath(file.path(experiment_dir, "log.txt"), mustWork = FALSE) + file_paths$log_file <- normalizePath( + file.path(experiment_dir, "log.txt"), + mustWork = FALSE + ) } # Assign to global environment. assign( "log_file", file_paths$log_file, - envir = familiar_global_env) + envir = familiar_global_env + ) # Directory for iterations file_paths$iterations_dir <- normalizePath( - experiment_dir, mustWork = FALSE) + experiment_dir, + mustWork = FALSE + ) if (!dir.exists(file_paths$iterations_dir)) dir.create(file_paths$iterations_dir) # Directory for pre-processing file_paths$process_data_dir <- normalizePath( - experiment_dir, mustWork = FALSE) + experiment_dir, + mustWork = FALSE + ) if (!dir.exists(file_paths$process_data_dir)) dir.create(file_paths$process_data_dir) - # Directory for feature selection - file_paths$fs_dir <- normalizePath( - file.path(experiment_dir, "variable_importance"), mustWork = FALSE) - if (!dir.exists(file_paths$fs_dir)) dir.create(file_paths$fs_dir) + # Directory for variable importance + file_paths$vimp_dir <- normalizePath( + file.path(experiment_dir, "variable_importance"), + mustWork = FALSE + ) + if (!dir.exists(file_paths$vimp_dir)) dir.create(file_paths$vimp_dir) # Directory and files for model building file_paths$mb_dir <- normalizePath( - file.path(experiment_dir, "trained_models"), mustWork = FALSE) + file.path(experiment_dir, "trained_models"), + mustWork = FALSE + ) if (!dir.exists(file_paths$mb_dir)) dir.create(file_paths$mb_dir) # Directory for familiarData objects file_paths$fam_data_dir <- normalizePath( - file.path(experiment_dir, "familiar_data"), mustWork = FALSE) + file.path(experiment_dir, "familiar_data"), + mustWork = FALSE + ) if (!dir.exists(file_paths$fam_data_dir)) dir.create(file_paths$fam_data_dir) # Directory for familiarDataCollection objects file_paths$fam_coll_dir <- normalizePath( - file.path(experiment_dir, "familiar_collections"), mustWork = FALSE) + file.path(experiment_dir, "familiar_collections"), + mustWork = FALSE + ) if (!dir.exists(file_paths$fam_coll_dir)) dir.create(file_paths$fam_coll_dir) # Create results directory file_paths$results_dir <- normalizePath( - file.path(experiment_dir, "results"), mustWork = FALSE) + file.path(experiment_dir, "results"), + mustWork = FALSE + ) if (!dir.exists(file_paths$results_dir)) dir.create(file_paths$results_dir) # Data file location @@ -189,7 +210,8 @@ var_name = "data_file", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(data_file)) { # Iterate over data file(s) to determine the full path @@ -204,20 +226,24 @@ return(file.path(project_dir, curr_data_file)) } else { - stop(paste( + ..error(paste( "Data could not be found. A file was expected at:", - curr_data_file, "or at", file.path(project_dir, curr_data_file))) + curr_data_file, "or at", file.path(project_dir, curr_data_file) + )) } }, - project_dir = project_dir) + project_dir = project_dir + ) } if (file_paths$is_temporary) { logger_message( paste0( "Configuration: A temporary R directory is created for the analysis: ", - temporary_directory), - verbose = verbose) + temporary_directory + ), + verbose = verbose + ) } return(file_paths) @@ -234,6 +260,7 @@ #' #' @param config A list of settings, e.g. from an xml file. #' @inheritDotParams .parse_experiment_settings -config +#' @inheritDotParams .parse_setup_settings -config #' #' @details Three variants of parameters exist: #' @@ -257,7 +284,18 @@ .parse_experiment_settings, args = c( list("config" = config$data), - list(...))) + list(...) + ) + ) + + # Computational setup settings + settings$run <- do.call_strict( + .parse_setup_settings, + args = c( + list("config" = config$run), + list(...) + ) + ) return(settings) } @@ -272,16 +310,14 @@ #' @param data Data set as loaded using the `.load_data` function. #' @inheritDotParams .parse_setup_settings -config #' @inheritDotParams .parse_preprocessing_settings -data -config -parallel -outcome_type -#' @inheritDotParams .parse_feature_selection_settings -data -config -parallel -outcome_type +#' @inheritDotParams .parse_variable_importance_settings -data -config -parallel -outcome_type #' @inheritDotParams .parse_model_development_settings -data -config -parallel -outcome_type #' @inheritDotParams .parse_hyperparameter_optimisation_settings -config -parallel -outcome_type #' @inheritDotParams .parse_evaluation_settings -config -data -parallel -outcome_type -hpo_metric -development_batch_id -vimp_aggregation_rank_threshold -vimp_aggregation_method -prep_cluster_method -prep_cluster_linkage_method -prep_cluster_cut_method -prep_cluster_similarity_threshold -prep_cluster_similarity_metric #' #' @return A list of settings to be used within the workflow #' -#' @references 1. Storey, J. D. A direct approach to false discovery rates. J. -#' R. Stat. Soc. Series B Stat. Methodol. 64, 479–498 (2002). -#' +#' @references #' 1. Shrout, P. E. & Fleiss, J. L. Intraclass correlations: uses in assessing #' rater reliability. Psychol. Bull. 86, 420–428 (1979). #' @@ -298,6 +334,10 @@ #' 1. Raymaekers, J., Rousseeuw, P. J. Transforming variables to central #' normality. Mach Learn. (2021). #' +#' 1. Zwanenburg, A., & Löck, S. (2026). Location and scale-invariant power +#' transformations for transforming data to normality. Machine Learning, +#' 115(3), 34. +#' #' 1. Park, M. Y., Hastie, T. & Tibshirani, R. Averaged gene expressions for #' regression. Biostatistics 8, 212–227 (2007). #' @@ -387,13 +427,18 @@ #' @md #' @keywords internal .parse_general_settings <- function(settings, config = NULL, data, ...) { - # Computational setup settings - settings$run <- do.call_strict( - .parse_setup_settings, - args = c( - list("config" = config$run), - list(...))) - + + if (is.null(settings$run)) { + # Run may already be set by .parse_initial_settings. + settings$run <- do.call_strict( + .parse_setup_settings, + args = c( + list("config" = config$run), + list(...) + ) + ) + } + # Remove outcome_type, development_batch_id and parallel from ... This # prevents an error caused by multiple matching arguments. dots <- list(...) @@ -408,19 +453,25 @@ "config" = config$preprocessing, "data" = data, "parallel" = settings$run$parallel, - "outcome_type" = settings$data$outcome_type), - dots)) + "outcome_type" = settings$data$outcome_type + ), + dots + ) + ) - # Feature selection settings - settings$fs <- do.call_strict( - .parse_feature_selection_settings, + # Variable importance settings + settings$vimp <- do.call_strict( + .parse_variable_importance_settings, args = c( list( - "config" = config$feature_selection, + "config" = config$variable_importance, "data" = data, "parallel" = settings$run$parallel, - "outcome_type" = settings$data$outcome_type), - dots)) + "outcome_type" = settings$data$outcome_type + ), + dots + ) + ) # Model development settings settings$mb <- do.call_strict( @@ -430,8 +481,11 @@ "config" = config$model_development, "data" = data, "parallel" = settings$run$parallel, - "outcome_type" = settings$data$outcome_type), - dots)) + "outcome_type" = settings$data$outcome_type + ), + dots + ) + ) # Hyperparameter optimisation settings settings$hpo <- do.call_strict( @@ -440,8 +494,11 @@ list( "config" = config$hyperparameter_optimisation, "parallel" = settings$run$parallel, - "outcome_type" = settings$data$outcome_type), - dots)) + "outcome_type" = settings$data$outcome_type + ), + dots + ) + ) # Remove development_batch_id, hpo_metric, vimp_aggregation_method and # vimp_aggregation_rank_threshold from ... This prevents an error caused by @@ -462,19 +519,22 @@ "outcome_type" = settings$data$outcome_type, "hpo_metric" = settings$hpo$hpo_metric, "development_batch_id" = settings$data$train_cohorts, - "vimp_aggregation_method" = settings$fs$aggregation, - "vimp_aggregation_rank_threshold" = settings$fs$aggr_rank_threshold, + "vimp_aggregation_method" = settings$vimp$aggregation, + "vimp_aggregation_rank_threshold" = settings$vimp$aggr_rank_threshold, "prep_cluster_method" = settings$prep$cluster_method, "prep_cluster_linkage_method" = settings$prep$cluster_linkage, "prep_cluster_cut_method" = settings$prep$cluster_cut_method, "prep_cluster_similarity_threshold" = settings$prep$cluster_similarity_threshold, - "prep_cluster_similarity_metric" = settings$prep$cluster_similarity_metric), - dots)) + "prep_cluster_similarity_metric" = settings$prep$cluster_similarity_metric + ), + dots + ) + ) # Set the general parallel switch to FALSE if all workflow steps disabled # parallel processing. settings$run$parallel <- settings$prep$do_parallel || - settings$fs$do_parallel || + settings$vimp$do_parallel || settings$mb$do_parallel || settings$hpo$do_parallel %in% c("TRUE", "inner", "outer") || settings$eval$do_parallel %in% c("TRUE", "inner", "outer") @@ -520,7 +580,7 @@ #' details. #' #' If unset, every row will be identified as a single sample. -#' @param series_id_column (**optional**) Name of the column containing series +#' @param series_id_column (*optional*) Name of the column containing series #' identifiers, which distinguish between measurements that are part of a #' series for a single sample. See `batch_id_column` above for more details. #' @@ -541,8 +601,8 @@ #' be used in figures created by `familiar`. #' #' If not set, the column name in `outcome_column` will be used for -#' `binomial`, `multinomial`, `count` and `continuous` outcomes. For other -#' outcomes (`survival` and `competing_risk`) no default is used. +#' `binomial`, `multinomial`, and `continuous` outcomes. For other outcomes +#' (`survival` and `competing_risk`) no default is used. #' #' @param outcome_column (**recommended**) Name of the column containing the #' outcome of interest. May be identified from a formula, if a formula is @@ -553,7 +613,7 @@ #' #' @param outcome_type (**recommended**) Type of outcome found in the outcome #' column. The outcome type determines many aspects of the overall process, -#' e.g. the available feature selection methods and learners, but also the +#' e.g. the available variable importance methods and learners, but also the #' type of assessments that can be conducted to evaluate the resulting models. #' Implemented outcome types are: #' @@ -561,8 +621,6 @@ #' #' * `multinomial`: categorical outcome with 2 or more levels. #' -#' * `count`: Poisson-distributed numeric outcomes. -#' #' * `continuous`: general continuous numeric outcomes. #' #' * `survival`: survival outcome for time-to-event data. @@ -572,7 +630,8 @@ #' therefore advise to provide this information manually. #' #' Note that `competing_risk` survival analysis are not fully supported, and -#' is currently not a valid choice for `outcome_type`. +#' is currently not a valid choice for `outcome_type`. The `count` outcome +#' type was deprecated in version 2.0.0, and superseded by `continuous`. #' #' @param class_levels (*optional*) Class levels for `binomial` or `multinomial` #' outcomes. This argument can be used to specify the ordering of levels for @@ -598,7 +657,7 @@ #' #' @param signature (*optional*) One or more names of feature columns that are #' considered part of a specific signature. Features specified here will -#' always be used for modelling. Ranking from feature selection has no effect +#' always be used for modelling. Ranking of variable importances has no effect #' for these features. #' #' @param novelty_features (*optional*) One or more names of feature columns @@ -633,10 +692,13 @@ #' #' @param experimental_design (**required**) Defines what the experiment looks #' like, e.g. `cv(bt(fs,20)+mb,3,2)+ev` for 2 times repeated 3-fold -#' cross-validation with nested feature selection on 20 bootstraps and -#' model-building, and external validation. The basic workflow components are: +#' cross-validation with nested variable importance computation on 20 +#' bootstraps and model-building, and external validation. The basic workflow +#' components are: #' -#' * `fs`: (required) feature selection step. +#' * `fs`: (optional) variable importance computation step. If not explicitly +#' declared, feature selection will be done just in time for hyperparameter +#' optimisation. #' #' * `mb`: (required) model building step. #' @@ -704,6 +766,10 @@ #' @param imbalance_n_partitions (*optional*) Number of times random #' undersampling should be repeated. 10 undersampled subsets with balanced #' classes are formed by default. +#' @param iteration_seed (*optional*) Integer seed used in sampling algorithms +#' specified by the `experimental_design` argument. This allows for creating +#' the same sample assignments across different experiments -- of course +#' provided that the same dataset is used. By default a random seed is used. #' @param ... Unused arguments. #' #' @return List of parameters related to data parsing and the experiment. @@ -731,7 +797,9 @@ experimental_design = waiver(), imbalance_correction_method = waiver(), imbalance_n_partitions = waiver(), - ...) { + iteration_seed = waiver(), + ... +) { settings <- list() # experimental_design -------------------------------------------------------- @@ -741,7 +809,8 @@ x_var = experimental_design, var_name = "experimental_design", optional = FALSE, - type = "character") + type = "character" + ) # imbalance_method ----------------------------------------------------------- # Class imbalance correction method @@ -751,12 +820,14 @@ var_name = "imbalance_correction_method", type = "character", optional = TRUE, - default = "full_undersampling") + default = "full_undersampling" + ) .check_parameter_value_is_valid( x = settings$imbalance_method, var_name = "imbalance_correction_method", - values = c("full_undersampling", "random_undersampling")) + values = c("full_undersampling", "random_undersampling") + ) # imbalance_n_partitions ----------------------------------------------------- # Number of imbalance partitions for random undersampling @@ -766,13 +837,27 @@ var_name = "imbalance_n_partitions", type = "integer", optional = TRUE, - default = 10) + default = 10L + ) .check_number_in_valid_range( x = settings$imbalance_n_partitions, var_name = "imbalance_n_partitions", - range = c(1, Inf)) + range = c(1L, Inf) + ) + # iteration_seed ------------------------------------------------------------- + # Seed for sampling algorithms. + settings$iteration_seed <- .parse_arg( + x_config = config$iteration_seed, + x_var = iteration_seed, + var_name = "iteration_seed", + type = "integer", + optional = TRUE, + default = NULL + ) + + # sample_id_column ----------------------------------------------------------- # Sample identifier column settings$sample_col <- .parse_arg( @@ -781,7 +866,8 @@ var_name = "sample_id_colum", type = "character", optional = TRUE, - default = NULL) + default = NULL + ) # Update column name if (!is.null(settings$sample_col)) { @@ -796,7 +882,8 @@ var_name = "batch_id_column", type = "character", optional = TRUE, - default = NULL) + default = NULL + ) # Update column name if (!is.null(settings$batch_col)) { @@ -811,7 +898,8 @@ var_name = "series_id_column", type = "character", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$series_col)) { settings$series_col <- .replace_illegal_column_name(settings$series_col) @@ -825,7 +913,8 @@ var_name = "development_batch_id", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) # validation_batch_id -------------------------------------------------------- # Validation cohort identifier @@ -835,7 +924,8 @@ var_name = "validation_batch_id", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) # outcome_column ------------------------------------------------------------- # Outcome column(s) @@ -845,7 +935,8 @@ var_name = "outcome_column", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$outcome_col)) { settings$outcome_col <- .replace_illegal_column_name(settings$outcome_col) @@ -859,7 +950,8 @@ var_name = "outcome_type", type = "character", optional = TRUE, - default = NULL) + default = NULL + ) # outcome_name --------------------------------------------------------------- # Outcome name @@ -869,7 +961,8 @@ var_name = "outcome_name", type = "character", optional = TRUE, - default = NULL) + default = NULL + ) # class_levels --------------------------------------------------------------- # Class levels @@ -879,7 +972,8 @@ var_name = "class_levels", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) # event_indicator ------------------------------------------------------------ # Event indicator @@ -900,7 +994,8 @@ var_name = "censoring_indicator", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) # competing_risk_indicator --------------------------------------------------- # Competing risk indicator @@ -910,7 +1005,8 @@ var_name = "competing_risk_indicator", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) # signature ------------------------------------------------------------------ # Signature features @@ -920,7 +1016,8 @@ var_name = "signature", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$signature)) { settings$signature <- .replace_illegal_column_name(settings$signature) @@ -934,7 +1031,8 @@ var_name = "novelty_features", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$novelty_features)) { settings$novelty_features <- .replace_illegal_column_name(settings$novelty_features) @@ -948,7 +1046,8 @@ var_name = "include_features", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$include_features)) { settings$include_features <- .replace_illegal_column_name(settings$include_features) @@ -962,7 +1061,8 @@ var_name = "exclude_features", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$exclude_features)) { settings$exclude_features <- .replace_illegal_column_name(settings$exclude_features) @@ -977,12 +1077,14 @@ var_name = "reference_method", type = "character", optional = TRUE, - default = "auto") + default = "auto" + ) .check_parameter_value_is_valid( x = settings$reference_method, var_name = "reference_method", - values = c("auto", "always", "never")) + values = c("auto", "always", "never") + ) return(settings) } @@ -1037,7 +1139,8 @@ cluster_type = waiver(), backend_type = waiver(), server_port = waiver(), - ...) { + ... +) { settings <- list() # parallel ------------------------------------------------------------------- @@ -1048,7 +1151,8 @@ var_name = "parallel", type = "logical", optional = TRUE, - default = TRUE) + default = TRUE + ) # parallel_nr_cores ---------------------------------------------------------- # Maximum number of cores that a R may use @@ -1058,13 +1162,15 @@ var_name = "parallel_nr_cores", type = "integer", optional = TRUE, - default = 2L) + default = 2L + ) if (!is.null(settings$parallel_nr_cores)) { .check_number_in_valid_range( x = settings$parallel_nr_cores, var_name = "parallel_nr_cores", - range = c(1, parallel::detectCores())) + range = c(1L, parallel::detectCores()) + ) } # Set cores to 1 in case parallel processing is disabled. @@ -1078,7 +1184,8 @@ var_name = "restart_cluster", type = "logical", optional = TRUE, - default = FALSE) + default = FALSE + ) if (!settings$parallel) settings$restart_cluster <- FALSE @@ -1090,12 +1197,14 @@ var_name = "cluster_type", type = "character", optional = TRUE, - default = "psock") + default = "psock" + ) .check_parameter_value_is_valid( x = settings$cluster_type, var_name = "cluster_type", - values = c("psock", "fork", "mpi", "nws", "sock", "none")) + values = c("psock", "fork", "mpi", "nws", "sock", "none") + ) if (!settings$parallel) settings$cluster_type <- "none" @@ -1105,7 +1214,8 @@ require_package( x = "microbenchmark", purpose = "to make use of optimised parallel processing", - message_type = "backend_warning") + message_type = "backend_warning" + ) } # backend_type --------------------------------------------------------------- @@ -1116,17 +1226,20 @@ var_name = "backend_type", type = "character", optional = TRUE, - default = "none") + default = "none" + ) .check_parameter_value_is_valid( x = settings$backend_type, var_name = "backend_type", - values = .get_available_backend_types()) + values = .get_available_backend_types() + ) require_package( x = .required_packages_backend(settings$backend_type), purpose = "to use the requested backend (", settings$backend_type, ")", - message_type = "backend_error") + message_type = "backend_error" + ) # server_port ---------------------------------------------------------------- # RServe communications port @@ -1136,12 +1249,14 @@ var_name = "server_port", type = "integer", optional = TRUE, - default = 6311L) + default = 6311L + ) .check_number_in_valid_range( x = settings$server_port, var_name = "server_port", - range = c(1025, 49151)) + range = c(1025L, 49151L) + ) return(settings) } @@ -1179,7 +1294,7 @@ #' #' * `univariate_test`: Features undergo a univariate regression using an #' outcome-appropriate regression model. The p-value of the model coefficient -#' is collected. Features with coefficient p or q-value above the +#' is collected. Features with coefficient p-value above the #' `univariate_test_threshold` are subsequently filtered. #' #' * `robustness`: Features that are not sufficiently robust according to the @@ -1191,20 +1306,16 @@ #' values are always filtered, as these do not contain information. #' @param univariate_test_threshold (*optional*) Numeric value between `1.0` and #' `0.0` that determines which features are irrelevant and will be filtered by -#' the `univariate_test`. The p or q-values are compared to this threshold. +#' the `univariate_test`. p-values are compared to this threshold. #' All features with values above the threshold are filtered. The default #' value is `0.20`. #' @param univariate_test_threshold_metric (*optional*) Metric used with the to -#' compare the `univariate_test_threshold` against. The following metrics can +#' compare the `univariate_test_threshold` against. The following metric can #' be chosen: #' #' * `p_value` (default): The unadjusted p-value of each feature is used for #' to filter features. #' -#' * `q_value`: The q-value (Story, 2002), is used to filter features. Some -#' data sets may have insufficient samples to compute the q-value. The -#' `qvalue` package must be installed from Bioconductor to use this method. -#' #' @param univariate_test_max_feature_set_size (*optional*) Maximum size of the #' feature set after the univariate test. P or q values of features are #' compared against the threshold, but if the resulting data set would be @@ -1258,7 +1369,7 @@ #' #' * `yeo_johnson`: Transformation using the location and scale invariant #' version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -#' Zwanenburg and Löck, 2023). +#' Zwanenburg and Löck, 2026). #' #' * `yeo_johnson_robust` (default): A robust version of `yeo_johnson`. #' This method is less sensitive to outliers. @@ -1269,7 +1380,7 @@ #' #' * `box_cox`: Transformation using the location and scale invariant version #' of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -#' 2023). +#' 2026). #' #' * `box_cox_robust`: A robust version of `yeo_johnson`. This method is less #' sensitive to outliers. @@ -1292,12 +1403,12 @@ #' * `mle` (default): Optimisation using maximum likelihood estimation. #' #' * `cramer_von_mises`: Optimisation using the Cramér-von Mises -#' criterion. Zwanenburg and Löck (2023) found that this criterion was +#' criterion. Zwanenburg and Löck (2026) found that this criterion was #' relatively robust against outliers. #' #' @param transformation_gof_test_p_value (*optional*) Not all transformations #' will lead to features that are roughly normally distributed. Zwanenburg and -#' Löck (2023) established a empirical goodness-of-fit test for central +#' Löck (2026) established a empirical goodness-of-fit test for central #' normality. This parameter sets the significance for rejecting the #' null-hypothesis that a feature distribution is centrally normal. When the #' null-hypothesis is rejected, no transformation is performed. The default @@ -1586,9 +1697,7 @@ #' #' @return List of parameters related to preprocessing. #' -#' @references 1. Storey, J. D. A direct approach to false discovery rates. J. -#' R. Stat. Soc. Series B Stat. Methodol. 64, 479–498 (2002). -#' +#' @references #' 1. Shrout, P. E. & Fleiss, J. L. Intraclass correlations: uses in assessing #' rater reliability. Psychol. Bull. 86, 420–428 (1979). #' @@ -1605,6 +1714,10 @@ #' 1. Raymaekers, J., Rousseeuw, P. J. Transforming variables to central #' normality. Mach Learn. (2021). #' +#' 1. Zwanenburg, A., & Löck, S. (2026). Location and scale-invariant power +#' transformations for transforming data to normality. Machine Learning, +#' 115(3), 34. +#' #' 1. Park, M. Y., Hastie, T. & Tibshirani, R. Averaged gene expressions for #' regression. Biostatistics 8, 212–227 (2007). #' @@ -1670,7 +1783,8 @@ cluster_similarity_threshold = waiver(), cluster_representation_method = waiver(), parallel_preprocessing = waiver(), - ...) { + ... +) { settings <- list() # feature_max_fraction_missing ----------------------------------------------- @@ -1681,12 +1795,14 @@ var_name = "feature_max_fraction_missing", type = "numeric", optional = TRUE, - default = 0.30) + default = 0.30 + ) .check_number_in_valid_range( x = settings$feature_max_fraction_missing, var_name = "feature_max_fraction_missing", - range = c(0.0, 0.95)) + range = c(0.0, 0.95) + ) # sample_max_fraction_missing ------------------------------------------------ # Maximum fraction of features missing for inclusion of a subject @@ -1696,12 +1812,14 @@ var_name = "sample_max_fraction_missing", type = "numeric", optional = TRUE, - default = 0.30) + default = 0.30 + ) .check_number_in_valid_range( x = settings$sample_max_fraction_missing, var_name = "sample_max_fraction_missing", - range = c(0.0, 0.95)) + range = c(0.0, 0.95) + ) # filter_method -------------------------------------------------------------- # Univariate filter methods @@ -1711,12 +1829,14 @@ var_name = "filter_method", type = "character_list", optional = TRUE, - default = "none") + default = "none" + ) .check_parameter_value_is_valid( x = settings$filter_method, var_name = "filter_method", - values = c("none", "low_variance", "univariate_test", "robustness")) + values = c("none", "low_variance", "univariate_test", "robustness") + ) if (outcome_type == "multinomial" && "univariate_test" %in% settings$filter_method) { # The nnet package is required for univariate tests with multinomial @@ -1724,10 +1844,11 @@ if (!require_package( x = "nnet", purpose = "to filter features using univariate tests", - message_type = "backend_warning")) { + message_type = "backend_warning" + )) { # If the nnet package is not present, avoid the univariate test. settings$filter_method <- setdiff(settings$filter_method, "univariate_test") - if (length(settings$filter_method) == 0) { + if (length(settings$filter_method) == 0L) { settings$filter_method <- "none" } } @@ -1741,13 +1862,15 @@ var_name = "univariate_test_threshold", type = "numeric", optional = TRUE, - default = 0.20) + default = 0.20 + ) .check_number_in_valid_range( x = settings$univar_threshold, var_name = "univariate_test_threshold", range = c(0.0, 1.0), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) # univariate_test_threshold_metric ------------------------------------------- # Univariate model threshold metric @@ -1757,24 +1880,21 @@ var_name = "univariate_test_threshold_metric", type = "character", optional = TRUE, - default = "p_value") + default = "p_value" + ) .check_parameter_value_is_valid( x = settings$univar_metric, var_name = "univariate_test_threshold_metric", - values = c("p_value", "q_value")) + values = c("p_value", "q_value") + ) - # If the qvalue package is not installed, use p-values instead. + # If q_value is provided, warn for deprecation and use p-values instead. if (settings$univar_metric == "q_value") { ..deprecation_qvalue() - if (!require_package( - x = "qvalue", - purpose = "to use q-values as a metric for univariate feature tests", - message_type = "backend_warning")) { - settings$univar_metric <- "p_value" - } + settings$univar_metric <- "p_value" } - + # univariate_test_max_feature_set_size --------------------------------------- # Maximum feature set size after univariate regression models. settings$univar_feat_set_size <- .parse_arg( @@ -1783,13 +1903,15 @@ var_name = "univariate_test_max_feature_set_size", type = "integer", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$univar_feat_set_size)) { .check_number_in_valid_range( x = settings$univar_feat_set_size, var_name = "univariate_test_max_feature_set_size", - range = c(1, Inf)) + range = c(1L, Inf) + ) } # low_var_minimum_variance_threshold ----------------------------------------- @@ -1800,12 +1922,14 @@ x_var = low_var_minimum_variance_threshold, var_name = "low_var_minimum_variance_threshold", type = "numeric", - optional = FALSE) + optional = FALSE + ) .check_number_in_valid_range( x = settings$low_var_threshold, var_name = "low_var_minimum_variance_threshold", - range = c(0.0, Inf)) + range = c(0.0, Inf) + ) } # low_var_max_feature_set_size ----------------------------------------------- @@ -1816,13 +1940,15 @@ var_name = "low_var_max_feature_set_size", type = "integer", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$low_var_max_feature_set_size)) { .check_number_in_valid_range( x = settings$low_var_max_feature_set_size, var_name = "low_var_max_feature_set_size", - range = c(1, Inf)) + range = c(1L, Inf) + ) } # robustness_icc_type -------------------------------------------------------- @@ -1833,12 +1959,14 @@ var_name = "robustness_icc_type", type = "character", optional = TRUE, - default = "1") + default = "1" + ) .check_parameter_value_is_valid( x = settings$robustness_icc_type, var_name = "robustness_icc_type", - values = .get_available_icc_types()) + values = .get_available_icc_types() + ) # robustness_threshold_metric ------------------------------------------------ # ICC parameter to use for thresholding. Can be icc (estimated icc), icc_low @@ -1850,12 +1978,14 @@ var_name = "robustness_threshold_metric", type = "character", optional = TRUE, - default = "icc_low") + default = "icc_low" + ) .check_parameter_value_is_valid( x = settings$robustness_threshold_param, var_name = "robustness_threshold_metric", - values = c("icc", "icc_low", "icc_panel", "icc_panel_low")) + values = c("icc", "icc_low", "icc_panel", "icc_panel_low") + ) # robustness_threshold_value ------------------------------------------------- # ICC value for thresholding. @@ -1865,19 +1995,22 @@ var_name = "robustness_threshold_value", type = "numeric", optional = TRUE, - default = 0.70) + default = 0.70 + ) .check_number_in_valid_range( x = settings$robustness_threshold_value, var_name = "robustness_threshold_value", - range = c(-Inf, 1.0)) + range = c(-Inf, 1.0) + ) # imputation_method ---------------------------------------------------------- # Data imputation method. For datasets smaller than 100 features we use lasso, # and simple imputation is used otherwise. default_imputation_method <- ifelse( - get_n_features(data, outcome_type = outcome_type) < 100, - "lasso", "simple") + get_n_features(data, outcome_type = outcome_type) < 100L, + "lasso", "simple" + ) settings$imputation_method <- .parse_arg( x_config = config$imputation_method, @@ -1885,19 +2018,22 @@ var_name = "imputation_method", type = "character", optional = TRUE, - default = default_imputation_method) + default = default_imputation_method + ) .check_parameter_value_is_valid( x = settings$imputation_method, var_name = "imputation_method", - values = .get_available_imputation_methods()) + values = .get_available_imputation_methods() + ) if (settings$imputation_method == "lasso") { # If glmnet is not installed, use simple imputation. if (!require_package( x = "glmnet", purpose = "to impute data using lasso regression", - message_type = "backend_warning")) { + message_type = "backend_warning" + )) { settings$imputation_method <- "simple" } } @@ -1910,18 +2046,21 @@ var_name = "transformation_method", type = "character", optional = TRUE, - default = "yeo_johnson_robust") + default = "yeo_johnson_robust" + ) .check_parameter_value_is_valid( x = settings$transform_method, var_name = "transformation_method", - values = .get_available_transformation_methods()) + values = .get_available_transformation_methods() + ) # If power.transform is not installed, no transformation can be performed. if (!require_package( x = "power.transform", purpose = "to transform data", - message_type = "backend_warning")) { + message_type = "backend_warning" + )) { settings$transform_method <- "none" } @@ -1971,12 +2110,14 @@ var_name = "normalisation_method", type = "character", optional = TRUE, - default = "standardisation_robust") + default = "standardisation_robust" + ) .check_parameter_value_is_valid( x = settings$normalisation_method, var_name = "normalisation_method", - values = .get_available_normalisation_methods()) + values = .get_available_normalisation_methods() + ) # batch_normalisation_method ------------------------------------------------- # Batch normalisation method @@ -1986,18 +2127,22 @@ var_name = "batch_normalisation_method", type = "character", optional = TRUE, - default = "none") + default = "none" + ) .check_parameter_value_is_valid( x = settings$batch_normalisation_method, var_name = "batch_normalisation_method", - values = .get_available_batch_normalisation_methods()) + values = .get_available_batch_normalisation_methods() + ) # If the batch normalisation method is combat, pre-normalisation of the # entire data is required. - if (settings$batch_normalisation_method %in% - .get_available_batch_normalisation_methods(type = "combat") && - settings$normalisation_method %in% c("none", "mean_centering")) { + if ( + settings$batch_normalisation_method %in% + .get_available_batch_normalisation_methods(type = "combat") && + settings$normalisation_method %in% c("none", "mean_centering") + ) { settings$normalisation_method <- "standardisation" } @@ -2009,14 +2154,16 @@ var_name = "cluster_method", type = "character", optional = TRUE, - default = "hclust") + default = "hclust" + ) # Check that the cluster package is installed, and revert to if none. if (!settings$cluster_method %in% c("none", "hclust")) { if (!require_package( x = "cluster", purpose = "to cluster similar features together", - message_type = "backend_warning")) { + message_type = "backend_warning" + )) { settings$cluster_method <- "hclust" } } @@ -2026,7 +2173,8 @@ require_package( x = "fastcluster", purpose = "to create clusters faster", - message_type = "backend_warning") + message_type = "backend_warning" + ) } # cluster_linkage ------------------------------------------------------------ @@ -2037,13 +2185,15 @@ var_name = "cluster_linkage_method", type = "character", optional = TRUE, - default = "average") + default = "average" + ) # cluster_cut_method --------------------------------------------------------- # Feature cluster cut method default_cluster_cut_method <- ifelse( settings$cluster_method == "pam", - "silhouette", "fixed_cut") + "silhouette", "fixed_cut" + ) settings$cluster_cut_method <- .parse_arg( x_config = config$cluster_cut_method, @@ -2051,13 +2201,15 @@ var_name = "cluster_cut_method", type = "character", optional = TRUE, - default = default_cluster_cut_method) + default = default_cluster_cut_method + ) if (settings$cluster_cut_method == "dynamic_cut") { if (!require_package( x = "dynamicTreeCut", purpose = "to cut dendrograms dynamically", - message_type = "backend_warning")) { + message_type = "backend_warning" + )) { settings$cluster_cut_method <- "fixed_cut" } } @@ -2071,7 +2223,8 @@ var_name = "cluster_similarity_metric", type = "character", optional = TRUE, - default = "mutual_information") + default = "mutual_information" + ) if (settings$cluster_similarity_metric %in% c("mcfadden_r2", "cox_snell_r2", "nagelkerke_r2")) { @@ -2079,8 +2232,10 @@ x = "nnet", purpose = paste0( "to compute log-likelihood pseudo R2 similarity using the ", - settings$cluster_similarity_metric, " metric"), - message_type = "backend_warning")) { + settings$cluster_similarity_metric, " metric" + ), + message_type = "backend_warning" + )) { settings$cluster_similarity_metric <- "spearman" } @@ -2089,8 +2244,10 @@ x = "praznik", purpose = paste0( "to compute similarity using the ", - settings$cluster_similarity_metric, " metric"), - message_type = "backend_warning")) { + settings$cluster_similarity_metric, " metric" + ), + message_type = "backend_warning" + )) { settings$cluster_similarity_metric <- "spearman" } } @@ -2106,7 +2263,8 @@ var_name = "cluster_similarity_threshold", type = "numeric", optional = TRUE, - default = NULL) + default = NULL + ) if (is.null(settings$cluster_similarity_threshold)) { if (settings$cluster_cut_method %in% c("fixed_cut")) { @@ -2115,7 +2273,7 @@ if (settings$cluster_similarity_metric %in% c("mcfadden_r2")) { settings$cluster_similarity_threshold <- 0.30 } else if (settings$cluster_similarity_metric %in% c("mutual_information")) { - settings$cluster_similarity_threshold <- 0.30 + settings$cluster_similarity_threshold <- 0.23 } else if (settings$cluster_similarity_metric %in% c("cox_snell_r2", "nagelkerke_r2")) { settings$cluster_similarity_threshold <- 0.75 } else { @@ -2129,7 +2287,7 @@ if (settings$cluster_similarity_metric %in% c("mcfadden_r2")) { settings$cluster_similarity_threshold <- 0.25 } else if (settings$cluster_similarity_metric %in% c("mutual_information")) { - settings$cluster_similarity_threshold <- 0.25 + settings$cluster_similarity_threshold <- 0.10 } else if (settings$cluster_similarity_metric %in% c("cox_snell_r2", "nagelkerke_r2")) { settings$cluster_similarity_threshold <- 0.40 } else { @@ -2146,7 +2304,8 @@ var_name = "cluster_representation_method", type = "character", optional = TRUE, - default = "best_predictor") + default = "best_predictor" + ) # Partioning around medioids only allows the use of medioids for # representation. @@ -2159,8 +2318,9 @@ if (settings$cluster_representation_method %in% c("mean")) { if (!settings$normalisation_method %in% c( "standardisation", "standardisation_trim", "standardisation_winsor", - "standardisation_robust", "quantile")) { - warning( + "standardisation_robust", "quantile" + )) { + ..warning( paste0( "When computing the meta-feature for a cluster using the mean value ", "of co-clustered features, each feature is expected to be centered ", @@ -2184,7 +2344,8 @@ cluster_similarity_metric = settings$cluster_similarity_metric, cluster_representation_method = settings$cluster_representation_method, data_type = "cluster", - message_type = "backend_error") + message_type = "backend_error" + ) # parallel_preprocessing ----------------------------------------------------- # Parallel processing @@ -2194,7 +2355,8 @@ var_name = "parallel_preprocessing", type = "logical", optional = TRUE, - default = TRUE) + default = TRUE + ) # Disable if parallel is FALSE. if (!parallel) settings$do_parallel <- FALSE @@ -2204,25 +2366,25 @@ -#' Internal function for parsing settings related to feature selection +#' Internal function for parsing settings related to variable importance +#' computation. #' #' @param config A list of settings, e.g. from an xml file. #' @param data Data set as loaded using the `.load_data` function. #' @param parallel Logical value that whether familiar uses parallelisation. If -#' `FALSE` it will override `parallel_feature_selection`. +#' `FALSE` it will override `parallel_vimp`. #' @param outcome_type Type of outcome found in the data set. -#' @param fs_method (**required**) Feature selection method to be used for -#' determining variable importance. `familiar` implements various feature -#' selection methods. Please refer to the vignette on feature selection -#' methods for more details. +#' @param vimp_method (**required**) Variable importance method. `familiar` +#' implements various variable importance methods. Please refer to the +#' vignette on variable importance methods for more details. #' -#' More than one feature selection method can be chosen. The experiment will +#' More than one variable importance method can be chosen. The experiment will #' then repeated for each feature selection method. #' -#' Feature selection methods determines the ranking of features. Actual +#' Variable importance methods determine the ranking of features. Actual #' selection of features is done by optimising the signature size model #' hyperparameter during the hyperparameter optimisation step. -#' @param fs_method_parameter (*optional*) List of lists containing parameters +#' @param vimp_method_parameter (*optional*) List of lists containing parameters #' for feature selection methods. Each sublist should have the name of the #' feature selection method it corresponds to. #' @@ -2274,20 +2436,20 @@ #' The *feature selection methods* vignette provides additional information. #' #' @param vimp_aggregation_rank_threshold (*optional*) The threshold used to -#' define the subset of highly important features. If not set, this threshold -#' is determined by maximising the variance in the occurrence value over all -#' features over the subset size. +#' define the subset of highly important features. If set to `NULL`, this +#' threshold is determined by maximising the variance in the occurrence value +#' over all features over the subset size. The default value is `5`. #' #' This parameter is only relevant for `stability`, `exponential`, #' `enhanced_borda`, `truncated_borda` and `enhanced_truncated_borda` methods. -#' @param parallel_feature_selection (*optional*) Enable parallel processing for -#' the feature selection workflow. Defaults to `TRUE`. When set to `FALSE`, +#' @param parallel_vimp (*optional*) Enable parallel processing for +#' variable importance tasks. Defaults to `TRUE`. When set to `FALSE`, #' this will disable the use of parallel processing while performing feature #' selection, regardless of the settings of the `parallel` parameter. -#' `parallel_feature_selection` is ignored if `parallel=FALSE`. +#' `parallel_vimp` is ignored if `parallel = FALSE`. #' @param ... Unused arguments. #' -#' @return List of parameters related to feature selection. +#' @return List of parameters related to variable importance computation. #' #' @references 1. Wald, R., Khoshgoftaar, T. M., Dittman, D., Awada, W. & #' Napolitano, A. An extensive comparison of feature ranking aggregation @@ -2302,48 +2464,53 @@ #' signatures. PLoS One 6, e28210 (2011). #' @md #' @keywords internal -.parse_feature_selection_settings <- function( +.parse_variable_importance_settings <- function( config = NULL, data, parallel, outcome_type, - fs_method = waiver(), - fs_method_parameter = waiver(), + vimp_method = waiver(), + vimp_method_parameter = waiver(), vimp_aggregation_method = waiver(), vimp_aggregation_rank_threshold = waiver(), - parallel_feature_selection = waiver(), - ...) { + parallel_vimp = waiver(), + ... +) { settings <- list() - # fs_method ------------------------------------------------------------------ - # Feature selection methods - settings$fs_methods <- .parse_arg( - x_config = config$fs_method, - x_var = fs_method, - var_name = "fs_method", + # vimp_method ---------------------------------------------------------------- + # Variable importance methods + settings$vimp_methods <- .parse_arg( + x_config = config$vimp_method, + x_var = vimp_method, + var_name = "vimp_method", type = "character_list", - optional = FALSE) + optional = FALSE + ) sapply( - settings$fs_methods, + settings$vimp_methods, .check_vimp_outcome_type, - outcome_type = outcome_type) + outcome_type = outcome_type + ) - # fs_method_parameter -------------------------------------------------------- - # Feature selection parameters + # vimp_method_parameter ------------------------------------------------------ + # Variable importance parameters settings$param <- .parse_arg( - x_config = config$fs_method_parameter, - x_var = fs_method_parameter, - var_name = "fs_method_parameter", + x_config = config$vimp_method_parameter, + x_var = vimp_method_parameter, + var_name = "vimp_method_parameter", type = "list", optional = TRUE, - default = list()) + default = list() + ) settings$param <- .parse_hyperparameters( data = data, parameter_list = settings$param, outcome_type = outcome_type, - fs_method = settings$fs_methods) + vimp_method = settings$vimp_methods + ) # vimp_aggregation_method ---------------------------------------------------- # Variable importance aggregation methods @@ -2353,12 +2520,14 @@ var_name = "vimp_aggregation_method", type = "character", optional = TRUE, - default = "borda") + default = "borda" + ) .check_parameter_value_is_valid( x = settings$aggregation, var_name = "vimp_aggregation_method", - values = .get_available_rank_aggregation_methods()) + values = .get_available_rank_aggregation_methods() + ) # vimp_aggregation_rank_threshold -------------------------------------------- # Variable importance rank threshold (used by some aggregation methods) @@ -2368,24 +2537,27 @@ var_name = "vimp_aggregation_rank_threshold", type = "integer", optional = TRUE, - default = 5L) + default = 5L + ) if (!is.null(settings$aggr_rank_threshold)) { .check_number_in_valid_range( x = settings$aggr_rank_threshold, var_name = "vimp_aggregation_rank_threshold", - range = c(1, Inf)) + range = c(1L, Inf) + ) } - # parallel_feature_selection ------------------------------------------------- - # Parallelisation switch for feature selection + # parallel_vimp -------------------------------------------------------------- + # Parallelisation switch for variable importance computation settings$do_parallel <- .parse_arg( - x_config = config$parallel_feature_selection, - x_var = parallel_feature_selection, - var_name = "parallel_feature_selection", + x_config = config$parallel_vimp, + x_var = parallel_vimp, + var_name = "parallel_vimp", type = "logical", optional = TRUE, - default = TRUE) + default = TRUE + ) # Disable if parallel is FALSE. if (!parallel) settings$do_parallel <- FALSE @@ -2443,7 +2615,8 @@ novelty_detector = waiver(), detector_parameters = waiver(), parallel_model_development = waiver(), - ...) { + ... +) { settings <- list() # learner -------------------------------------------------------------------- @@ -2452,12 +2625,14 @@ x_config = config$learner, x_var = learner, var_name = "learner", type = "character_list", - optional = FALSE) + optional = FALSE + ) sapply( settings$learners, .check_learner_outcome_type, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # hyperparameters ------------------------------------------------------------ # Model hyperparameters @@ -2467,13 +2642,15 @@ var_name = "hyperparameter", type = "list", optional = TRUE, - default = list()) + default = list() + ) settings$hyper_param <- .parse_hyperparameters( data = data, parameter_list = settings$hyper_param, outcome_type = outcome_type, - learner = settings$learners) + learner = settings$learners + ) # novelty_detector ----------------------------------------------------------- settings$novelty_detector <- .parse_arg( @@ -2482,7 +2659,8 @@ var_name = "novelty_detector", type = "character", optional = TRUE, - default = "isolation_forest") + default = "isolation_forest" + ) .check_novelty_detector_available(detector = settings$novelty_detector) @@ -2493,13 +2671,15 @@ var_name = "detector_parameters", type = "list", optional = TRUE, - default = list()) + default = list() + ) settings$detector_parameters <- .parse_hyperparameters( data = data, parameter_list = settings$detector_parameters, detector = settings$novelty_detector, - outcome_type = "unsupervised") + outcome_type = "unsupervised" + ) # parallel_model_development ------------------------------------------------- # Parallelisation switch for model building @@ -2509,7 +2689,8 @@ var_name = "parallel_model_development", type = "logical", optional = TRUE, - default = TRUE) + default = TRUE + ) # Disable if parallel is FALSE if (!parallel) settings$do_parallel <- FALSE @@ -2537,16 +2718,17 @@ #' @param optimisation_determine_vimp (*optional*) Logical value that indicates #' whether variable importance is determined separately for each of the #' bootstraps created during the optimisation process (`TRUE`) or the -#' applicable results from the feature selection step are used (`FALSE`). +#' applicable results from the variable importance computation step are used +#' (`FALSE`). #' #' Determining variable importance increases the initial computational #' overhead. However, it prevents positive biases for the out-of-bag data due #' to overlap of these data with the development data set used for the feature #' selection step. In this case, any hyperparameters of the variable #' importance method are not determined separately for each bootstrap, but -#' those obtained during the feature selection step are used instead. In case -#' multiple of such hyperparameter sets could be applicable, the set that will -#' be used is randomly selected for each bootstrap. +#' those obtained during the variable importance computation step are used +#' instead. In case multiple of such hyperparameter sets could be applicable, +#' the set that will be used is randomly selected for each bootstrap. #' #' This parameter only affects hyperparameter optimisation of learners. The #' default is `TRUE`. @@ -2636,8 +2818,6 @@ #' #' * `mse`: Mean squared error for `continuous` models. #' -#' * `msle`: Mean squared logarithmic error for `count` models. -#' #' * `concordance_index`: For `survival` models. #' #' Multiple optimisation metrics can be specified. Actual metric values are @@ -2840,7 +3020,8 @@ exploration_method = waiver(), hyperparameter_learner = waiver(), parallel_hyperparameter_optimisation = waiver(), - ...) { + ... +) { settings <- list() # smbo_random_initialisation ------------------------------------------------- @@ -2851,12 +3032,14 @@ var_name = "smbo_random_initialisation", type = "character", optional = TRUE, - default = "fixed_subsample") + default = "fixed_subsample" + ) .check_parameter_value_is_valid( x = settings$hpo_grid_initialisation_method, var_name = "smbo_random_initialisation", - values = c("fixed_subsample", "fixed", "random")) + values = c("fixed_subsample", "fixed", "random") + ) # smbo_n_random_sets --------------------------------------------------------- # Number of samples in the initial parameter grid. @@ -2866,12 +3049,14 @@ var_name = "smbo_n_random_sets", type = "integer", optional = TRUE, - default = 100) + default = 100L + ) .check_number_in_valid_range( x = settings$hpo_n_grid_initialisation_samples, var_name = "smbo_n_random_sets", - range = c(10, Inf)) + range = c(10L, Inf) + ) # optimisation_determine_vimp ------------------------------------------------ # Variable importance for the bootstraps @@ -2881,7 +3066,8 @@ var_name = "optimisation_determine_vimp", type = "logical", optional = TRUE, - default = TRUE) + default = TRUE + ) # max_smbo_iterations -------------------------------------------------------- # Maximum number of SMBO iterations before stopping @@ -2891,12 +3077,14 @@ var_name = "max_smbo_iterations", type = "integer", optional = TRUE, - default = 20) + default = 20L + ) .check_number_in_valid_range( x = settings$hpo_smbo_iter_max, var_name = "max_smbo_iterations", - range = c(1, Inf)) + range = c(1L, Inf) + ) # optimisation_bootstraps ---------------------------------------------------- # Maximum number of bootstraps for hyperparameter evaluation @@ -2906,12 +3094,14 @@ var_name = "optimisation_bootstraps", type = "integer", optional = TRUE, - default = 20) + default = 20L + ) .check_number_in_valid_range( x = settings$hpo_max_bootstraps, var_name = "optimisation_bootstraps", - range = c(10, Inf)) + range = c(10L, Inf) + ) # smbo_initial_bootstraps ---------------------------------------------------- # Number of bootstraps evaluated initially @@ -2921,12 +3111,14 @@ var_name = "smbo_initial_bootstraps", type = "integer", optional = TRUE, - default = 1L) + default = 1L + ) .check_number_in_valid_range( x = settings$hpo_initial_bootstraps, var_name = "smbo_initial_bootstraps", - range = c(1, settings$hpo_max_bootstraps)) + range = c(1L, settings$hpo_max_bootstraps) + ) # smbo_step_bootstraps ------------------------------------------------------- # Maximum number of bootstrap evaluated each intensify step of each SMBO @@ -2937,12 +3129,14 @@ var_name = "smbo_step_bootstraps", type = "integer", optional = TRUE, - default = 3L) + default = 3L + ) .check_number_in_valid_range( x = settings$hpo_bootstraps, var_name = "smbo_step_bootstraps", - range = c(1, settings$hpo_max_bootstraps)) + range = c(1L, settings$hpo_max_bootstraps) + ) # smbo_intensify_steps ------------------------------------------------------- # Maximum number of intensify iterations during each SMBO iteration. @@ -2952,12 +3146,14 @@ var_name = "smbo_intensify_steps", type = "integer", optional = TRUE, - default = 5) + default = 5L + ) .check_number_in_valid_range( x = settings$hpo_intensify_max_iter, var_name = "smbo_intensify_steps", - range = c(1, Inf)) + range = c(1L, Inf) + ) # smbo_stochastic_reject_p_value --------------------------------------------- # Significance level for early stopping of intensity iterations. Only used for @@ -2968,13 +3164,15 @@ var_name = "smbo_stochastic_reject_p_value", type = "numeric", optional = TRUE, - default = 0.05) + default = 0.05 + ) .check_number_in_valid_range( x = settings$hpo_alpha, var_name = "smbo_stochastic_reject_p_value", range = c(0.0, 1.0), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) # smbo_stop_convergent_iterations -------------------------------------------- # Number of converging iterations before stopping SMBO. @@ -2984,12 +3182,14 @@ var_name = "smbo_stop_convergent_iterations", type = "integer", optional = TRUE, - default = 3) + default = 3L + ) .check_number_in_valid_range( x = settings$hpo_conv_stop, var_name = "smbo_stop_convergent_iterations", - range = c(1, Inf)) + range = c(1L, Inf) + ) # smbo_stop_tolerance -------------------------------------------------------- # Convergence tolerance @@ -2999,7 +3199,8 @@ var_name = "smbo_stop_tolerance", type = "numeric", optional = TRUE, - default = NULL) + default = NULL + ) # Check provided settings. If NULL, convergence will be set by the algorithm. if (!is.null(settings$hpo_convergence_tolerance)) { @@ -3007,7 +3208,8 @@ x = settings$hpo_convergence_tolerance, var_name = "smbo_stop_tolerance", range = c(0.0, 1.0), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) } # smbo_time_limit ------------------------------------------------------------ @@ -3018,18 +3220,22 @@ var_name = "smbo_time_limit", type = "numeric", optional = TRUE, - default = NULL) + default = NULL + ) if (!is.null(settings$hpo_time_limit)) { .check_number_in_valid_range( x = settings$hpo_time_limit, var_name = "smbo_time_limit", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) - require_package(c("callr", "microbenchmark"), + require_package( + c("callr", "microbenchmark"), purpose = "to measure hyperparameter optimisation time", - message_type = "backend_warning") + message_type = "backend_warning" + ) } # hyperparameter_learner ----------------------------------------------------- @@ -3040,15 +3246,18 @@ var_name = "hyperparameter_learner", type = "character", optional = TRUE, - default = "gaussian_process") + default = "gaussian_process" + ) .check_parameter_value_is_valid( x = settings$hpo_hyperparameter_learner, var_name = "hyperparameter_learner", - values = .get_available_hyperparameter_learners()) + values = .get_available_hyperparameter_learners() + ) .check_hyperparameter_learner_available( - hyperparameter_learner = settings$hpo_hyperparameter_learner) + hyperparameter_learner = settings$hpo_hyperparameter_learner + ) # optimisation_function ------------------------------------------------------ @@ -3059,13 +3268,16 @@ var_name = "optimisation_function", type = "character", optional = TRUE, - default = "validation") + default = "validation" + ) .check_parameter_value_is_valid( x = settings$hpo_optimisation_function, var_name = "optimisation_function", values = .get_available_optimisation_functions( - hyperparameter_learner = settings$hpo_hyperparameter_learner)) + hyperparameter_learner = settings$hpo_hyperparameter_learner + ) + ) # acquisition_function ------------------------------------------------------- @@ -3076,12 +3288,14 @@ var_name = "acquisition_function", type = "character", optional = TRUE, - default = "expected_improvement") + default = "expected_improvement" + ) .check_parameter_value_is_valid( x = settings$hpo_acquisition_function, var_name = "acquisition_function", - values = .get_available_acquisition_functions()) + values = .get_available_acquisition_functions() + ) # exploration_method --------------------------------------------------------- @@ -3092,12 +3306,14 @@ var_name = "exploration_method", type = "character", optional = TRUE, - default = "single_shot") + default = "single_shot" + ) .check_parameter_value_is_valid( x = settings$hpo_exploration_method, var_name = "exploration_method", - values = .get_available_hyperparameter_exploration_methods()) + values = .get_available_hyperparameter_exploration_methods() + ) # optimisation_metric -------------------------------------------------------- # Performance metric for hyperparameter optimisation @@ -3107,7 +3323,8 @@ var_name = "optimisation_metric", type = "character_list", optional = TRUE, - default = NULL) + default = NULL + ) # Set default metric if (is.null(settings$hpo_metric)) { @@ -3119,7 +3336,8 @@ sapply( settings$hpo_metric, .check_metric_outcome_type, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # parallel_hyperparameter_optimisation --------------------------------------- # Parallelisation switch for parallel processing @@ -3129,12 +3347,14 @@ var_name = "parallel_hyperparameter_optimisation", type = "character", optional = TRUE, - default = "TRUE") + default = "TRUE" + ) .check_parameter_value_is_valid( x = settings$do_parallel, var_name = "parallel_hyperparameter_optimisation", - values = c("TRUE", "FALSE", "inner", "outer")) + values = c("TRUE", "FALSE", "inner", "outer") + ) # Disable if parallel is FALSE if (!parallel) settings$do_parallel <- "FALSE" @@ -3158,10 +3378,9 @@ #' These identifiers are used to determine the cohorts used to determine a #' setting for `time_max`, if the `outcome_type` is `survival`, and both #' `time_max` and `evaluation_times` are not provided. -#' @param vimp_aggregation_method Method for variable importance aggregation that -#' was used for feature selection. -#' @param vimp_aggregation_rank_threshold Rank threshold for variable importance -#' aggregation used during feature selection. +#' @param vimp_aggregation_method Variable importance aggregation method. +#' @param vimp_aggregation_rank_threshold Rank threshold used for variable +#' importance aggregation. #' @param prep_cluster_method Cluster method used during pre-processing. #' @param prep_cluster_linkage_method Cluster linkage method used during #' pre-processing. @@ -3184,65 +3403,83 @@ #' from both the global layer and the next lower level. #' #' Setting the flag to `true` saves computation time. -#' @param skip_evaluation_elements (*optional*) Specifies which evaluation steps, -#' if any, should be skipped as part of the evaluation process. Defaults to -#' `none`, which means that all relevant evaluation steps are performed. It can -#' have one or more of the following values: -#' -#' * `none`, `false`: no steps are skipped. +#' @param evaluation_elements (*optional*) Specifies which evaluation steps +#' should be performed during the evaluation process. Defaults to `all`, +#' indicating that all evaluation steps should be performed. It can have one or +#' more of the following values: #' -#' * `all`, `true`: all steps are skipped. +#' * `all`, `true`: all evaluation steps are performed. +#' +#' * `none`, `false`: no evaluation is performed. #' #' * `auc_data`: data for assessing and plotting the area under the receiver -#' operating characteristic curve are not computed. +#' operating characteristic curve are computed. #' #' * `calibration_data`: data for assessing and plotting model calibration are -#' not computed. +#' computed. #' #' * `calibration_info`: data required to assess calibration, such as baseline -#' survival curves, are not collected. These data will still be present in the +#' survival curves, are collected. These data will still be present in the #' models. #' #' * `confusion_matrix`: data for assessing and plotting a confusion matrix are -#' not collected. +#' collected. #' #' * `decision_curve_analyis`: data for performing a decision curve analysis -#' are not computed. +#' are computed. #' #' * `feature_expressions`: data for assessing and plotting sample clustering -#' are not computed. +#' are computed. #' -#' * `feature_similarity`: data for assessing and plotting feature clusters are +#' * `feature_similarity`: data for assessing and plotting feature clusters #' not computed. #' #' * `fs_vimp`: data for assessing and plotting feature selection-based -#' variable importance are not collected. +#' variable importance are collected. #' -#' * `hyperparameters`: data for assessing model hyperparameters are not +#' * `hyperparameters`: data for assessing model hyperparameters are #' collected. These data will still be present in the models. #' #' * `ice_data`: data for individual conditional expectation and partial -#' dependence plots are not created. +#' dependence plots are created. #' #' * `model_performance`: data for assessing and visualising model performance -#' are not created. +#' are created. #' #' * `model_vimp`: data for assessing and plotting model-based variable -#' importance are not collected. +#' importance are collected. #' #' * `permutation_vimp`: data for assessing and plotting model-agnostic -#' permutation variable importance are not computed. +#' permutation variable importance are computed. #' -#' * `prediction_data`: predictions for each sample are not made and exported. +#' * `prediction_data`: predictions for each sample are made and exported. #' #' * `risk_stratification_data`: data for assessing and plotting Kaplan-Meier -#' survival curves are not collected. +#' survival curves are collected. #' #' * `risk_stratification_info`: data for assessing stratification into risk -#' groups are not computed. -#' +#' groups are computed. +#' +#' * `sample_similarity`: data for assessing sample similarity are computed. +#' +#' * `shap`: data for assessing marginal contributions of feature values in +#' a SHAP analysis. +#' #' * `univariate_analysis`: data for assessing and plotting univariate feature -#' importance are not computed. +#' importance are computed. +#' +#' The logical intersect of the evaluation elements specified by +#' `evaluation_elements` and `skip_evaluation_elements` is used to define which +#' evaluation steps are performed. +#' @param skip_evaluation_elements (*optional*) Specifies which evaluation steps, +#' if any, should be skipped as part of the evaluation process. Defaults to +#' `none`, which means that all relevant evaluation steps are performed. It can +#' have one or more of the same values as `evaluation_elements`. +#' +#' The logical intersect of the evaluation elements specified by +#' `evaluation_elements` and `skip_evaluation_elements` is used to define which +#' evaluation steps are performed. +#' #' @param ensemble_method (*optional*) Method for ensembling predictions from #' models for the same sample. Available methods are: #' @@ -3265,15 +3502,25 @@ #' If unset, the metric in the `optimisation_metric` variable is used. #' #' @param sample_limit (*optional*) Set the upper limit of the number of samples -#' that are used during evaluation steps. Cannot be less than 20. +#' that are used during evaluation steps. Cannot be fewer than 20. #' #' This setting can be specified per data element by providing a parameter #' value in a named list with data elements, e.g. #' `list("sample_similarity"=100, "permutation_vimp"=1000)`. #' #' This parameter can be set for the following data elements: -#' `sample_similarity` and `ice_data`. +#' `sample_similarity`, `shap`, `permutation_vimp`, and `ice_data`. +#' +#' @param n_important_features (*optional*) Set the number of features that are +#' evaluated in evaluation steps. Cannot be 0 or fewer. +#' +#' This setting can be specified per data element by providing a parameter +#' value in a named list with data elements, e.g. +#' `list("ice_data"=10, "permutation_vimp"=5)`. #' +#' This parameter can be set for the following data elements: +#' `ice_data`, `permutation_vimp`, and `shap`. +#' #' @param detail_level (*optional*) Sets the level at which results are computed #' and aggregated. #' @@ -3319,6 +3566,10 @@ #' This parameter can be set for the following data elements: `auc_data`, #' `decision_curve_analyis`, `model_performance`, `permutation_vimp`, #' `ice_data`, `prediction_data` and `confusion_matrix`. +#' +#' If results are computed from 10 samples or fewer, `ensemble` is +#' automatically used. This prevents issues where evaluation steps do not have +#' a required minimum number of samples for `hybrid` or `model`. #' #' @param estimation_type (*optional*) Sets the type of estimation that should be #' possible. This has the following options: @@ -3379,6 +3630,22 @@ #' often not suitable due to non-normal distributions. The bias-corrected and #' accelerated (BCa) method is not implemented yet. #' +#' @param shap_tolerance (*optional*) Relative tolerance for convergence of SHAP +#' values. The tolerance is scaled with the range in SHAP values. +#' +#' The default value is `0.05`. +#' +#' @param shap_max_iterations (*optional*) Maximum iterations for convergence of +#' SHAP values. +#' +#' The default value is `1000` iterations. +#' +#' @param shap_phi_0 (*optional*) Value(s) to use for computing marginal +#' contributions. By default, the average predicted value in the population is +#' used. For `multinomial` and `survival` outcomes, this parameter requires a +#' value for each class and evaluation time (`evaluation_times`), +#' respectively. +#' #' @param feature_cluster_method (*optional*) Method used to perform clustering #' of features. The same methods as for the `cluster_method` configuration #' parameter are available: `none`, `hclust`, `agnes`, `diana` and `pam`. @@ -3472,9 +3739,9 @@ #' #' @param eval_aggregation_method (*optional*) Method for aggregating variable #' importances for the purpose of evaluation. Variable importances are -#' determined during feature selection steps and after training the model. Both -#' types are evaluated, but feature selection variable importance is only -#' evaluated at run-time. +#' determined both during initial variable importance computation steps and +#' after training the model. Both types are evaluated after training the +#' model, but only the initial variable importances are evaluated at run-time. #' #' See the documentation for the `vimp_aggregation_method` argument for #' information concerning the different methods available. @@ -3597,15 +3864,20 @@ prep_cluster_similarity_threshold, prep_cluster_similarity_metric, evaluate_top_level_only = waiver(), + evaluation_elements = waiver(), skip_evaluation_elements = waiver(), ensemble_method = waiver(), evaluation_metric = waiver(), sample_limit = waiver(), + n_important_features = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), confidence_level = waiver(), bootstrap_ci_method = waiver(), + shap_tolerance = waiver(), + shap_max_iterations = waiver(), + shap_phi_0 = waiver(), feature_cluster_method = waiver(), feature_cluster_cut_method = waiver(), feature_linkage_method = waiver(), @@ -3623,10 +3895,8 @@ evaluation_times = waiver(), dynamic_model_loading = waiver(), parallel_evaluation = waiver(), - ...) { - # Suppress NOTES due to non-standard evaluation in data.table - outcome_event <- batch_id <- NULL - + ... +) { settings <- list() # pool_only ------------------------------------------------------------------ @@ -3637,45 +3907,79 @@ var_name = "evaluate_top_level_only", type = "logical", optional = TRUE, - default = TRUE) + default = TRUE + ) + # evaluation_elements -------------------------------------------------------- + keep_evaluation_elements <- .parse_arg( + x_config = config$evaluation_elements, + x_var = evaluation_elements, + var_name = "evaluation_elements", + type = "character_list", + optional = TRUE, + default = "all" + ) + + keep_evaluation_elements <- tolower(keep_evaluation_elements) + .check_parameter_value_is_valid( + x = keep_evaluation_elements, + var_name = "evaluation_elements", + values = c(.get_available_data_elements(), "none", "false", "all", "true") + ) + + if (any(keep_evaluation_elements %in% c("all", "true"))) { + keep_evaluation_elements <- .get_available_data_elements() + } + + if (any(keep_evaluation_elements %in% c("none", "false"))) { + keep_evaluation_elements <- NULL + } + # skip_evaluation_elements --------------------------------------------------- # Specify any specific elements of the evaluation to skip. - settings$evaluation_data_elements <- .parse_arg( + skipped_evaluation_elements <- .parse_arg( x_config = config$skip_evaluation_elements, x_var = skip_evaluation_elements, var_name = "skip_evaluation_elements", type = "character_list", optional = TRUE, - default = "none") + default = "none" + ) - settings$evaluation_data_elements <- tolower(settings$evaluation_data_elements) + skipped_evaluation_elements <- tolower(skipped_evaluation_elements) .check_parameter_value_is_valid( - x = settings$evaluation_data_elements, + x = skipped_evaluation_elements, var_name = "skip_evaluation_elements", - values = c(.get_available_data_elements(), "none", "false", "all", "true")) + values = c(.get_available_data_elements(), "none", "false", "all", "true") + ) - if (any(settings$evaluation_data_elements %in% c("all", "true"))) { - settings$evaluation_data_elements <- .get_available_data_elements() + if (any(skipped_evaluation_elements %in% c("all", "true"))) { + skipped_evaluation_elements <- .get_available_data_elements() } - if (any(settings$evaluation_data_elements %in% c("none", "false"))) { - settings$evaluation_data_elements <- NULL + if (any(skipped_evaluation_elements %in% c("none", "false"))) { + skipped_evaluation_elements <- NULL } # Instead of specifying the elements to skip, we specify the elements to keep. - settings$evaluation_data_elements <- setdiff( + skipped_evaluation_elements <- setdiff( .get_available_data_elements(), - settings$evaluation_data_elements) - + skipped_evaluation_elements + ) + if ("calibration_data" %in% settings$evaluation_data_elements) { require_package( x = "harmonicmeanp", purpose = "to compute p-values for model calibration tests", - message_type = "backend_warning") + message_type = "backend_warning" + ) } - if (length(settings$evaluation_data_elements) == 0) { + settings$evaluation_data_elements <- intersect( + keep_evaluation_elements, skipped_evaluation_elements + ) + + if (length(settings$evaluation_data_elements) == 0L) { settings$evaluation_data_elements <- NULL } @@ -3685,7 +3989,8 @@ require_package( x = ..required_plotting_packages(extended = TRUE), purpose = "to create plots", - message_type = "backend_warning") + message_type = "backend_warning" + ) } # ensemble_method ------------------------------------------------------------ @@ -3696,12 +4001,14 @@ var_name = "ensemble_method", type = "character", optional = TRUE, - default = "median") + default = "median" + ) .check_parameter_value_is_valid( x = settings$ensemble_method, var_name = "ensemble_method", - values = .get_available_ensemble_prediction_methods()) + values = .get_available_ensemble_prediction_methods() + ) # evaluation_metric ---------------------------------------------------------- # List of performance metrics for evaluation @@ -3711,12 +4018,14 @@ var_name = "evaluation_metric", type = "character_list", optional = TRUE, - default = hpo_metric) + default = hpo_metric + ) sapply( settings$metric, .check_metric_outcome_type, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # sample_limit --------------------------------------------------------------- # Number of samples that should be analysed. @@ -3726,28 +4035,33 @@ var_name = "sample_limit", type = "list", optional = TRUE, - default = list()) + default = list() + ) - if (length(settings$sample_limit) == 0) { + if (length(settings$sample_limit) == 0L) { # Default - use method-specific settings. settings$sample_limit <- NULL - } else if (length(settings$sample_limit) == 1 && is.null(names(settings$sample_limit))) { + } else if (length(settings$sample_limit) == 1L && is.null(names(settings$sample_limit))) { # Check that the contents are a correctly specified. At least 20 samples # should be present. .check_number_in_valid_range( - x = settings$sample_limit[[1]], + x = settings$sample_limit[[1L]], var_name = "sample_limit", - range = c(20L, Inf)) + range = c(20L, Inf) + ) - # Add provided detail level to each possible element. + # Add provided sample limit to each possible element. settings$sample_limit <- lapply( .get_available_data_elements(check_has_sample_limit = TRUE), function(x, sample_limit) (sample_limit), - sample_limit = settings$sample_limit[[1]]) + sample_limit = settings$sample_limit[[1L]] + ) # Add name of respective data elements. - names(settings$sample_limit) <- .get_available_data_elements(check_has_sample_limit = TRUE) + names(settings$sample_limit) <- .get_available_data_elements( + check_has_sample_limit = TRUE + ) } else { # Check that the list elements are correctly specified. @@ -3755,7 +4069,8 @@ names(settings$sample_limit), .check_parameter_value_is_valid, var_name = "sample_limit (data element name)", - values = .get_available_data_elements(check_has_sample_limit = TRUE)) + values = .get_available_data_elements(check_has_sample_limit = TRUE) + ) # Check that the list contents are correctly specified. sapply( @@ -3764,9 +4079,69 @@ .check_number_in_valid_range( x = x[[element_name]], var_name = paste0("sample_limit (", element_name, ")"), - range = c(20L, Inf)) + range = c(20L, Inf) + ) + }, + x = settings$sample_limit + ) + } + + # n_important_features ------------------------------------------------------- + # Number of important features + settings$n_important_features <- .parse_arg( + x_config = config$n_important_features, + x_var = n_important_features, + var_name = "n_important_features", + type = "list", + optional = TRUE, + default = list() + ) + + if (length(settings$n_important_features) == 0L) { + # Default - use method-specific settings. + settings$n_important_features <- NULL + + } else if (length(settings$n_important_features) == 1L && is.null(names(settings$n_important_features))) { + # Check that the parameter has values between 1 and Inf. + .check_number_in_valid_range( + x = settings$n_important_features[[1L]], + var_name = "n_important_features", + range = c(1L, Inf) + ) + + # Add provided sample limit to each possible element. + settings$n_important_features <- lapply( + .get_available_data_elements(check_has_n_important_features = TRUE), + function(x, n_important_features) (n_important_features), + n_important_features = settings$n_important_features[[1L]] + ) + + # Add name of respective data elements. + names(settings$n_important_features) <- .get_available_data_elements( + check_has_n_important_features = TRUE + ) + + } else { + # Check that the list elements are correctly specified. + sapply( + names(settings$n_important_features), + .check_parameter_value_is_valid, + var_name = "n_important_features (data element name)", + values = .get_available_data_elements(check_has_sample_limit = TRUE) + ) + + # Check that the list contents are correctly specified. + sapply( + names(settings$n_important_features), + function(element_name, x) { + .check_number_in_valid_range( + x = x[[element_name]], + var_name = paste0("n_important_features (", element_name, ")"), + range = c(1L, Inf) + ) }, - x = settings$sample_limit) + x = settings$sample_limit + ) } # detail_level --------------------------------------------------------------- @@ -3777,27 +4152,35 @@ var_name = "detail_level", type = "list", optional = TRUE, - default = list()) + default = list() + ) - if (length(settings$detail_level) == 0) { + if (length(settings$detail_level) == 0L) { # Default - use method-specific settings. settings$detail_level <- NULL - } else if (length(settings$detail_level) == 1 && - is.null(names(settings$detail_level))) { + + } else if ( + length(settings$detail_level) == 1L && + is.null(names(settings$detail_level)) + ) { # Check that the contents are a correctly specified, single string. .check_parameter_value_is_valid( - x = settings$detail_level[[1]], + x = settings$detail_level[[1L]], var_name = "detail_level", - values = c("ensemble", "hybrid", "model")) + values = c("ensemble", "hybrid", "model") + ) # Add provided detail level to each possible element. settings$detail_level <- lapply( .get_available_data_elements(check_has_detail_level = TRUE), function(x, detail_level) (detail_level), - detail_level = settings$detail_level[[1]]) + detail_level = settings$detail_level[[1L]] + ) # Add name of respective data elements. - names(settings$detail_level) <- .get_available_data_elements(check_has_detail_level = TRUE) + names(settings$detail_level) <- .get_available_data_elements( + check_has_detail_level = TRUE + ) } else { # Check that the list elements are correctly specified. @@ -3805,7 +4188,8 @@ names(settings$detail_level), .check_parameter_value_is_valid, var_name = "detail_level (data element name)", - values = .get_available_data_elements(check_has_detail_level = TRUE)) + values = .get_available_data_elements(check_has_detail_level = TRUE) + ) # Check that the list contents are correctly specified. sapply( @@ -3814,43 +4198,53 @@ .check_parameter_value_is_valid( x = x[[element_name]], var_name = paste0("detail_level (", element_name, ")"), - values = c("ensemble", "hybrid", "model")) + values = c("ensemble", "hybrid", "model") + ) }, - x = settings$detail_level) + x = settings$detail_level + ) } - + # estimation_type ------------------------------------------------------------ # Type of estimation performed. settings$estimation_type <- .parse_arg( x_config = config$estimation_type, x_var = estimation_type, var_name = "estimation_type", - type = "list", optional = TRUE, - default = list()) + type = "list", + optional = TRUE, + default = list() + ) - if (length(settings$estimation_type) == 0) { + if (length(settings$estimation_type) == 0L) { # Default - use method-specific settings. settings$estimation_type <- NULL - } else if (length(settings$estimation_type) == 1 && - is.null(names(settings$estimation_type))) { + } else if ( + length(settings$estimation_type) == 1L && + is.null(names(settings$estimation_type)) + ) { # Check that the contents are a correctly specified, single string. .check_parameter_value_is_valid( - x = settings$estimation_type[[1]], + x = settings$estimation_type[[1L]], var_name = "estimation_type", values = c( "point", "bias_correction", "bc", - "bootstrap_confidence_interval", "bci")) + "bootstrap_confidence_interval", "bci" + ) + ) # Add provided estimation type to each possible element. settings$estimation_type <- lapply( .get_available_data_elements(check_has_estimation_type = TRUE), function(x, estimation_type) (estimation_type), - estimation_type = settings$estimation_type[[1]]) + estimation_type = settings$estimation_type[[1L]] + ) # Add name of respective data elements. names(settings$estimation_type) <- .get_available_data_elements( - check_has_estimation_type = TRUE) + check_has_estimation_type = TRUE + ) } else { # Check that the list elements are correctly specified. @@ -3858,7 +4252,8 @@ names(settings$estimation_type), .check_parameter_value_is_valid, var_name = "estimation_type (data element name)", - values = .get_available_data_elements(check_has_estimation_type = TRUE)) + values = .get_available_data_elements(check_has_estimation_type = TRUE) + ) # Check that the list contents are correctly specified. sapply( @@ -3869,9 +4264,12 @@ var_name = paste0("estimation_type (", element_name, ")"), values = c( "point", "bias_correction", "bc", - "bootstrap_confidence_interval", "bci")) + "bootstrap_confidence_interval", "bci" + ) + ) }, - x = settings$estimation_type) + x = settings$estimation_type + ) } # aggregate_results ---------------------------------------------------------- @@ -3882,28 +4280,35 @@ var_name = "aggregate_results", type = "list", optional = TRUE, - default = list()) + default = list() + ) - if (length(settings$aggregate_results) == 0) { + if (length(settings$aggregate_results) == 0L) { # Default - use method-specific settings. settings$aggregate_results <- NULL - } else if (length(settings$aggregate_results) == 1 && - is.null(names(settings$aggregate_results))) { + + } else if ( + length(settings$aggregate_results) == 1L && + is.null(names(settings$aggregate_results)) + ) { # Check that the contents are a correctly specified, single string. .check_parameter_value_is_valid( - x = tolower(settings$aggregate_results[[1]]), + x = tolower(settings$aggregate_results[[1L]]), var_name = "aggregate_results", - values = c("true", "false", "none", "all", "default")) + values = c("true", "false", "none", "all", "default") + ) # Add provided aggregate_results value to each possible element. settings$aggregate_results <- lapply( .get_available_data_elements(check_has_estimation_type = TRUE), function(x, aggregate_results) (aggregate_results), - aggregate_results = tolower(settings$aggregate_results[[1]])) + aggregate_results = tolower(settings$aggregate_results[[1L]]) + ) # Add name of respective data elements. names(settings$aggregate_results) <- .get_available_data_elements( - check_has_estimation_type = TRUE) + check_has_estimation_type = TRUE + ) } else { # Check that the list elements are correctly specified. @@ -3911,7 +4316,8 @@ names(settings$aggregate_results), .check_parameter_value_is_valid, var_name = "aggregate_results (data element name)", - values = .get_available_data_elements(check_has_estimation_type = TRUE)) + values = .get_available_data_elements(check_has_estimation_type = TRUE) + ) # Check that the list contents are correctly specified. sapply( @@ -3920,9 +4326,11 @@ .check_parameter_value_is_valid( x = tolower(x[[element_name]]), var_name = paste0("aggregate_results (", element_name, ")"), - values = c("true", "false", "none", "all", "default")) + values = c("true", "false", "none", "all", "default") + ) }, - x = settings$aggregate_results) + x = settings$aggregate_results + ) } # bootstrap_ci_method -------------------------------------------------------- @@ -3933,12 +4341,14 @@ var_name = "bootstrap_ci_method", type = "character", optional = TRUE, - default = "percentile") + default = "percentile" + ) .check_parameter_value_is_valid( x = settings$bootstrap_ci_method, var_name = "bootstrap_ci_method", - values = .get_available_bootstrap_confidence_interval_methods()) + values = .get_available_bootstrap_confidence_interval_methods() + ) # confidence_level ----------------------------------------------------------- # Width of the confidence intervals @@ -3948,14 +4358,271 @@ var_name = "confidence_level", type = "numeric", optional = TRUE, - default = 0.95) + default = 0.95 + ) .check_number_in_valid_range( x = settings$confidence_level, var_name = "confidence_level", range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) + closed = c(FALSE, FALSE) + ) + + # SHAP tolerance ------------------------------------------------------------- + settings$shap_tolerance <- .parse_arg( + x_config = config$shap_tolerance, + x_var = shap_tolerance, + var_name = "shap_tolerance", + type = "numeric", + optional = TRUE, + default = 0.05 + ) + + .check_number_in_valid_range( + x = settings$shap_tolerance, + var_name = "shap_tolerance", + range = c(0.0, Inf), + closed = c(FALSE, FALSE) + ) + + # SHAP maximum iterations ---------------------------------------------------- + settings$shap_max_iterations <- .parse_arg( + x_config = config$shap_max_iterations, + x_var = shap_max_iterations, + var_name = "shap_max_iterations", + type = "integer", + optional = TRUE, + default = 1000L + ) + + .check_number_in_valid_range( + x = settings$shap_max_iterations, + var_name = "shap_max_iterations", + range = c(1L, Inf), + closed = c(TRUE, TRUE) + ) + + # SHAP reference value ------------------------------------------------------- + settings$shap_phi_0 <- .parse_arg( + x_config = config$shap_phi_0, + x_var = shap_phi_0, + var_name = "shap_phi_0", + type = "numeric_list", + optional = TRUE, + default = NULL + ) + + # feature cluster options ---------------------------------------------------- + settings <- c( + settings, + .parse_feature_clustering( + config = config, + default_cluster_method = prep_cluster_method, + default_cluster_linkage_method = prep_cluster_linkage_method, + default_cluster_cut_method = prep_cluster_cut_method, + default_cluster_similarity_metric = prep_cluster_similarity_metric, + default_cluster_similarity_threshold = prep_cluster_similarity_threshold, + feature_cluster_method = feature_cluster_method, + feature_linkage_method = feature_linkage_method, + feature_cluster_cut_method = feature_cluster_cut_method, + feature_similarity_metric = feature_similarity_metric, + feature_similarity_threshold = feature_similarity_threshold, + .check_more = any(c("feature_similarity", "univariate_analysis", "feature_expressions", "permutation_vimp") %in% settings$evaluation_data_elements) + ) + ) + + # sample cluster options ----------------------------------------------------- + settings <- c( + settings, + .parse_sample_clustering( + config = config, + default_cluster_method = prep_cluster_method, + default_cluster_linkage_method = prep_cluster_linkage_method, + sample_cluster_method = sample_cluster_method, + sample_linkage_method = sample_linkage_method, + sample_similarity_metric = sample_similarity_metric, + .check_more = any(c("sample_similarity", "feature_expressions") %in% settings$evaluation_data_elements) + ) + ) + + # eval_aggregation_method ---------------------------------------------------- + # Variable importance aggregation methods + settings$aggregation <- .parse_arg( + x_config = config$eval_aggregation_method, + x_var = eval_aggregation_method, + var_name = "eval_aggregation_method", + type = "character", + optional = TRUE, + default = vimp_aggregation_method + ) + + .check_parameter_value_is_valid( + x = settings$aggregation, + var_name = "eval_aggregation_method", + values = .get_available_rank_aggregation_methods() + ) + + # eval_aggregation_rank_threshold -------------------------------------------- + # Variable importance rank threshold (used by some aggregation methods) + settings$aggr_rank_threshold <- .parse_arg( + x_config = config$eval_aggregation_rank_threshold, + x_var = eval_aggregation_rank_threshold, + var_name = "eval_aggregation_rank_threshold", + type = "integer", + optional = TRUE, + default = vimp_aggregation_rank_threshold + ) + + if (!is.null(settings$aggr_rank_threshold)) { + .check_number_in_valid_range( + x = settings$aggr_rank_threshold, + var_name = "eval_aggregation_rank_threshold", + range = c(1L, Inf) + ) + } + + # eval_icc_type -------------------------------------------------------------- + # Type of ICC computed for univariate analysis. + settings$icc_type <- .parse_arg( + x_config = config$eval_icc_type, + x_var = eval_icc_type, + var_name = "eval_icc_type", + type = "character", + optional = TRUE, + default = "1" + ) + + .check_parameter_value_is_valid( + x = settings$icc_type, + var_name = "eval_icc_type", + values = .get_available_icc_types() + ) + + # stratification_method ------------------------------------------------------ + # Method used to set stratification thresholds for Kaplan-Meier analysis + settings$strat_method <- .parse_arg( + x_config = config$stratification_method, + x_var = stratification_method, + var_name = "stratification_method", + type = "character_list", + optional = TRUE, + default = "median" + ) + + .check_parameter_value_is_valid( + x = settings$strat_method, + var_name = "stratification_method", + values = .get_available_stratification_methods() + ) + + if ("optimised" %in% settings$strat_method) { + if (!require_package( + x = "maxstat", + purpose = "to determine an optimal risk threshold", + message_type = "backend_warning" + )) { + settings$strat_method <- setdiff(settings$strat_method, "optimised") + if (length(settings$strat_method) == 0L) settings$strat_method <- "median" + } + } + + # stratification_threshold --------------------------------------------------- + # Quantile stratification thresholds for the "fixed" stratification method. + # Note that c(0.333, 0.667) means that 3 groups are created: a low risk group + # (up to 0.333), a moderate risk group (between 0.333 and 0.667), and a high + # risk group (0.667) + settings$strat_quant_threshold <- .parse_arg( + x_config = config$stratification_threshold, + x_var = stratification_threshold, + var_name = "stratification_threshold", + type = "numeric_list", + optional = TRUE, + default = c(1.0 / 3.0, 2.0 / 3.0) + ) + + sapply( + settings$strat_quant_threshold, + .check_number_in_valid_range, + var_name = "stratification_threshold", + range = c(0.0, 1.0), + closed = c(FALSE, FALSE) + ) + # evaluation time options ---------------------------------------------------- + settings <- c( + settings, + .parse_evaluation_time_settings( + data = data, + outcome_type = outcome_type, + config = config, + time_max = time_max, + evaluation_times = evaluation_times, + development_batch_id = development_batch_id + ) + ) + + # dynamic_model_loading ------------------------------------------------------ + # Dynamic loading of models during evaluation. + settings$auto_detach <- .parse_arg( + x_config = config$dynamic_model_loading, + x_var = dynamic_model_loading, + var_name = "dynamic_model_loading", + type = "logical", + optional = TRUE, + default = FALSE + ) + + # parallel_evaluation -------------------------------------------------------- + # Parallelisation switch for parallel processing + settings$do_parallel <- .parse_arg( + x_config = config$parallel_evaluation, + x_var = parallel_evaluation, + var_name = "parallel_evaluation", + type = "character", + optional = TRUE, + default = "TRUE" + ) + + .check_parameter_value_is_valid( + x = settings$do_parallel, + var_name = "parallel_evaluation", + values = c("TRUE", "FALSE", "inner", "outer") + ) + + # Disable if parallel is FALSE + if (!parallel) settings$do_parallel <- "FALSE" + + # Return list of settings + return(settings) +} + + + +.parse_feature_clustering <- function( + config = NULL, + default_cluster_method = waiver(), + default_cluster_linkage_method = waiver(), + default_cluster_cut_method = waiver(), + default_cluster_similarity_metric = waiver(), + default_cluster_similarity_threshold = waiver(), + feature_cluster_method = waiver(), + feature_linkage_method = waiver(), + feature_cluster_cut_method = waiver(), + feature_similarity_metric = waiver(), + feature_similarity_threshold = waiver(), + .check_more = TRUE +) { + settings <- list() + + # Set default cluster method. + if (is.waive(default_cluster_method)) default_cluster_method <- "hclust" + if (is.waive(default_cluster_linkage_method)) default_cluster_linkage_method <- "average" + if (is.waive(default_cluster_cut_method)) { + default_cluster_cut_method <- ifelse(default_cluster_method == "pam", "silhouette", "fixed_cut") + } + if (is.waive(default_cluster_similarity_metric)) default_cluster_similarity_metric <- "mutual_information" + if (is.waive(default_cluster_similarity_threshold)) default_cluster_similarity_threshold <- NULL + # feature_cluster_method ----------------------------------------------------- # Feature cluster method settings$feature_cluster_method <- .parse_arg( @@ -3964,8 +4631,9 @@ var_name = "feature_cluster_method", type = "character", optional = TRUE, - default = prep_cluster_method) - + default = default_cluster_method + ) + # feature_linkage_method ----------------------------------------------------- # Feature linkage method settings$feature_linkage_method <- .parse_arg( @@ -3974,8 +4642,9 @@ var_name = "feature_linkage_method", type = "character", optional = TRUE, - default = prep_cluster_linkage_method) - + default = default_cluster_linkage_method + ) + # feature_cluster_cut_method ------------------------------------------------- # Feature cluster cluster cut method settings$feature_cluster_cut_method <- .parse_arg( @@ -3984,8 +4653,9 @@ var_name = "feature_cluster_cut_method", type = "character", optional = TRUE, - default = prep_cluster_cut_method) - + default = default_cluster_cut_method + ) + # feature_similarity_metric -------------------------------------------------- # Feature similarity metric settings$feature_similarity_metric <- .parse_arg( @@ -3994,32 +4664,35 @@ var_name = "feature_similarity_metric", type = "character", optional = TRUE, - default = prep_cluster_similarity_metric) - - if ( - any(c("feature_similarity", "univariate_analysis", "feature_expressions", "permutation_vimp") %in% - settings$evaluation_data_elements) && - settings$feature_similarity_metric %in% c("mcfadden_r2", "cox_snell_r2", "nagelkerke_r2")) { + default = default_cluster_similarity_metric + ) + + # Perform additional checks, if required. + if (.check_more && settings$feature_similarity_metric %in% c("mcfadden_r2", "cox_snell_r2", "nagelkerke_r2")) { if (!require_package( x = "nnet", purpose = paste0( "to compute log-likelihood pseudo R2 similarity using the ", - settings$feature_similarity_metric, " metric"), - message_type = "backend_warning")) { + settings$feature_similarity_metric, " metric" + ), + message_type = "backend_warning" + )) { settings$feature_similarity_metric <- "spearman" } - } else if (settings$feature_similarity_metric %in% c("mutual_information")) { + } else if (.check_more && settings$feature_similarity_metric %in% c("mutual_information")) { if (!require_package( x = "praznik", purpose = paste0( "to compute similarity using the ", - settings$feature_similarity_metric, " metric"), - message_type = "backend_warning")) { - settings$cluster_similarity_metric <- "spearman" + settings$feature_similarity_metric, " metric" + ), + message_type = "backend_warning" + )) { + settings$feature_similarity_metric <- "spearman" } } - + # feature_similarity_threshold ----------------------------------------------- # Feature similarity threshold settings$feature_similarity_threshold <- .parse_arg( @@ -4028,11 +4701,41 @@ var_name = "feature_similarity_threshold", type = "numeric_list", optional = TRUE, - default = prep_cluster_similarity_threshold) - + default = default_cluster_similarity_threshold + ) + + if (is.null(settings$feature_similarity_threshold)) { + if (settings$feature_cluster_cut_method %in% c("fixed_cut")) { + # Fixed cut requires stringent defaults, otherwise non-sense clusters will + # be produced. + if (settings$feature_similarity_metric %in% c("mcfadden_r2")) { + settings$feature_similarity_threshold <- 0.30 + } else if (settings$feature_similarity_metric %in% c("mutual_information")) { + settings$feature_similarity_threshold <- 0.23 + } else if (settings$feature_similarity_metric %in% c("cox_snell_r2", "nagelkerke_r2")) { + settings$feature_similarity_threshold <- 0.75 + } else { + settings$feature_similarity_threshold <- 0.90 + } + + } else { + # The similarity threshold is also used to determine if any clusters could + # potentially be found. The threshold is set low so that other cut methods + # can be explored. + if (settings$feature_similarity_metric %in% c("mcfadden_r2")) { + settings$feature_similarity_threshold <- 0.25 + } else if (settings$feature_similarity_metric %in% c("mutual_information")) { + settings$feature_similarity_threshold <- 0.10 + } else if (settings$feature_similarity_metric %in% c("cox_snell_r2", "nagelkerke_r2")) { + settings$feature_similarity_threshold <- 0.40 + } else { + settings$feature_similarity_threshold <- 0.70 + } + } + } + # Check the proposed cluster parameters. - if (any(c("feature_similarity", "univariate_analysis", "feature_expressions", "permutation_vimp") %in% - settings$evaluation_data_elements)) { + if (.check_more) { .check_cluster_parameters( cluster_method = settings$feature_cluster_method, cluster_linkage = settings$feature_linkage_method, @@ -4040,9 +4743,30 @@ cluster_similarity_threshold = settings$feature_similarity_threshold, cluster_similarity_metric = settings$feature_similarity_metric, data_type = "feature", - message_type = "backend_error") + message_type = "backend_error" + ) } + + return(settings) +} + + +.parse_sample_clustering <- function( + config = NULL, + default_cluster_method = waiver(), + default_cluster_linkage_method = waiver(), + sample_cluster_method = waiver(), + sample_linkage_method = waiver(), + sample_similarity_metric = waiver(), + .check_more = TRUE +) { + settings <- list() + + # Set default cluster method. + if (is.waive(default_cluster_method)) default_cluster_method <- "hclust" + if (is.waive(default_cluster_linkage_method)) default_cluster_linkage_method <- "average" + # sample_cluster_method ------------------------------------------------------ # Sample cluster method settings$sample_cluster_method <- .parse_arg( @@ -4051,8 +4775,9 @@ var_name = "sample_cluster_method", type = "character", optional = TRUE, - default = prep_cluster_method) - + default = default_cluster_method + ) + # sample_linkage_method ------------------------------------------------------ # Sample cluster linkage method settings$sample_linkage_method <- .parse_arg( @@ -4061,8 +4786,9 @@ var_name = "sample_linkage_method", type = "character", optional = TRUE, - default = prep_cluster_linkage_method) - + default = default_cluster_linkage_method + ) + # sample_similarity_metric --------------------------------------------------- # Sample similarity metric settings$sample_similarity_metric <- .parse_arg( @@ -4071,122 +4797,55 @@ var_name = "sample_similarity_metric", type = "character", optional = TRUE, - default = "gower_winsor") - - if (any(c("sample_similarity", "feature_expressions") %in% settings$evaluation_data_elements) && - settings$sample_similarity_metric %in% c("mcfadden_r2", "cox_snell_r2", "nagelkerke_r2")) { + default = "gower_winsor" + ) + + # Check similarity metrics can be feasibly computed. + if ( + .check_more && + settings$sample_similarity_metric %in% c("mcfadden_r2", "cox_snell_r2", "nagelkerke_r2") + ) { if (!require_package( x = "nnet", purpose = paste0( "to compute log-likelihood pseudo R2 similarity using the ", - settings$sample_similarity_metric, " metric"), - message_type = "backend_warning")) { + settings$sample_similarity_metric, " metric" + ), + message_type = "backend_warning" + )) { settings$sample_similarity_metric <- "gower_winsor" } } - + # Check the proposed cluster parameters. - if (any(c("sample_similarity", "feature_expressions") %in% settings$evaluation_data_elements)) { + if (.check_more) { .check_cluster_parameters( cluster_method = settings$sample_cluster_method, cluster_linkage = settings$sample_linkage_method, cluster_similarity_metric = settings$sample_similarity_metric, data_type = "sample", - message_type = "backend_error") - } - - # eval_aggregation_method ---------------------------------------------------- - # Variable importance aggregation methods - settings$aggregation <- .parse_arg( - x_config = config$eval_aggregation_method, - x_var = eval_aggregation_method, - var_name = "eval_aggregation_method", - type = "character", - optional = TRUE, - default = vimp_aggregation_method) - - .check_parameter_value_is_valid( - x = settings$aggregation, - var_name = "eval_aggregation_method", - values = .get_available_rank_aggregation_methods()) - - # eval_aggregation_rank_threshold -------------------------------------------- - # Variable importance rank threshold (used by some aggregation methods) - settings$aggr_rank_threshold <- .parse_arg( - x_config = config$eval_aggregation_rank_threshold, - x_var = eval_aggregation_rank_threshold, - var_name = "eval_aggregation_rank_threshold", - type = "integer", - optional = TRUE, - default = vimp_aggregation_rank_threshold) - - if (!is.null(settings$aggr_rank_threshold)) { - .check_number_in_valid_range( - x = settings$aggr_rank_threshold, - var_name = "eval_aggregation_rank_threshold", - range = c(1, Inf)) - } - - # eval_icc_type -------------------------------------------------------------- - # Type of ICC computed for univariate analysis. - settings$icc_type <- .parse_arg( - x_config = config$eval_icc_type, - x_var = eval_icc_type, - var_name = "eval_icc_type", - type = "character", - optional = TRUE, - default = "1") - - .check_parameter_value_is_valid( - x = settings$icc_type, - var_name = "eval_icc_type", - values = .get_available_icc_types()) - - # stratification_method ------------------------------------------------------ - # Method used to set stratification thresholds for Kaplan-Meier analysis - settings$strat_method <- .parse_arg( - x_config = config$stratification_method, - x_var = stratification_method, - var_name = "stratification_method", - type = "character_list", - optional = TRUE, - default = "median") - - .check_parameter_value_is_valid( - x = settings$strat_method, - var_name = "stratification_method", - values = .get_available_stratification_methods()) - - if ("optimised" %in% settings$strat_method) { - if (!require_package( - x = "maxstat", - purpose = "to determine an optimal risk threshold", - message_type = "backend_warning")) { - settings$strat_method <- setdiff(settings$strat_method, "optimised") - if (length(settings$strat_method) == 0) settings$strat_method <- "median" - } + message_type = "backend_error" + ) } + + return(settings) +} - # stratification_threshold --------------------------------------------------- - # Quantile stratification thresholds for the "fixed" stratification method. - # Note that c(0.333, 0.667) means that 3 groups are created: a low risk group - # (up to 0.333), a moderate risk group (between 0.333 and 0.667), and a high - # risk group (0.667) - settings$strat_quant_threshold <- .parse_arg( - x_config = config$stratification_threshold, - x_var = stratification_threshold, - var_name = "stratification_threshold", - type = "numeric_list", - optional = TRUE, - default = c(1 / 3, 2 / 3)) - sapply( - settings$strat_quant_threshold, - .check_number_in_valid_range, - var_name = "stratification_threshold", - range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) +.parse_evaluation_time_settings <- function( + data, + outcome_type, + config = NULL, + time_max = waiver(), + evaluation_times = waiver(), + development_batch_id = NULL +) { + # Suppress NOTES due to non-standard evaluation in data.table + outcome_event <- batch_id <- NULL + + settings <- list() + # time_max ------------------------------------------------------------------- # Study end time (this is used for plotting, and Uno's concordance index). settings$time_max <- .parse_arg( @@ -4195,8 +4854,9 @@ var_name = "time_max", type = "numeric", optional = TRUE, - default = NULL) - + default = NULL + ) + # evaluation_times ----------------------------------------------------------- # Times at which calibration is evaluated for time-to-event (survival) data. settings$eval_times <- .parse_arg( @@ -4205,8 +4865,9 @@ var_name = "evaluation_time", type = "numeric_list", optional = TRUE, - default = NULL) - + default = NULL + ) + # Update time_max and eval_times only if we are dealing with survival # endpoints. if (outcome_type %in% c("survival")) { @@ -4218,26 +4879,24 @@ } else if (!is.null(development_batch_id)) { # 98th percentile of all outcome times in the training cohorts. - settings$time_max <- stats::quantile( - data[outcome_event == 1 & batch_id %in% development_batch_id]$outcome_time, - probs = 0.98, - na.rm = TRUE, - names = FALSE) + settings$time_max <- .get_default_time_max( + data[outcome_event == 1L & batch_id %in% development_batch_id]$outcome_time + ) } else { - # 98th percentile of all outcome times. - settings$time_max <- stats::quantile(data[outcome_event == 1]$outcome_time, - probs = 0.98, - na.rm = TRUE, - names = FALSE) + # 98th percentile of all outcome times in the training cohorts. + settings$time_max <- .get_default_time_max( + data[outcome_event == 1L]$outcome_time + ) } } - + .check_number_in_valid_range( settings$time_max, var_name = "time_max", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) # Identify evaluation times if they were not provided. if (is.null(settings$eval_times)) settings$eval_times <- settings$time_max @@ -4247,38 +4906,10 @@ .check_number_in_valid_range, var_name = "evaluation_times", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) } - - # dynamic_model_loading ------------------------------------------------------ - # Dynamic loading of models during evaluation. - settings$auto_detach <- .parse_arg( - x_config = config$dynamic_model_loading, - x_var = dynamic_model_loading, - var_name = "dynamic_model_loading", - type = "logical", - optional = TRUE, - default = FALSE) - - # parallel_evaluation -------------------------------------------------------- - # Parallelisation switch for parallel processing - settings$do_parallel <- .parse_arg( - x_config = config$parallel_evaluation, - x_var = parallel_evaluation, - var_name = "parallel_evaluation", - type = "character", - optional = TRUE, - default = "TRUE") - - .check_parameter_value_is_valid( - x = settings$do_parallel, - var_name = "parallel_evaluation", - values = c("TRUE", "FALSE", "inner", "outer")) - - # Disable if parallel is FALSE - if (!parallel) settings$do_parallel <- "FALSE" - - # Return list of settings + return(settings) } @@ -4291,7 +4922,7 @@ names(as.list(args(.parse_experiment_settings))), names(as.list(args(.parse_setup_settings))), names(as.list(args(.parse_preprocessing_settings))), - names(as.list(args(.parse_feature_selection_settings))), + names(as.list(args(.parse_variable_importance_settings))), names(as.list(args(.parse_model_development_settings))), names(as.list(args(.parse_hyperparameter_optimisation_settings))), names(as.list(args(.parse_evaluation_settings))) @@ -4322,7 +4953,23 @@ .get_all_configuration_parent_node_names <- function() { return(c( - "paths", "data", "run", "preprocessing", "feature_selection", + "paths", "data", "run", "preprocessing", "variable_importance", "model_development", "hyperparameter_optimisation", "evaluation" )) } + + + +.get_default_time_max <- function(x) { + if (is_empty(x)) return(Inf) + if (!any(is.finite(x))) return(Inf) + + x <- x[is.finite(x)] + + return(stats::quantile( + x, + probs = 0.98, + na.rm = TRUE, + names = FALSE + )) +} diff --git a/R/PlotAUCcurves.R b/R/PlotAUCcurves.R index d7504167..cb85107c 100644 --- a/R/PlotAUCcurves.R +++ b/R/PlotAUCcurves.R @@ -7,14 +7,12 @@ NULL #' @title Plot the receiver operating characteristic curve. #' #' @description This method creates receiver operating characteristic curves -#' based on data in a familiarCollection object. +#' based on data in a familiarCollection object. #' -#' @param dir_path (*optional*) Path to the directory where the plots of receiver -#' operating characteristic curves are saved to. Output is saved in the -#' `performance` subdirectory. If `NULL` no figures are saved, but are returned -#' instead. -#' @param discrete_palette (*optional*) Palette to use to color the different -#' plot elements in case a value was provided to the `color_by` argument. +#' @param dir_path (*optional*) Path to the directory where the plots of +#' receiver operating characteristic curves are saved to. Output is saved in +#' the `performance` subdirectory. If `NULL` no figures are saved, but are +#' returned instead. #' #' @inheritParams as_familiar_collection #' @inheritParams plot_univariate_importance @@ -26,33 +24,25 @@ NULL #' #' @details This function generates area under the ROC curve plots. #' -#' Available splitting variables are: `fs_method`, `learner`, `data_set` and -#' `positive_class`. By default, the data is split by `fs_method` and `learner`, -#' with faceting by `data_set` and colouring by `positive_class`. -#' -#' Available palettes for `discrete_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. +#' Available splitting variables are: `vimp_method`, `learner`, `data_set` and +#' `positive_class`. By default, the data is split by `vimp_method` and +#' `learner`, with faceting by `data_set` and colouring by `positive_class`. #' -#' Bootstrap confidence intervals of the ROC curve (if present) can be shown -#' using various styles set by `conf_int_style`: +#' Bootstrap confidence intervals of the ROC curve (if present) can be shown +#' using various styles set by `conf_int_style`: #' #' * `ribbon` (default): confidence intervals are shown as a ribbon with an -#' opacity of `conf_int_alpha` around the point estimate of the ROC curve. +#' opacity of `conf_int_alpha` around the point estimate of the ROC curve. #' #' * `step` (default): confidence intervals are shown as a step function around -#' the point estimate of the ROC curve. +#' the point estimate of the ROC curve. #' #' * `none`: confidence intervals are not shown. The point estimate of the ROC -#' curve is shown as usual. +#' curve is shown as usual. #' -#' Labelling methods such as `set_fs_method_names` or `set_data_set_names` can -#' be applied to the `familiarCollection` object to update labels, and order -#' the output in the figure. +#' Labelling methods such as `set_vimp_method_names` or `set_data_set_names` can +#' be applied to the `familiarCollection` object to update labels, and order +#' the output in the figure. #' #' @return `NULL` or list of plot objects, if `dir_path` is `NULL`. #' @@ -77,17 +67,18 @@ setGeneric( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_auc_roc_curve") } ) @@ -114,25 +105,29 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "auc_data"), - list(...))) + "data_element" = "auc_data" + ), + list(...) + ) + ) return(do.call( plot_auc_roc_curve, @@ -161,7 +156,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -188,17 +185,18 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -230,7 +228,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -249,8 +249,8 @@ setMethod( #' #' @details This function generates area under the precision-recall curve plots. #' -#' Available splitting variables are: `fs_method`, `learner`, `data_set` and -#' `positive_class`. By default, the data is split by `fs_method` and `learner`, +#' Available splitting variables are: `vimp_method`, `learner`, `data_set` and +#' `positive_class`. By default, the data is split by `vimp_method` and `learner`, #' with faceting by `data_set` and colouring by `positive_class`. #' #' Available palettes for `discrete_palette` are those listed by @@ -273,7 +273,7 @@ setMethod( #' * `none`: confidence intervals are not shown. The point estimate of the ROC #' curve is shown as usual. #' -#' Labelling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labelling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -300,17 +300,18 @@ setGeneric( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_auc_precision_recall_curve") } ) @@ -339,25 +340,29 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "auc_data"), - list(...))) + "data_element" = "auc_data" + ), + list(...) + ) + ) return(do.call( plot_auc_precision_recall_curve, @@ -386,7 +391,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -414,17 +421,18 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -456,7 +464,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -479,22 +489,24 @@ setMethod( plot_title = NULL, plot_sub_title = NULL, caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... +) { # Get input data. x <- export_auc_data( object = object, - aggregate_results = TRUE) + aggregate_results = TRUE + ) # Check that the data are not empty. if (is_empty(x)) return(NULL) @@ -509,13 +521,14 @@ setMethod( if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) { + if (length(x) > 1L) { ..error_reached_unreachable_code( - ".plot_auc_curve: list of data elements contains unmerged elements.") + ".plot_auc_curve: list of data elements contains unmerged elements." + ) } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -525,7 +538,8 @@ setMethod( .check_parameter_value_is_valid( x = curve_type, var_name = "curve_type", - values = c("roc", "pr")) + values = c("roc", "pr") + ) # Select the correct subset. if (curve_type == "roc") { @@ -540,10 +554,13 @@ setMethod( # Check package requirements for plotting. if (!require_package( x = ..required_plotting_packages(extended = FALSE), - purpose = ifelse(curve_type == "roc", - "to create AUC-ROC plots", - "to create AUC-PR plots"), - message_type = "warning")) { + purpose = ifelse( + curve_type == "roc", + "to create AUC-ROC plots", + "to create AUC-PR plots" + ), + message_type = "warning" + )) { return(NULL) } @@ -570,9 +587,10 @@ setMethod( # Create breaks x_breaks <- labeling::extended( m = x_n_breaks, - dmin = x_range[1], - dmax = x_range[2], - only.loose = TRUE) + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) } # y_breaks @@ -582,14 +600,15 @@ setMethod( # Create breaks y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) } # conf_int_style - if (length(conf_int_style) > 1) { - conf_int_style <- head(conf_int_style, n = 1) + if (length(conf_int_style) > 1L) { + conf_int_style <- head(conf_int_style, n = 1L) } # Set the style of the confidence interval to none, in case no confidence @@ -602,52 +621,55 @@ setMethod( if (is.null(split_by) && is.null(facet_by) && is.null(color_by)) { # Determine the number of learners and feature_selection methods. n_learner <- nlevels(x@data$learner) - n_fs_method <- nlevels(x@data$fs_method) + n_vimp_method <- nlevels(x@data$vimp_method) n_positive_class <- ifelse( object@outcome_type == "binomial", - 1L, nlevels(x@data$positive_class)) + 1L, nlevels(x@data$positive_class) + ) - if (n_learner > 1 && n_fs_method > 1) { - split_by <- c("fs_method", "learner") + if (n_learner > 1L && n_vimp_method > 1L) { + split_by <- c("vimp_method", "learner") - if (n_positive_class > 1) { + if (n_positive_class > 1L) { color_by <- "positive_class" facet_by <- "data_set" + } else { color_by <- c("data_set", "positive_class") } - } else if (n_learner > 1) { - # Implying n_fs_method == 1 + } else if (n_learner > 1L) { + # Implying n_vimp_method == 1 - if (n_positive_class > 1) { - split_by <- c("fs_method", "learner") + if (n_positive_class > 1L) { + split_by <- c("vimp_method", "learner") color_by <- "positive_class" facet_by <- "data_set" + } else { - split_by <- c("fs_method") + split_by <- c("vimp_method") color_by <- c("learner") facet_by <- c("data_set", "positive_class") } - } else if (n_fs_method > 1) { + } else if (n_vimp_method > 1L) { # Implying n_learner == 1 - if (n_positive_class > 1) { - split_by <- c("fs_method", "learner") + if (n_positive_class > 1L) { + split_by <- c("vimp_method", "learner") color_by <- "positive_class" facet_by <- "data_set" } else { split_by <- "learner" - color_by <- "fs_method" + color_by <- "vimp_method" facet_by <- c("data_set", "positive_class") } } else { - # Implying n_learner == n_fs_method == 1 - split_by <- c("fs_method", "learner") + # Implying n_learner == n_vimp_method == 1 + split_by <- c("vimp_method", "learner") - if (n_positive_class > 1) { + if (n_positive_class > 1L) { color_by <- "positive_class" facet_by <- "data_set" } else { @@ -662,7 +684,8 @@ setMethod( split_by = split_by, color_by = color_by, facet_by = facet_by, - available = c("fs_method", "learner", "data_set", "positive_class")) + available = c("vimp_method", "learner", "data_set", "positive_class") + ) # Update splitting variables split_by <- split_var_list$split_by @@ -672,7 +695,8 @@ setMethod( # Create a legend label legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) # Check input arguments for validity. .check_input_plot_args( @@ -688,7 +712,8 @@ setMethod( legend_label = legend_label, plot_title = plot_title, plot_sub_title = plot_sub_title, - caption = caption) + caption = caption + ) # Create plots --------------------------------------------------------------- @@ -708,19 +733,21 @@ setMethod( # Iterate over splits for (ii in names(x_split)) { # Skip empty datasets - if (is_empty(x_split[[ii]])) next() + if (is_empty(x_split[[ii]])) next if (is.waive(plot_title)) { plot_title <- ifelse( curve_type == "roc", "Receiver operating characteristic curve", - "Precision-recall curve") + "Precision-recall curve" + ) } if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, - x = x_split[[ii]]) + x = x_split[[ii]] + ) } # Generate plot @@ -757,7 +784,8 @@ setMethod( def_plot_dims <- .determine_auc_roc_plot_dimensions( x = x_split[[ii]], facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Save to file. do.call( @@ -771,10 +799,13 @@ setMethod( "subtype" = paste0("auc_", curve_type), "x" = x_split[[ii]], "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list for export. @@ -787,7 +818,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } @@ -810,11 +842,13 @@ setMethod( y_range, y_breaks, conf_int_style, - conf_int_alpha) { + conf_int_alpha +) { # Generate a guide table. guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- guide_list$data @@ -824,7 +858,9 @@ setMethod( data = x, mapping = ggplot2::aes( x = !!sym("x"), - y = !!sym("y"))) + y = !!sym("y") + ) + ) # Add theme p <- p + ggtheme @@ -837,7 +873,8 @@ setMethod( } else { # With colour-based splitting. p <- p + ggplot2::geom_line( - mapping = ggplot2::aes(colour = !!sym("color_breaks"))) + mapping = ggplot2::aes(colour = !!sym("color_breaks")) + ) # Extract guidetable for color g_color <- guide_list$guide_color @@ -847,59 +884,71 @@ setMethod( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } # Plot confidence intervals - if (conf_int_style[1] != "none") { - if (conf_int_style[1] == "step") { + if (conf_int_style[1L] != "none") { + if (conf_int_style[1L] == "step") { if (is.null(color_by)) { p <- p + ggplot2::geom_step( mapping = ggplot2::aes(y = !!sym("ci_low")), - linetype = "dashed") + linetype = "dashed" + ) p <- p + ggplot2::geom_step( mapping = ggplot2::aes(y = !!sym("ci_up")), - linetype = "dashed") + linetype = "dashed" + ) } else { p <- p + ggplot2::geom_step( mapping = ggplot2::aes( y = !!sym("ci_low"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) p <- p + ggplot2::geom_step( mapping = ggplot2::aes( y = !!sym("ci_up"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) } # Do not show dashed lines in the legend. - p <- p + ggplot2::scale_linetype(guide = FALSE) + p <- p + ggplot2::scale_linetype(guide = "none") - } else if (conf_int_style[1] == "ribbon") { + } else if (conf_int_style[1L] == "ribbon") { if (is.null(color_by)) { p <- p + ggplot2::geom_ribbon( mapping = ggplot2::aes( ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), - alpha = conf_int_alpha) + ymax = !!sym("ci_up") + ), + alpha = conf_int_alpha + ) } else { p <- p + ggplot2::geom_ribbon( mapping = ggplot2::aes( ymin = !!sym("ci_low"), ymax = !!sym("ci_up"), - fill = !!sym("color_breaks")), - alpha = conf_int_alpha) + fill = !!sym("color_breaks") + ), + alpha = conf_int_alpha + ) } } } @@ -914,13 +963,15 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Determine how things are faceted facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -929,20 +980,23 @@ setMethod( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } } # Prevent removal of data outside or on plot limits. p <- p + ggplot2::coord_cartesian( xlim = x_range, - ylim = y_range) + ylim = y_range + ) return(p) } @@ -952,22 +1006,24 @@ setMethod( .determine_auc_roc_plot_dimensions <- function( x, facet_by, - facet_wrap_cols) { + facet_wrap_cols +) { # Obtain faceting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Set default height and width for each subplot (in cm). - default_width <- 6 - default_height <- 4 + default_width <- 6.0 + default_height <- 4.0 # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } diff --git a/R/PlotAll.R b/R/PlotAll.R index 26f49c92..ab9d5fca 100644 --- a/R/PlotAll.R +++ b/R/PlotAll.R @@ -4,7 +4,10 @@ NULL # plot_all (generic) ----------------------------------------------------------- -setGeneric("plot_all", function(object, ...) standardGeneric("plot_all")) +setGeneric( + "plot_all", + function(object, ...) standardGeneric("plot_all") +) @@ -15,162 +18,261 @@ setMethod( function(object, dir_path = NULL, ...) { if (!is.null(dir_path)) dir_path <- encapsulate_path(dir_path) - + # Make sure the collection object is updated. object <- update_object(object = object) - + # Feature univariate p-values (horizontal bars) do.call( plot_univariate_importance, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Feature occurrence (unclustered) do.call( plot_feature_selection_occurrence, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Feature ranking (unclustered) do.call( plot_feature_selection_variable_importance, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Model signature occurrence (unclustered) do.call( plot_model_signature_occurrence, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Model signature ranking (unclustered) do.call( plot_model_signature_variable_importance, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Permutation variable importance do.call( plot_permutation_variable_importance, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Feature similarity heatmap do.call( plot_feature_similarity, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Calibration curves do.call( plot_calibration_data, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Model performance do.call( plot_model_performance, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # AUC-ROC curve do.call( plot_auc_roc_curve, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # AUC-PR curve do.call( plot_auc_precision_recall_curve, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Decision curve do.call( plot_decision_curve, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Kaplan-Meier curves do.call( plot_kaplan_meier, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Feature expressions do.call( plot_sample_clustering, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Confusion matrix do.call( plot_confusion_matrix, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Individual conditional expectation do.call( plot_ice, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) - + "dir_path" = dir_path + ), + list(...) + ) + ) + # Partial dependence do.call( plot_pd, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...))) + "dir_path" = dir_path + ), + list(...) + ) + ) + + # SHAP summary. + do.call( + plot_shap_summary, + args = c( + list( + "object" = object, + "dir_path" = dir_path + ), + list(...) + ) + ) + + # SHAP waterfall. + do.call( + plot_shap_waterfall, + args = c( + list( + "object" = object, + "dir_path" = dir_path + ), + list(...) + ) + ) + + # SHAP force. + do.call( + plot_shap_force, + args = c( + list( + "object" = object, + "dir_path" = dir_path + ), + list(...) + ) + ) + + # SHAP dependence. + do.call( + plot_shap_dependence, + args = c( + list( + "object" = object, + "dir_path" = dir_path + ), + list(...) + ) + ) return(invisible(NULL)) } @@ -188,15 +290,21 @@ setMethod( args = c( list( "object" = object, - "data_element" = "all"), - list(...))) + "data_element" = "all" + ), + list(...) + ) + ) return(do.call( plot_all, args = c( list( "object" = object, - "dir_path" = dir_path), - list(...)))) + "dir_path" = dir_path + ), + list(...) + ) + )) } ) diff --git a/R/PlotCalibration.R b/R/PlotCalibration.R index 352d2b2e..d0a52fdd 100644 --- a/R/PlotCalibration.R +++ b/R/PlotCalibration.R @@ -16,9 +16,6 @@ NULL #' @param dir_path (*optional*) Path to the directory where created calibration #' plots are saved to. Output is saved in the `calibration` subdirectory. If #' `NULL` no figures are saved, but are returned instead. -#' @param discrete_palette (*optional*) Palette to use to color the different -#' data points and fit lines in case a non-singular variable was provided to -#' the `color_by` argument. #' @param show_density (*optional*) Show point density in top margin of the #' figure. If `color_by` is set, this information will not be shown. #' @param show_calibration_fit (*optional*) Specifies whether the calibration in @@ -43,10 +40,10 @@ NULL #' dataset. Any data used for calibration (e.g. baseline survival) is obtained #' during model creation. #' -#' Available splitting variables are: `fs_method`, `learner`, `data_set` and +#' Available splitting variables are: `vimp_method`, `learner`, `data_set` and #' `evaluation_time` (survival analysis only) and `positive_class` (multinomial #' endpoints only). By default, separate figures are created for each -#' combination of `fs_method` and `learner`, with facetting by `data_set`. +#' combination of `vimp_method` and `learner`, with facetting by `data_set`. #' #' Calibration in survival analysis is performed at set time points so that #' survival probabilities can be computed from the model, and compared with @@ -79,15 +76,7 @@ NULL #' is only annotated when `color_by` is not used as a splitting variable (i.e. #' one calibration plot per facet). #' -#' Available palettes for `discrete_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. -#' -#' Labeling methods such as `set_risk_group_names` or `set_data_set_names` can +#' Labelling methods such as `set_risk_group_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -128,13 +117,13 @@ setGeneric( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_density = TRUE, show_calibration_fit = TRUE, show_goodness_of_fit = TRUE, @@ -143,7 +132,8 @@ setGeneric( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_calibration_data") } ) @@ -175,13 +165,13 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_density = TRUE, show_calibration_fit = TRUE, show_goodness_of_fit = TRUE, @@ -190,13 +180,16 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list("object" = object, "data_element" = "calibration_data"), - list(...))) + list(...) + ) + ) return(do.call( plot_calibration_data, @@ -233,7 +226,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -264,13 +259,13 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_density = TRUE, show_calibration_fit = TRUE, show_goodness_of_fit = TRUE, @@ -279,7 +274,8 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table .NATURAL <- NULL @@ -289,7 +285,8 @@ setMethod( # Get input data x <- export_calibration_data( object = object, - aggregate_results = TRUE) + aggregate_results = TRUE + ) # Check that the data are not empty. if (is_empty(x$data)) return(NULL) @@ -301,10 +298,10 @@ setMethod( } # Get data - calibration_data <- x$data[[1]]@data - density_data <- x$density[[1]]@data - linear_test_data <- x$linear_test[[1]]@data - gof_test_data <- x$gof_test[[1]]@data + calibration_data <- x$data[[1L]]@data + density_data <- x$density[[1L]]@data + linear_test_data <- x$linear_test[[1L]]@data + gof_test_data <- x$gof_test[[1L]]@data # Check that the calibration data are not empty. if (is_empty(calibration_data)) return(NULL) @@ -313,7 +310,8 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = TRUE), purpose = "to create calibration plots", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -337,50 +335,54 @@ setMethod( } # x_range - if (is.null(x_range)) x_range <- c(0, 1) + if (is.null(x_range)) x_range <- c(0.0, 1.0) # x_breaks if (is.null(x_breaks)) { # Check input arguments. .check_input_plot_args( x_range = x_range, - x_n_breaks = x_n_breaks) + x_n_breaks = x_n_breaks + ) # Create breaks and update x_range x_breaks <- labeling::extended( m = x_n_breaks, - dmin = x_range[1], - dmax = x_range[2], - only.loose = TRUE) + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) - x_range <- c(head(x_breaks, n = 1), tail(x_breaks, n = 1)) + x_range <- c(head(x_breaks, n = 1L), tail(x_breaks, n = 1L)) } # y_range - if (is.null(y_range)) y_range <- c(0, 1) + if (is.null(y_range)) y_range <- c(0.0, 1.0) # y_breaks if (is.null(y_breaks)) { # Check input arguments. .check_input_plot_args( y_range = y_range, - y_n_breaks = y_n_breaks) + y_n_breaks = y_n_breaks + ) # Create breaks and update y_range y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) - y_range <- c(head(y_breaks, n = 1), tail(y_breaks, n = 1)) + y_range <- c(head(y_breaks, n = 1L), tail(y_breaks, n = 1L)) } # x_label if (is.waive(x_label)) { if (object@outcome_type %in% c("binomial", "multinomial")) { x_label <- "expected probability" - } else if (object@outcome_type %in% c("count", "continuous")) { + } else if (object@outcome_type %in% c("continuous")) { x_label <- "expected value" } else if (object@outcome_type %in% c("survival")) { x_label <- "expected survival probability" @@ -393,7 +395,7 @@ setMethod( if (is.waive(y_label)) { if (object@outcome_type %in% c("binomial", "multinomial")) { y_label <- "observed proportion" - } else if (object@outcome_type %in% c("count", "continuous")) { + } else if (object@outcome_type %in% c("continuous")) { y_label <- "observed value" } else if (object@outcome_type %in% c("survival")) { y_label <- "observed survival proportion" @@ -403,19 +405,19 @@ setMethod( } # conf_int_style - if (length(conf_int_style) > 1) { - conf_int_style <- head(conf_int_style, n = 1) + if (length(conf_int_style) > 1L) { + conf_int_style <- head(conf_int_style, n = 1L) } # Set the style of the confidence interval to none, in case no confidence # interval data is present. - if (!x$data[[1]]@estimation_type %in% c("bci", "bootstrap_confidence_interval")) { + if (!x$data[[1L]]@estimation_type %in% c("bci", "bootstrap_confidence_interval")) { conf_int_style <- "none" } # Add default splitting variables. if (is.null(split_by) & is.null(color_by) & is.null(facet_by)) { - split_by <- c("fs_method", "learner") + split_by <- c("vimp_method", "learner") # Set faceting variables facet_by <- c("data_set") @@ -424,8 +426,8 @@ setMethod( # analysis. if (object@outcome_type %in% c("survival")) { facet_by <- c(facet_by, "evaluation_time") - } else if ( - object@outcome_type %in% c("multinomial")) { + + } else if (object@outcome_type %in% c("multinomial")) { facet_by <- c(facet_by, "positive_class") } } @@ -434,7 +436,7 @@ setMethod( # studied. For survival outcomes, evaluation time is an additional splitting # point. For multinomial outcomes, the positive class indicator is an # additional splitting variable. - available_splitting_vars <- c("fs_method", "learner", "data_set") + available_splitting_vars <- c("vimp_method", "learner", "data_set") if (object@outcome_type %in% c("survival")) { available_splitting_vars <- c(available_splitting_vars, "evaluation_time") } else if (object@outcome_type %in% c("multinomial")) { @@ -447,7 +449,8 @@ setMethod( split_by = split_by, color_by = color_by, facet_by = facet_by, - available = available_splitting_vars) + available = available_splitting_vars + ) # Update splitting variables split_by <- split_var_list$split_by @@ -457,7 +460,8 @@ setMethod( # Create a legend label legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) # Update show_density, show_goodness_of_fit and show_calibration_fit # variables so that they are FALSE in case color_by is set. @@ -471,22 +475,26 @@ setMethod( .check_parameter_value_is_valid( x = show_calibration_fit, var_name = "show_calibration_fit", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) .check_parameter_value_is_valid( x = show_goodness_of_fit, var_name = "show_goodness_of_fit", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) .check_parameter_value_is_valid( x = show_density, var_name = "show_density", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) # Check density_plot_height .check_plot_grid_unit( x = density_plot_height, - var_name = "density_plot_height") + var_name = "density_plot_height" + ) # Check input arguments for validity. .check_input_plot_args( @@ -500,7 +508,8 @@ setMethod( legend_label = legend_label, plot_title = plot_title, plot_sub_title = plot_sub_title, - caption = caption) + caption = caption + ) # Create plots ------------------------------------------------------------- @@ -512,7 +521,8 @@ setMethod( data_split <- split( unique(calibration_data[, mget(split_by)]), by = split_by, - drop = TRUE) + drop = TRUE + ) } else { data_split <- list(NULL) @@ -522,7 +532,7 @@ setMethod( if (is.null(dir_path)) plot_list <- list() # Find grouping columns - grouping_column <- x$data[[1]]@grouping_column + grouping_column <- x$data[[1L]]@grouping_column grouping_column <- setdiff(grouping_column, "expected") # Iterate over splits @@ -577,18 +587,22 @@ setMethod( # Add evaluation time as subtitle component if it is not used # otherwise. - if (!"evaluation_time" %in% c(split_by, color_by, facet_by) && - object@outcome_type %in% c("survival")) { + if ( + !"evaluation_time" %in% c(split_by, color_by, facet_by) && + object@outcome_type %in% c("survival") + ) { additional_subtitle <- c( additional_subtitle, - .add_time_to_plot_subtitle(calibration_data_split$evaluation_time[1])) + .add_time_to_plot_subtitle(calibration_data_split$evaluation_time[1L]) + ) } if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = additional_subtitle, - x = current_split) + x = current_split + ) } # Generate plot @@ -621,8 +635,9 @@ setMethod( gof_test = gof_test_data_split, density = density_data_split, outcome_type = object@outcome_type, - grouping_column = x$linear_test[[1]]@grouping_column, - is_point = x$data[[1]]@estimation_type %in% c("point")) + grouping_column = x$linear_test[[1L]]@grouping_column, + is_point = x$data[[1L]]@estimation_type %in% c("point") + ) # Check empty output if (is.null(p)) next @@ -637,7 +652,8 @@ setMethod( x = calibration_data_split, facet_by = facet_by, facet_wrap_cols = facet_wrap_cols, - show_density = show_density) + show_density = show_density + ) # Save to file. do.call( @@ -650,10 +666,13 @@ setMethod( "type" = "calibration", "x" = current_split, "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list and export @@ -666,7 +685,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -702,34 +722,50 @@ setMethod( density, outcome_type, grouping_column, - is_point) { + is_point +) { # Split by facet. This generates a list of data splits with faceting # information that allows for positioning. plot_layout_table <- .get_plot_layout_table( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) + + # Used for ordering of composite figures. + layout_split <- split( + plot_layout_table, + by = c("col_id", "row_id"), + sorted = TRUE + ) # Split data into facets. This is done by row. data_facet_list <- .split_data_by_plot_facet( x = x, - plot_layout_table = plot_layout_table) + plot_layout_table = plot_layout_table + ) linear_test_facet_list <- .split_data_by_plot_facet( x = linear_test, - plot_layout_table = plot_layout_table) + plot_layout_table = plot_layout_table + ) gof_test_facet_list <- .split_data_by_plot_facet( x = gof_test, - plot_layout_table = plot_layout_table) + plot_layout_table = plot_layout_table + ) density_facet_list <- .split_data_by_plot_facet( x = density, - plot_layout_table = plot_layout_table) + plot_layout_table = plot_layout_table + ) # Placeholders for plots. figure_list <- list() extracted_element_list <- list() # Iterate over facets - for (ii in names(data_facet_list)) { + for (ii in names(layout_split)) { + + if (is_empty(data_facet_list[[ii]])) next + # Create calibration plot. p_calibration <- .create_calibration_plot( x = data_facet_list[[ii]], @@ -756,22 +792,19 @@ setMethod( gof_test = gof_test_facet_list[[ii]], outcome_type = outcome_type, grouping_column = grouping_column, - is_point = is_point) - - # Extract plot elements from the main calibration plot. - extracted_elements <- .extract_plot_grobs(p = p_calibration) - - # Remove extracted elements from the plot. - p_calibration <- .remove_plot_grobs(p = p_calibration) - + is_point = is_point + ) + # Rename plot elements. g_calibration <- .rename_plot_grobs( g = .convert_to_grob(p_calibration), - extension = "main") + extension = "main" + ) + if (!gtable::is.gtable(g_calibration)) next - if (show_density && - gtable::is.gtable(g_calibration) && - !is_empty(density_facet_list[[ii]])) { + if ( + show_density && !is_empty(density_facet_list[[ii]]) + ) { # Procedure for normal density plots. p_margin <- .create_calibration_density_subplot( x = density_facet_list[[ii]], @@ -779,52 +812,44 @@ setMethod( x_range = x_range, x_breaks = x_breaks, flip = FALSE, - plot_height = density_plot_height) + plot_height = density_plot_height + ) # Extract the panel element from the density plot. - g_margin <- .gtable_extract( + # Convert to gtable + g_margin <- .rename_plot_grobs( g = .convert_to_grob(p_margin), - element = c("panel"), - partial_match = TRUE) - - # Insert in the calibration plot at the top margin. + extension = "density" + ) + g_calibration <- .gtable_insert( g = g_calibration, - g_new = g_margin, - where = "top", - ref_element = "panel-main", - partial_match = TRUE, - spacer = list("b" = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "x"))) + g_new = .gtable_extract_grob(g_margin, element = "panel-density"), + where = c("above", "panel-main"), + grob_name = "panel-density", + spacer = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "y") + ) } - - # Add combined grob to list - figure_list <- c( - figure_list, - list(g_calibration)) - - # Add extract elements to the grob_element_list - extracted_element_list <- c( - extracted_element_list, - list(extracted_elements)) + + # Attach to figure list. + figure_list[[paste0(layout_split[[ii]]$row_id, ".", layout_split[[ii]]$col_id)]] <- as_familiar_plot( + g = g_calibration, + layout = layout_split[[ii]] + ) } - # Update the layout table. - plot_layout_table <- .update_plot_layout_table( + # Compose the final figure. Magic. + g <- .compose_figure( + figure_list = figure_list, plot_layout_table = plot_layout_table, - grobs = figure_list, x_text_shared = x_label_shared, x_label_shared = x_label_shared, y_text_shared = y_label_shared, y_label_shared = y_label_shared, - facet_wrap_cols = facet_wrap_cols) - - # Combine features. - g <- .arrange_plot_grobs( - grobs = figure_list, - plot_layout_table = plot_layout_table, - element_grobs = extracted_element_list, - ggtheme = ggtheme) - + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme + ) + return(g) } @@ -855,7 +880,8 @@ setMethod( linear_test, gof_test, outcome_type, - is_point) { + is_point +) { # Suppress NOTES due to non-standard evaluation in data.table type <- NULL @@ -866,14 +892,16 @@ setMethod( # outcomes. cast_formula <- stats::as.formula(paste0( paste(setdiff(grouping_column, "type"), collapse = "+"), - "~type")) + "~type" + )) if (!is_empty(linear_test)) { # Cast wide on the value of the intercept or slope coefficient. linear_fit <- data.table::dcast( data = linear_test, cast_formula, - value.var = "value") + value.var = "value" + ) } else { linear_fit <- NULL @@ -884,11 +912,13 @@ setMethod( x_guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) fit_guide_list <- .create_plot_guide_table( x = linear_fit, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- x_guide_list$data @@ -898,7 +928,9 @@ setMethod( data = x, mapping = ggplot2::aes( x = !!sym("expected"), - y = !!sym("observed"))) + y = !!sym("observed") + ) + ) # Add theme p <- p + ggtheme @@ -908,34 +940,25 @@ setMethod( slope = 1.0, intercept = 0.0, colour = "grey80", - linetype = "dashed") + linetype = "dashed" + ) # Add fill colors if (!is.null(color_by)) { if (is_point) { # Add scatter for individual data points. p <- p + ggplot2::geom_point( - mapping = ggplot2::aes(colour = !!sym("color_breaks"))) + mapping = ggplot2::aes(colour = !!sym("color_breaks")) + ) } else { - if (utils::packageVersion("ggplot2") >= "3.4.0") { - # Version 3.4.0 introduces the linewidth element for geom_line, and will - # produce deprecation warnings if the size argument is used instead. - - # Add line for individual data points. - p <- p + ggplot2::geom_line( - mapping = ggplot2::aes(colour = !!sym("color_breaks")), - linewidth = ..get_plot_theme_linewidth(ggtheme = ggtheme) * 3) - - } else { - # For backward compatibility with ggplot2 versions prior to 3.4.0 - p <- p + ggplot2::geom_line( - mapping = ggplot2::aes(colour = !!sym("color_breaks")), - size = ..get_plot_theme_linewidth(ggtheme = ggtheme) * 3) - } + # Add line for individual data points. + p <- p + ggplot2::geom_line( + mapping = ggplot2::aes(colour = !!sym("color_breaks")), + linewidth = ..get_plot_theme_linewidth(ggtheme = ggtheme) * 3.0 + ) } - # Add fit if (!is_empty(fit_guide_list$data)) { p <- p + ggplot2::geom_abline( @@ -943,7 +966,9 @@ setMethod( mapping = ggplot2::aes( colour = !!sym("color_breaks"), intercept = !!sym("offset"), - slope = !!sym("slope"))) + slope = !!sym("slope") + ) + ) } # Set colour. @@ -951,33 +976,25 @@ setMethod( name = legend_label$guide_color, values = x_guide_list$guide_color$color_values, breaks = x_guide_list$guide_color$color_breaks, - drop = FALSE) + drop = FALSE + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = x_guide_list$guide_color$color_values, breaks = x_guide_list$guide_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } else { if (is_point) { p <- p + ggplot2::geom_point() } else { - if (utils::packageVersion("ggplot2") >= "3.4.0") { - # Version 3.4.0 introduces the linewidth element for geom_line, and will - # produce deprecation warnings if the size argument is used instead. - - # Add scatter for individual data points. - p <- p + ggplot2::geom_line( - linewidth = ..get_plot_theme_linewidth(ggtheme = ggtheme) * 3) - - } else { - # For backward compatibility with ggplot2 versions prior to version - # 3.4.0. - p <- p + ggplot2::geom_line( - size = ..get_plot_theme_linewidth(ggtheme = ggtheme) * 3) - } + # Add scatter for individual data points. + p <- p + ggplot2::geom_line( + linewidth = ..get_plot_theme_linewidth(ggtheme = ggtheme) * 3.0 + ) } # Add fit @@ -986,54 +1003,66 @@ setMethod( data = fit_guide_list$data, mapping = ggplot2::aes( intercept = !!sym("offset"), - slope = !!sym("slope"))) + slope = !!sym("slope") + ) + ) } } # Plot confidence intervals - if (conf_int_style[1] != "none") { - if (conf_int_style[1] == "step") { + if (conf_int_style[1L] != "none") { + if (conf_int_style[1L] == "step") { if (is.null(color_by)) { p <- p + ggplot2::geom_step( mapping = ggplot2::aes(y = !!sym("ci_low")), - linetype = "dashed") + linetype = "dashed" + ) p <- p + ggplot2::geom_step( mapping = ggplot2::aes(y = !!sym("ci_up")), - linetype = "dashed") + linetype = "dashed" + ) } else { p <- p + ggplot2::geom_step( mapping = ggplot2::aes( y = !!sym("ci_low"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) p <- p + ggplot2::geom_step( mapping = ggplot2::aes( y = !!sym("ci_up"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) } # Remove linetype from the legend. - p <- p + ggplot2::scale_linetype(guide = FALSE) + p <- p + ggplot2::scale_linetype(guide = "none") - } else if (conf_int_style[1] == "ribbon") { + } else if (conf_int_style[1L] == "ribbon") { if (is.null(color_by)) { p <- p + ggplot2::geom_ribbon( mapping = ggplot2::aes( ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), - alpha = conf_int_alpha) + ymax = !!sym("ci_up") + ), + alpha = conf_int_alpha + ) } else { p <- p + ggplot2::geom_ribbon( mapping = ggplot2::aes( ymin = !!sym("ci_low"), ymax = !!sym("ci_up"), - fill = !!sym("color_breaks")), - alpha = conf_int_alpha) + fill = !!sym("color_breaks") + ), + alpha = conf_int_alpha + ) } } } @@ -1046,7 +1075,8 @@ setMethod( facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -1054,20 +1084,24 @@ setMethod( p <- p + ggplot2::facet_grid( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, - labeller = "label_context") + labeller = "label_context" + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, - labeller = "label_context") + labeller = "label_context" + ) } } # Annotate calibration information. - if ((show_calibration_fit && !is_empty(linear_test)) || - (show_goodness_of_fit && !is_empty(gof_test))) { + if ( + (show_calibration_fit && !is_empty(linear_test)) || + (show_goodness_of_fit && !is_empty(gof_test)) + ) { # Merge test data - label <- character(0) + label <- character(0L) if (show_calibration_fit && !is_empty(linear_test)) { # Add calibration-in-the-large. @@ -1076,40 +1110,48 @@ setMethod( label, paste0( "intercept: ", - format(round(linear_test[type == "offset"]$value, 2), nsmall = 2), + format(round(linear_test[type == "offset"]$value, 2L), nsmall = 2L), " (", - format(round(linear_test[type == "offset"]$ci_low, 2), nsmall = 2), + format(round(linear_test[type == "offset"]$ci_low, 2L), nsmall = 2L), "\u2013", - ifelse(round(linear_test[type == "offset"]$ci_up, 2) < 0, " ", ""), - format(round(linear_test[type == "offset"]$ci_up, 2), nsmall = 2), - ")")) + ifelse(round(linear_test[type == "offset"]$ci_up, 2L) < 0.0, " ", ""), + format(round(linear_test[type == "offset"]$ci_up, 2L), nsmall = 2L), + ")" + ) + ) # Add calibration slope. label <- c( label, paste0( "slope: ", - format(round(linear_test[type == "slope"]$value, 2), nsmall = 2), + format(round(linear_test[type == "slope"]$value, 2L), nsmall = 2L), " (", - format(round(linear_test[type == "slope"]$ci_low, 2), nsmall = 2), + format(round(linear_test[type == "slope"]$ci_low, 2L), nsmall = 2L), "\u2013", - ifelse(round(linear_test[type == "slope"]$ci_up, 2) < 0, " ", ""), - format(round(linear_test[type == "slope"]$ci_up, 2), nsmall = 2), - ")")) + ifelse(round(linear_test[type == "slope"]$ci_up, 2L) < 0.0, " ", ""), + format(round(linear_test[type == "slope"]$ci_up, 2L), nsmall = 2L), + ")" + ) + ) } else { label <- c( label, paste0( "intercept: ", - format(round(linear_test[type == "offset"]$value, 2), nsmall = 2))) + format(round(linear_test[type == "offset"]$value, 2L), nsmall = 2L) + ) + ) # Add calibration slope. label <- c( label, paste0( "slope: ", - format(round(linear_test[type == "slope"]$value, 2), nsmall = 2))) + format(round(linear_test[type == "slope"]$value, 2L), nsmall = 2L) + ) + ) } } @@ -1120,7 +1162,9 @@ setMethod( label, paste0( "HL-test p: ", - format(signif(gof_test[type == "hosmer_lemeshow"]$p_value, 2), nsmall = 2))) + format(signif(gof_test[type == "hosmer_lemeshow"]$p_value, 2L), nsmall = 2L) + ) + ) } # Nam-D'Agostino test @@ -1129,7 +1173,9 @@ setMethod( label, paste0( "ND-test p: ", - format(signif(gof_test[type == "nam_dagostino"]$p_value, 2), nsmall = 2))) + format(signif(gof_test[type == "nam_dagostino"]$p_value, 2L), nsmall = 2L) + ) + ) } # Greenwood-Nam-D'Agostino test @@ -1138,12 +1184,14 @@ setMethod( label, paste0( "GND-test p: ", - format(signif(gof_test[type == "greenwood_nam_dagostino"]$p_value, 2), nsmall = 2))) + format(signif(gof_test[type == "greenwood_nam_dagostino"]$p_value, 2L), nsmall = 2L) + ) + ) } } # Combine all label elements, and use for annotation - if (length(label) > 0) { + if (length(label) > 0L) { label <- paste(label, collapse = "\n") # Obtain default settings. @@ -1152,15 +1200,16 @@ setMethod( # Show in plot p <- p + ggplot2::annotate( "text", - x = x_range[1], - y = y_range[2], + x = x_range[1L], + y = y_range[2L], label = label, colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, size = text_settings$geom_text_size, vjust = "inward", - hjust = "inward") + hjust = "inward" + ) } } @@ -1170,12 +1219,11 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Prevent clipping of confidence intervals. - p <- p + ggplot2::coord_cartesian( - xlim = x_range, - ylim = y_range) + p <- p + ggplot2::coord_cartesian(xlim = x_range, ylim = y_range) return(p) } @@ -1188,18 +1236,22 @@ setMethod( x_range, x_breaks, flip = FALSE, - plot_height) { + plot_height +) { # Create plot p <- ggplot2::ggplot( data = x, mapping = ggplot2::aes( x = !!sym("expected"), - weight = !!sym("frequency"))) + weight = !!sym("frequency") + ) + ) p <- p + ggplot2::geom_density(bw = 0.075) p <- p + ggplot2::scale_x_continuous( breaks = x_breaks, - limits = x_range) + limits = x_range + ) # Set main theme p <- p + ggtheme @@ -1215,7 +1267,8 @@ setMethod( axis.text.y = ggplot2::element_blank(), axis.ticks.x = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank()) + axis.title.y = ggplot2::element_blank() + ) if (flip) { p <- p + ggplot2::scale_y_reverse() @@ -1234,22 +1287,24 @@ setMethod( x, facet_by, facet_wrap_cols, - show_density) { + show_density +) { # Obtain facetting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Set default height and width for each subplot (in cm). - default_width <- 6 - default_height <- ifelse(show_density, 6, 5.5) + default_width <- 6.0 + default_height <- ifelse(show_density, 6.0, 5.5) # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } diff --git a/R/PlotColours.R b/R/PlotColours.R index 9d6a6241..747de8e9 100644 --- a/R/PlotColours.R +++ b/R/PlotColours.R @@ -1,10 +1,12 @@ .get_palette <- function( x = NULL, palette_type, - n = 5, + n = NULL, invert = FALSE, use_alternative = FALSE, - diverge_to_white = FALSE) { + diverge_to_white = TRUE +) { + # Check whether the provided palette is known, a set of colours, or a default. if (is.null(x)) { colours <- .get_default_palette( @@ -12,35 +14,48 @@ palette_type = palette_type, invert = invert, use_alternative = use_alternative, - diverge_to_white = diverge_to_white) + diverge_to_white = diverge_to_white + ) } else if (all(is.character(x))) { - if (length(x) > 1) { + if (length(x) > 1L) { # Check that all elements are colours. valid_colours <- sapply(x, .is_colour) - if (any(!valid_colours)) { - stop(paste0( + if (!all(valid_colours)) { + ..error(paste0( "The following palette colours could not be interpreted: ", paste_s(x[!valid_colours]), " . A valid colour is either a hexadecimal string (e.g. \"#4F94CD\"), ", "a colour specified in grDevices::colors() (e.g. \"steelblue3\"), ", - "or \"transparant\". Alternatively, a palette can be specified by name.")) + "or \"transparant\". Alternatively, a palette can be specified by name." + )) } colours <- x - } else if (length(x) == 1) { + } else if (length(x) == 1L) { + if (palette_type %in% c("divergent", "sequential") && is.null(n)) { + # Set n if unspecified. + n <- 31L + + } else if (palette_type == "qualitative" && is.null(n)) { + # In case of qualitative palettes, n should be set explicitly by familiar. + ..error_reached_unreachable_code("Qualitative palettes requires the number of discrete cases n.") + } + # Obtain colours from a predefined palette. colours <- .palette_to_colour( x = x, - n = n) + n = n + ) } } else { - stop(paste0( + ..error(paste0( "The requested palette are neither colours nor a palette: ", - paste0(x, collapse = ", "))) + paste_s(x) + )) } return(colours) @@ -49,32 +64,74 @@ .is_colour <- function(x) { - return(x %in% grDevices::colors() || - x == "transparant" || - grepl(pattern = "^#(\\d|[a-f]){6,8}$", x, ignore.case = TRUE)) + return( + x %in% grDevices::colors() || + x == "transparant" || + grepl(pattern = "^#(\\d|[a-f]){6,8}$", x, ignore.case = TRUE) + ) } -.palette_to_colour <- function(x, n = 5) { +.palette_to_colour <- function(x, n) { # Determine if the string ends with _, _r or _rev. invert_colours <- grepl(pattern = "_$|_r$|_rev$", x, ignore.case = TRUE) # Strip from x x <- gsub(pattern = "_$|_r$|_rev$", replacement = "", x) + colours <- NULL + # Try paletteer. + if (rlang::is_installed("paletteer")) { + # Continuous palette + colours <- tryCatch( + paletteer::paletteer_c( + palette = x, + n = n + ), + error = function(err) (NULL) + ) + + # Dynamic palette + if (is.null(colours)) { + colours <- tryCatch( + paletteer::paletteer_dynamic( + palette = x, + n = n + ), + error = function(err) (NULL) + ) + } + + # Discrete palette + if (is.null(colours)) { + colours <- tryCatch( + paletteer::paletteer_d( + palette = x, + n = n + ), + error = function(err) (NULL) + ) + } + } + # Try grDevices::palette (requires R version >= 4.0.0) - colours <- tryCatch( - grDevices::palette.colors(n = n, palette = x), - error = function(err) (NULL)) + if (is.null(colours)) { + colours <- tryCatch( + grDevices::palette.colors(n = n, palette = x), + error = function(err) (NULL) + ) + } # Try grDevices::hcl.colors (requires R version >= 3.6.0) if (is.null(colours)) { colours <- tryCatch( grDevices::hcl.colors(n = n, palette = x), - error = function(err) (NULL)) + error = function(err) (NULL) + ) } - + + # Palettes that are always available. if (is.null(colours)) { if (x == "default") { @@ -93,15 +150,14 @@ } if (is.null(colours)) { - stop(paste0( + ..error(paste0( "The palette was not recognised: ", x, ". Please check the spelling. Note that some options may not be available prior ", - "to R 4.0.0 (grDevices::palette.pals(), and R 3.6.0 (grDevices::hcl.pals())).")) + "to R 4.0.0 (grDevices::palette.pals(), and R 3.6.0 (grDevices::hcl.pals()))." + )) } - if (invert_colours) { - colours <- rev(colours) - } + if (invert_colours) colours <- rev(colours) return(colours) } @@ -112,143 +168,117 @@ palette_type, invert, use_alternative = FALSE, - diverge_to_white = FALSE) { + diverge_to_white = TRUE +) { .check_parameter_value_is_valid( x = palette_type, var_name = "palette_type", - values = c("qualitative", "sequential", "divergent")) + values = c("qualitative", "sequential", "divergent") + ) if (palette_type == "qualitative") { - # Default qualitative palettes are based on the Tableau 10 palette by - # Maureen Stone, Cristy Miller and Jeffrey Heer. + # Palette derived from: + # + # colorspace::diverge_hcl(n = 21, h = c(245, 35), c = c(130, 85), l = c(65, + # 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) # - # * Maureen Stone, Designing Colors for Data, International Symposium on - # Computational Aesthetics in Graphics, Visualization, and Imaging, Banff, - # AB, Canada, June 22, 2007. + # colorspace::diverge_hcl(n = 21, h = c(185, 10), c = c(130, 85), l = c(60, + # 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) # - # * Jeffrey Heer and Maureen Stone, Color Naming Models for Color Selection, - # Image Editing and Palette Design, ACM Human Factors in Computing Systems, - # 2012. + # colorspace::diverge_hcl(n = 21, h = c(65, 125), c = c(100, 85), l = c(70, + # 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) # - # * https://www.tableau.com/about/blog/2016/7/colors-upgrade-tableau-10-56782 - # + # colorspace::diverge_hcl(n = 21, h = c(210, 320), c = c(60, 85), l = c(60, + # 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) + # + # colorspace::diverge_hcl(n = 21, h = c(100, 0), c = c(50, 85), l = c(70, + # 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) + + palette_10 <- c( + "#00A8FF", + "#F77D00", + "#00BCAB", + "#FE535E", + "#D4A600", + "#40C41C", + "#00A2B7", + "#C973B6", + "#9FB368", + "#E495A5" + ) + + palette_20 <- c( + "#00A8FF", + "#93BDF0", + "#F77D00", + "#E9AD8D", + "#00BCAB", + "#96C9C5", + "#FE535E", + "#DFB6B7", + "#D4A600", + "#CEC2AC", + "#40C41C", + "#B2C9B0", + "#00A2B7", + "#8AC4D1", + "#C973B6", + "#DCADD0", + "#9FB368", + "#B3C680", + "#E495A5", + "#ECB1BC" + ) + if (!use_alternative) { - if (n <= 10) { - colours <- c( - "#4e79a7", - "#f28e2b", - "#e15759", - "#76b7b2", - "#59a14f", - "#edc948", - "#b07aa1", - "#ff9da7", - "#9c755f", - "#bab0ac" - )[1:n] + if (n <= 10L) { + colours <- palette_10[1L:n] - } else if (n <= 20) { - colours <- c( - "#4e79a7", - "#a0cbe8", - "#f28e2b", - "#ffbe7d", - "#59a14f", - "#8cd17d", - "#b6992d", - "#f1ce63", - "#499894", - "#86bcb6", - "#e15759", - "#ff9d9a", - "#79706e", - "#bab0ac", - "#d37295", - "#fabfd2", - "#b07aa1", - "#d4a6c8", - "#9d7660", - "#d7b5a6" - )[1:n] + } else if (n <= 20L) { + colours <- palette_20[1L:n] } else { - stop(paste0( + ..error(paste0( "The required number (", n, ") of discrete colors is too large for the ", - "default qualitative score (max 20). ")) + "default qualitative score (max 20). " + )) } } else { # Alternative colour schemes were the blue and orange colours come last. # This is to avoid confusion with other gradients that may be used in the # plot. - if (n <= 10) { - colours <- c( - "#e15759", - "#76b7b2", - "#59a14f", - "#edc948", - "#b07aa1", - "#ff9da7", - "#9c755f", - "#bab0ac", - "#4e79a7", - "#f28e2b" - )[1:n] + if (n <= 10L) { + colours <- rev(palette_10)[1L:n] - } else if (n <= 20) { - colours <- c( - "#59a14f", - "#8cd17d", - "#b6992d", - "#f1ce63", - "#499894", - "#86bcb6", - "#e15759", - "#ff9d9a", - "#79706e", - "#bab0ac", - "#d37295", - "#fabfd2", - "#b07aa1", - "#d4a6c8", - "#9d7660", - "#d7b5a6", - "#4e79a7", - "#a0cbe8", - "#f28e2b", - "#ffbe7d" - )[1:n] + } else if (n <= 20L) { + colours <- rev(palette_20)[1L:n] } else { - stop(paste0( + ..error(paste0( "The required number (", n, ") of discrete colors is too large for ", - "the default qualitative score (max 20). ")) + "the default qualitative score (max 20). " + )) } } } else if (palette_type == "sequential") { if (!use_alternative) { # A palette with the same hue (blue) as the first color of the qualitative - # palette. Based on an advanced single-hue sequential palette created - # using colorspace::hcl_wizard, with Hue 1=245, Chroma 1 = 15, Max Chroma - # = 75, Lumin. 1 = 20, Lumin 2 = 98, Power 1 = 0.8, Power 2 = 1.4, without - # color correction. + # palette. Based on the blue part of colorspace::diverge_hcl(n = 21, h = + # c(245, 35), c = c(130, 85), l = c(65, 80), power = c(1, 1.3), gamma = + # NULL, fixup = TRUE) colours <- c( - "#233143", "#243950", "#26415D", "#27496A", "#285177", "#295A85", - "#296393", "#2A6CA2", "#2A76B1", "#297FC0", "#2D89CF", "#4D93D2", - "#649CD6", "#79A7DA", "#8CB1DF", "#9FBDE3", "#B2C9E8", "#C6D6ED", - "#DCE5F2", "#F9F9F9" + "#C6C6C6", "#BCC5D2", "#B0C3DD", "#A3C0E7", "#93BDF0", "#81BAF8", + "#6AB7FF", "#49B3FF", "#00B0FF", "#00ACFF", "#00A8FF" ) + } else { # Alternative reddish colour scheme that avoids the use of blues and - # orange tones that may have been used as a primary palette. Based on an - # advanced single-hue sequential palette created using - # colorspace::hcl_wizard, with Hue=12, Chroma 1 = 40, Max Chroma = 120, - # Lumin. 1 = 20, Lumin 2 = 98, Power 1 = 0.8, Power 2 = 1.4, without color - # correction. + # orange tones that may have been used as a primary palette. Based on the + # red part of colorspace::diverge_hcl(n = 21, h = c(185, 10), c = c(130, + # 85), l = c(60, 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) colours <- c( - "#581B1C", "#661F1F", "#732323", "#812727", "#8F2B2C", "#9E2F30", - "#AC3434", "#BC3839", "#CC3D3E", "#DC4243", "#E25354", "#E76364", - "#EC7374", "#F18383", "#F59394", "#F8A4A4", "#FBB5B6", "#FCC8C8", - "#FCDDDD", "#F9F9F9" + "#C6C6C6", "#D4BFBF", "#DFB6B7", "#E8ACAE", "#EFA1A4", "#F5969A", + "#F98A8F", "#FC7E84", "#FE7178", "#FE636C", "#FE535E" ) } @@ -256,71 +286,62 @@ } else if (palette_type == "divergent") { if (!use_alternative) { - # A palette with the same hues (blue and orange) as the first two colors of - # the qualitative palette. Based on a combination of two advanced single-hue - # sequential palettes created using colorspace::hcl_wizard: - # - # Blues: Hue 1=245, Chroma 1 = 15, Max Chroma = 75, Lumin. 1 = 20, Lumin 2 = - # 98, Power 1 = 0.8, Power 2 = 1.4, without color correction. Oranges: Hue - # 1=36, Chroma 1 = 20, Max Chroma = 100, Lumin. 1 = 35, Lumin 2 = 98, Power - # 1 = 0.8, Power 2 = 1.4, without color correction, in reverse order. - if (!diverge_to_white) { - # Centre colour is white. + # A palette with the same hues (blue and orange) as the first two colors + # of the qualitative palette. + if (diverge_to_white) { + # Bright center. + # + # colorspace::diverge_hcl(n = 21, h = c(245, 35), c = c(130, 85), l = + # c(65, 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) colours <- c( - "#233143", "#243950", "#26415D", "#27496A", "#285177", "#295A85", - "#296393", "#2A6CA2", "#2A76B1", "#297FC0", "#2D89CF", "#4D93D2", - "#649CD6", "#79A7DA", "#8CB1DF", "#9FBDE3", "#B2C9E8", "#C6D6ED", "#DCE5F2", - "#F9F9F9", - "#FAE4DA", "#F9D4C3", "#F8C6AE", "#F5B999", "#F2AD85", "#EFA170", - "#EB965A", "#E78C40", "#E28118", "#D67B1E", "#C87528", "#BC702F", - "#AF6A34", "#A36537", "#96603A", "#8A5B3C", "#7E563E", "#725240", "#664D41" + "#00A8FF", "#00ACFF", "#00B0FF", "#49B3FF", "#6AB7FF", "#81BAF8", + "#93BDF0", "#A3C0E7", "#B0C3DD", "#BCC5D2", + "#C6C6C6", + "#D2C1BA", "#DBBBAC", "#E3B49D", "#E9AD8D", "#EEA57C", "#F29D68", + "#F49650", "#F68E2F", "#F78600", "#F77D00" ) + } else { - # Centre colour is dark. + # Dark centre. + # + # colorspace::diverge_hcl(n = 21, h = c(245, 35), c = c(130, 85), l = + # c(65, 30), power = c(1, 1.3), gamma = NULL, fixup = TRUE) colours <- c( - "#FAE4DA", "#F9D4C3", "#F8C6AE", "#F5B999", "#F2AD85", "#EFA170", - "#EB965A", "#E78C40", "#E28118", "#D67B1E", "#C87528", "#BC702F", - "#AF6A34", "#A36537", "#96603A", "#8A5B3C", "#7E563E", "#725240", "#664D41", - "#050505", - "#233143", "#243950", "#26415D", "#27496A", "#285177", "#295A85", - "#296393", "#2A6CA2", "#2A76B1", "#297FC0", "#2D89CF", "#4D93D2", - "#649CD6", "#79A7DA", "#8CB1DF", "#9FBDE3", "#B2C9E8", "#C6D6ED", "#DCE5F2" + "#00A8FF", "#009BFF", "#008FEF", "#0083D8", "#0078C1", "#056DAB", + "#266495", "#345B81", "#3C526D", "#424C59", + "#474747", + "#584740", "#694A39", "#794E32", "#8A522A", "#9A581E", "#AC5E07", + "#BE6500", "#D06D00", "#E37500" ,"#F77D00" ) } + } else { # A palette based on the same hues the first two colours of the - # alternative qualitative palette. Based on a combination of two advanced - # single-hue sequential palettes created using colorspace::hcl_wizard: - # - # Reds: Hue=12, Chroma 1 = 40, Max Chroma = 120, Lumin. 1 = 20, Lumin 2 = - # 98, Power 1 = 0.8, Power 2 = 1.4, without color correction. Cyan: - # Hue=185, Chroma 1 = 0, Max Chroma = 55, Lumin. 1 = 40, Lumin 2 = 98, - # Power 1 = 1.0, Power 2 = 1.4, without color correction. - if (!diverge_to_white) { - # Centre colour is white. + # alternative qualitative palette. + if (diverge_to_white) { + # Bright centre. + # + # colorspace::diverge_hcl(n = 21, h = c(185, 10), c = c(130, 85), l = + # c(60, 80), power = c(1, 1.3), gamma = NULL, fixup = TRUE) colours <- c( - "#581B1C", "#661F1F", "#732323", "#812727", "#8F2B2C", "#9E2F30", - "#AC3434", "#BC3839", "#CC3D3E", "#DC4243", "#E25354", "#E76364", - "#EC7374", "#F18383", "#F59394", "#F8A4A4", "#FBB5B6", "#FCC8C8", "#FCDDDD", - "#F9F9F9", - "#E8F3F2", "#D7ECEA", "#C5E6E3", "#B2DFDC", "#9FD9D4", "#8AD3CD", - "#72CCC6", "#56C6BF", "#2DC0B8", "#16B7B0", "#30ADA6", "#3EA39D", - "#489994", "#4F8F8B", "#548582", "#587B79", "#5B7270", "#5D6867", "#5E5E5E" + "#00BCAB", "#00BFAF", "#00C2B4", "#00C4B7", "#00C6BB", "#00C8BE", + "#40C9C1", "#74C9C3", "#96C9C5", "#B0C9C6", + "#C6C6C6", + "#D4BFBF", "#DFB6B7", "#E8ACAE", "#EFA1A4", "#F5969A", "#F98A8F", + "#FC7E84", "#FE7178", "#FE636C", "#FE535E" ) + } else { - # Centre colour is black. + # Dark centre. + # + # colorspace::diverge_hcl(n = 21, h = c(185, 10), c = c(130, 85), l = + # c(60, 30), power = c(1, 1.3), gamma = NULL, fixup = TRUE) colours <- c( - rev(c( - "#E8F3F2", "#D7ECEA", "#C5E6E3", "#B2DFDC", "#9FD9D4", "#8AD3CD", - "#72CCC6", "#56C6BF", "#2DC0B8", "#16B7B0", "#30ADA6", "#3EA39D", - "#489994", "#4F8F8B", "#548582", "#587B79", "#5B7270", "#5D6867", "#5E5E5E" - )), - "#050505", - rev(c( - "#581B1C", "#661F1F", "#732323", "#812727", "#8F2B2C", "#9E2F30", - "#AC3434", "#BC3839", "#CC3D3E", "#DC4243", "#E25354", "#E76364", - "#EC7374", "#F18383", "#F59394", "#F8A4A4", "#FBB5B6", "#FCC8C8", "#FCDDDD" - )) + "#00BCAB", "#00AE9F", "#00A093", "#009387", "#00877C", "#007A71", + "#006F67", "#00645E", "#065955", "#334F4D", + "#474747", + "#5A4546", "#6D4446", "#7E4547", "#904649", "#A1474C", "#B3494F", + "#C54B52", "#D74D56", "#EB505A", "#FE535E" ) } } diff --git a/R/PlotConfusionMatrix.R b/R/PlotConfusionMatrix.R index 0c1e679a..acf9dd6d 100644 --- a/R/PlotConfusionMatrix.R +++ b/R/PlotConfusionMatrix.R @@ -13,9 +13,16 @@ NULL #' @param dir_path (*optional*) Path to the directory where created confusion #' matrixes are saved to. Output is saved in the `performance` subdirectory. #' If `NULL` no figures are saved, but are returned instead. -#' @param discrete_palette (*optional*) Palette used to colour the confusion -#' matrix. The colour depends on whether each cell of the confusion matrix is -#' on the diagonal (observed outcome matched expected outcome) or not. +#' @param discrete_palette (*optional*) Palette Palette for colouring the cells +#' of the confusion matrix. The colour depends on whether each cell of the +#' confusion matrix is on the diagonal (observed outcome matched expected +#' outcome) or not. `familiar` has a default palette. Other palettes are +#' supported by the `paletteer` package, `grDevices::palette.pals()` (requires +#' R >= 4.0.0), `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, +#' `heat.colors`, `terrain.colors`, `topo.colors` and `cm.colors`, which +#' correspond to the palettes of the same name in `grDevices`. You may also +#' specify your own palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param show_alpha (*optional*) Interpreting confusion matrices is made easier #' by setting the opacity of the cells. `show_alpha` takes the following #' values: @@ -48,19 +55,11 @@ NULL #' #' @details This function generates area under the ROC curve plots. #' -#' Available splitting variables are: `fs_method`, `learner` and `data_set`. -#' By default, the data is split by `fs_method` and `learner`, with facetting +#' Available splitting variables are: `vimp_method`, `learner` and `data_set`. +#' By default, the data is split by `vimp_method` and `learner`, with facetting #' by `data_set`. #' -#' Available palettes for `discrete_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. -#' -#' Labeling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labelling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -92,7 +91,8 @@ setGeneric( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_confusion_matrix") } ) @@ -126,15 +126,19 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "confusion_matrix"), - list(...))) + "data_element" = "confusion_matrix" + ), + list(...) + ) + ) return(do.call( plot_confusion_matrix, @@ -158,7 +162,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -190,7 +196,8 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table observed_outcome <- expected_outcome <- count <- class_matches <- total_observed <- NULL @@ -207,13 +214,14 @@ setMethod( if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) { + if (length(x) > 1L) { ..error_reached_unreachable_code( - "plot_model_performance: list of data elements contains unmerged elements.") + "plot_model_performance: list of data elements contains unmerged elements." + ) } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -223,7 +231,8 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = FALSE), purpose = "to plot confusion matrices", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -242,7 +251,7 @@ setMethod( # x_label if (is.waive(x_label)) { x_label <- "expected" - if (length(outcome_name) > 0) { + if (length(outcome_name) > 0L) { x_label <- paste(x_label, outcome_name, sep = " ") } } @@ -250,7 +259,7 @@ setMethod( # y_label if (is.waive(y_label)) { y_label <- "observed" - if (length(outcome_name) > 0) { + if (length(outcome_name) > 0L) { y_label <- paste(y_label, outcome_name, sep = " ") } } @@ -263,11 +272,12 @@ setMethod( .check_parameter_value_is_valid( x = show_alpha, var_name = "show_alpha", - values = c("none", "by_class", "by_matrix", "by_figure", "by_all")) + values = c("none", "by_class", "by_matrix", "by_figure", "by_all") + ) # Splitting variables if (is.null(split_by) && is.null(facet_by)) { - split_by <- c("fs_method", "learner") + split_by <- c("vimp_method", "learner") facet_by <- c("data_set") } @@ -276,7 +286,8 @@ setMethod( x = x@data, split_by = split_by, facet_by = facet_by, - available = c("fs_method", "learner", "data_set")) + available = c("vimp_method", "learner", "data_set") + ) # Update splitting variables split_by <- split_var_list$split_by @@ -294,7 +305,8 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Add a class_matches column x@data[, "class_matches" := observed_outcome == expected_outcome] @@ -307,16 +319,18 @@ setMethod( # Determine the alpha level (opacity) of the fills in the confusion # matrix. This is determined by the number of instances of observed # classes. - max_observations <- x@data[, list( - "total_observed" = sum(count)), - by = c("observed_outcome", facet_by, split_by)] + max_observations <- x@data[ + , + list("total_observed" = sum(count)), + by = c("observed_outcome", facet_by, split_by) + ] if (show_alpha == "by_class") { # Nothing extra needed } else if (show_alpha == "by_matrix") { # Find the maximum observations in each facet and split, i.e. normalise # per matrix. - if (!is.null(facet_by) | !is.null(split_by)) { + if (!is.null(facet_by) || !is.null(split_by)) { max_observations[, "total_observed" := max(total_observed), by = c(facet_by, split_by)] } } else if (show_alpha == "by_figure") { @@ -336,13 +350,13 @@ setMethod( x@data <- merge( x = x@data, y = max_observations, - by = c("observed_outcome", facet_by, split_by)) + by = c("observed_outcome", facet_by, split_by) + ) x@data[, "alpha" := count / total_observed] } - # Create plots ------------------------------------------------------------- # Determine if subtitle should be generated. @@ -368,7 +382,8 @@ setMethod( if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, - x = x_split[[ii]]) + x = x_split[[ii]] + ) } # Generate plot @@ -384,7 +399,8 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Check empty output if (is.null(p)) next @@ -400,7 +416,8 @@ setMethod( class_levels = get_outcome_class_levels(object), facet_by = facet_by, facet_wrap_cols = facet_wrap_cols, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Save to file. do.call( @@ -414,10 +431,13 @@ setMethod( "subtype" = "confusion_matrix", "x" = x_split[[ii]], "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list for export. @@ -430,7 +450,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -448,12 +469,14 @@ setMethod( plot_title, plot_sub_title, caption, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Find the colours discrete_colours <- .get_palette( x = discrete_palette, palette_type = "qualitative", - n = 2) + n = 2L + ) # Create basic plot p <- ggplot2::ggplot( @@ -462,7 +485,9 @@ setMethod( x = !!sym("expected_outcome"), y = !!sym("observed_outcome"), fill = !!sym("class_matches"), - alpha = !!sym("alpha"))) + alpha = !!sym("alpha") + ) + ) # Add theme p <- p + ggtheme @@ -474,12 +499,14 @@ setMethod( p <- p + ggplot2::scale_fill_manual( values = discrete_colours, breaks = c(FALSE, TRUE), - drop = FALSE) + drop = FALSE + ) # Set alpha scale. p <- p + ggplot2::scale_alpha_continuous( range = c(0.0, 1.0), - limits = c(0.0, 1.0)) + limits = c(0.0, 1.0) + ) # Labels p <- p + ggplot2::labs( @@ -487,7 +514,8 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Obtain default settings. text_settings <- .get_plot_geom_text_settings(ggtheme = ggtheme) @@ -499,17 +527,20 @@ setMethod( x = !!sym("expected_outcome"), y = !!sym("observed_outcome"), label = !!sym("count"), - alpha = 1.0), + alpha = 1.0 + ), colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, - size = text_settings$geom_text_size) + size = text_settings$geom_text_size + ) # Determine how things are facetted facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -518,13 +549,15 @@ setMethod( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } } @@ -534,7 +567,9 @@ setMethod( axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } # Suppress legends @@ -550,7 +585,8 @@ setMethod( class_levels, facet_by, facet_wrap_cols, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Determine the number of elements along the x-axis. n_elements <- length(class_levels) longest_element <- max(sapply(class_levels, nchar)) @@ -573,14 +609,15 @@ setMethod( plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * (default_height) + x_tick_space, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * (default_height) + x_tick_space, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm). We leave some # room for the legend on the right. - width <- min(c(2 + plot_dims[2] * (default_width) + y_tick_space, 19)) + width <- min(c(2.0 + plot_dims[2L] * (default_width) + y_tick_space, 19.0)) return(c(height, width)) } diff --git a/R/PlotDecisionCurves.R b/R/PlotDecisionCurves.R index 0090ee39..6813b52f 100644 --- a/R/PlotDecisionCurves.R +++ b/R/PlotDecisionCurves.R @@ -15,8 +15,6 @@ NULL #' curve plots are saved to. Output is saved in the `decision_curve_analysis` #' subdirectory. If `NULL`, figures are written to the folder, but are #' returned instead. -#' @param discrete_palette (*optional*) Palette to use to color the different -#' plot elements in case a value was provided to the `color_by` argument. #' #' @inheritParams as_familiar_collection #' @inheritParams plot_univariate_importance @@ -28,20 +26,12 @@ NULL #' #' @details This function generates plots for decision curves. #' -#' Available splitting variables are: `fs_method`, `learner`, `data_set` and +#' Available splitting variables are: `vimp_method`, `learner`, `data_set` and #' `positive_class` (categorical outcomes) or `evaluation_time` (survival -#' outcomes). By default, the data is split by `fs_method` and `learner`, with +#' outcomes). By default, the data is split by `vimp_method` and `learner`, with #' faceting by `data_set` and colouring by `positive_class` or #' `evaluation_time`. #' -#' Available palettes for `discrete_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. -#' #' Bootstrap confidence intervals of the decision curve (if present) can be #' shown using various styles set by `conf_int_style`: #' @@ -55,7 +45,7 @@ NULL #' * `none`: confidence intervals are not shown. The point estimate of the #' decision curve is shown as usual. #' -#' Labelling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labelling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -94,18 +84,19 @@ setGeneric( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_decision_curve") } ) @@ -135,26 +126,30 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "decision_curve_analyis"), - list(...))) + "data_element" = "decision_curve_analyis" + ), + list(...) + ) + ) return(do.call( plot_decision_curve, @@ -185,7 +180,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -214,18 +211,19 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table curve_type <- ci_low <- ci_up <- net_benefit <- NULL @@ -235,7 +233,8 @@ setMethod( # Get input data. x <- export_decision_curve_analysis_data( object = object, - aggregate_results = TRUE) + aggregate_results = TRUE + ) # Check that the data are not empty. if (is_empty(x)) return(NULL) @@ -250,13 +249,14 @@ setMethod( if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) { + if (length(x) > 1L) { ..error_reached_unreachable_code( - "plot_decision_curve: list of data elements contains unmerged elements.") + "plot_decision_curve: list of data elements contains unmerged elements." + ) } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -266,7 +266,8 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = FALSE), purpose = "to plot decision curves", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -291,14 +292,15 @@ setMethod( # Create breaks x_breaks <- labeling::extended( m = x_n_breaks, - dmin = x_range[1], - dmax = x_range[2], - only.loose = TRUE) + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) } # conf_int_style - if (length(conf_int_style) > 1) { - conf_int_style <- head(conf_int_style, n = 1) + if (length(conf_int_style) > 1L) { + conf_int_style <- head(conf_int_style, n = 1L) } # Set the style of the confidence interval to none, in case no confidence @@ -313,14 +315,15 @@ setMethod( # Base the y-range on the confidence intervals. y_range <- c( min(x@data[curve_type == "model" & is.finite(ci_low)]$ci_low), - max(x@data[curve_type == "model" & is.finite(ci_up)]$ci_up)) + max(x@data[curve_type == "model" & is.finite(ci_up)]$ci_up) + ) } else { # Base the y-range on the range of the benefit. y_range <- c( min(c(0.0, min(x@data[curve_type == "model" & is.finite(net_benefit)]$net_benefit))), - max(c(0.0, max(x@data[curve_type == "model" & is.finite(net_benefit)]$net_benefit)))) - + max(c(0.0, max(x@data[curve_type == "model" & is.finite(net_benefit)]$net_benefit))) + ) } } @@ -331,14 +334,16 @@ setMethod( # Create breaks y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) # Adapt the y-range. y_range <- c( - head(y_breaks, n = 1), - tail(y_breaks, n = 1)) + head(y_breaks, n = 1L), + tail(y_breaks, n = 1L) + ) } if (object@outcome_type %in% c("binomial", "multinomial")) { @@ -353,7 +358,7 @@ setMethod( if (is.null(split_by) && is.null(facet_by) && is.null(color_by)) { # Determine the number of learners and feature_selection methods. n_learner <- nlevels(x@data$learner) - n_fs_method <- nlevels(x@data$fs_method) + n_vimp_method <- nlevels(x@data$vimp_method) if (object@outcome_type %in% c("multinomial")) { n_class_or_time <- nlevels(x@data$positive_class) @@ -365,48 +370,48 @@ setMethod( ..error_outcome_type_not_implemented(object@outcome_type) } - if (n_learner > 1 && n_fs_method > 1) { + if (n_learner > 1L && n_vimp_method > 1L) { # Split by learner and feature selection method. - split_by <- c("fs_method", "learner") + split_by <- c("vimp_method", "learner") - if (n_class_or_time > 1) { + if (n_class_or_time > 1L) { color_by <- split_variable facet_by <- "data_set" } else { color_by <- c("data_set", split_variable) } - } else if (n_learner > 1) { - # Implying n_fs_method == 1 + } else if (n_learner > 1L) { + # Implying n_vimp_method == 1 - if (n_class_or_time > 1) { - split_by <- c("fs_method", "learner") + if (n_class_or_time > 1L) { + split_by <- c("vimp_method", "learner") color_by <- split_variable facet_by <- "data_set" } else { - split_by <- c("fs_method") + split_by <- c("vimp_method") color_by <- c("learner") facet_by <- c("data_set", split_variable) } - } else if (n_fs_method > 1) { + } else if (n_vimp_method > 1L) { # Implying n_learner == 1 - if (n_class_or_time > 1) { - split_by <- c("fs_method", "learner") + if (n_class_or_time > 1L) { + split_by <- c("vimp_method", "learner") color_by <- split_variable facet_by <- "data_set" } else { split_by <- "learner" - color_by <- "fs_method" + color_by <- "vimp_method" facet_by <- c("data_set", split_variable) } } else { - # Implying n_learner == n_fs_method == 1 - split_by <- c("fs_method", "learner") + # Implying n_learner == n_vimp_method == 1 + split_by <- c("vimp_method", "learner") - if (n_class_or_time > 1) { + if (n_class_or_time > 1L) { color_by <- split_variable facet_by <- "data_set" } else { @@ -421,7 +426,8 @@ setMethod( split_by = split_by, color_by = color_by, facet_by = facet_by, - available = c("fs_method", "learner", "data_set", split_variable)) + available = c("vimp_method", "learner", "data_set", split_variable) + ) # Update splitting variables split_by <- split_var_list$split_by @@ -431,7 +437,8 @@ setMethod( # Create a legend label legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) # Check input arguments for validity. .check_input_plot_args( @@ -447,7 +454,8 @@ setMethod( legend_label = legend_label, plot_title = plot_title, plot_sub_title = plot_sub_title, - caption = caption) + caption = caption + ) # Create plots ------------------------------------------------------------- @@ -476,18 +484,22 @@ setMethod( # Add evaluation time as subtitle component if it is not used # otherwise. - if (!"evaluation_time" %in% c(split_by, color_by, facet_by) && - object@outcome_type %in% c("survival")) { + if ( + !"evaluation_time" %in% c(split_by, color_by, facet_by) && + object@outcome_type %in% c("survival") + ) { additional_subtitle <- c( additional_subtitle, - .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1])) + .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1L]) + ) } if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = additional_subtitle, - x = x_split[[ii]]) + x = x_split[[ii]] + ) } # Generate plot @@ -509,7 +521,8 @@ setMethod( y_range = y_range, y_breaks = y_breaks, conf_int_style = conf_int_style, - conf_int_alpha = conf_int_alpha) + conf_int_alpha = conf_int_alpha + ) # Check empty output if (is.null(p)) next @@ -523,7 +536,8 @@ setMethod( def_plot_dims <- .determine_decision_curve_plot_dimensions( x = x_split[[ii]], facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Save to file. do.call( @@ -537,10 +551,13 @@ setMethod( "subtype" = "decision_curve", "x" = x_split[[ii]], "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list for export. @@ -553,7 +570,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -577,14 +595,16 @@ setMethod( y_range, y_breaks, conf_int_style, - conf_int_alpha) { + conf_int_alpha +) { # Suppress NOTES due to non-standard evaluation in data.table curve_type <- NULL # Generate a guide table. guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- guide_list$data @@ -594,7 +614,9 @@ setMethod( data = x[curve_type == "model"], mapping = ggplot2::aes( x = !!sym("threshold_probability"), - y = !!sym("net_benefit"))) + y = !!sym("net_benefit") + ) + ) # Add theme p <- p + ggtheme @@ -610,7 +632,9 @@ setMethod( data = x[curve_type == "intervention_all"], mapping = ggplot2::aes( x = !!sym("threshold_probability"), - y = !!sym("net_benefit"))) + y = !!sym("net_benefit") + ) + ) # Intervention for none. p <- p + ggplot2::geom_hline(yintercept = 0.0) @@ -626,7 +650,9 @@ setMethod( mapping = ggplot2::aes( x = !!sym("threshold_probability"), y = !!sym("net_benefit"), - colour = !!sym("color_breaks"))) + colour = !!sym("color_breaks") + ) + ) # Intervention for none. p <- p + ggplot2::geom_hline(yintercept = 0.0) @@ -639,59 +665,71 @@ setMethod( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } # Plot confidence intervals - if (conf_int_style[1] != "none") { - if (conf_int_style[1] == "step") { + if (conf_int_style[1L] != "none") { + if (conf_int_style[1L] == "step") { if (is.null(color_by)) { p <- p + ggplot2::geom_step( mapping = ggplot2::aes(y = !!sym("ci_low")), - linetype = "dashed") + linetype = "dashed" + ) p <- p + ggplot2::geom_step( mapping = ggplot2::aes(y = !!sym("ci_up")), - linetype = "dashed") + linetype = "dashed" + ) } else { p <- p + ggplot2::geom_step( mapping = ggplot2::aes( y = !!sym("ci_low"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) p <- p + ggplot2::geom_step( mapping = ggplot2::aes( y = !!sym("ci_up"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) } # Remove linetype from the legend. - p <- p + ggplot2::scale_linetype(guide = FALSE) + p <- p + ggplot2::scale_linetype(guide = "none") - } else if (conf_int_style[1] == "ribbon") { + } else if (conf_int_style[1L] == "ribbon") { if (is.null(color_by)) { p <- p + ggplot2::geom_ribbon( mapping = ggplot2::aes( ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), - alpha = conf_int_alpha) + ymax = !!sym("ci_up") + ), + alpha = conf_int_alpha + ) } else { p <- p + ggplot2::geom_ribbon( mapping = ggplot2::aes( ymin = !!sym("ci_low"), ymax = !!sym("ci_up"), - fill = !!sym("color_breaks")), - alpha = conf_int_alpha) + fill = !!sym("color_breaks") + ), + alpha = conf_int_alpha + ) } } } @@ -706,13 +744,15 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Determine how things are faceted. facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -721,20 +761,20 @@ setMethod( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } } # Prevent clipping of confidence intervals. - p <- p + ggplot2::coord_cartesian( - xlim = x_range, - ylim = y_range) + p <- p + ggplot2::coord_cartesian(xlim = x_range, ylim = y_range) return(p) } @@ -744,22 +784,24 @@ setMethod( .determine_decision_curve_plot_dimensions <- function( x, facet_by, - facet_wrap_cols) { + facet_wrap_cols +) { # Obtain faceting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Set default height and width for each subplot (in cm). - default_width <- 6 - default_height <- 4 + default_width <- 6.0 + default_height <- 4.0 # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } diff --git a/R/PlotFamiliarPlot.R b/R/PlotFamiliarPlot.R new file mode 100644 index 00000000..2ced52d5 --- /dev/null +++ b/R/PlotFamiliarPlot.R @@ -0,0 +1,274 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + +as_familiar_plot <- function( + p = NULL, + g = NULL, + layout +) { + fam_plot <- methods::new("familiarPlot") + + if (is.null(g) && ggplot2::is_ggplot(p)) { + # Get gtable from ggplot2 object. + fam_plot@gtable <- .convert_to_grob(p) + + } else if (gtable::is.gtable(g)) { + fam_plot@gtable <- g + } + + # Set column and row id. + fam_plot@row_id <- layout$row_id + fam_plot@col_id <- layout$col_id + + # Add global plot elements. + fam_plot@global_elements <- .extract_global_plot_elements(g) + + # Make panels inherit heights and widths, if they don't have any. This is done + # to ensure that panels retain heights and widths, even if supporting elements + # such as the axis text and label elements are stripped on figure composition. + fam_plot@gtable <- .gtable_update_panel_aspects(fam_plot@gtable) + + return(fam_plot) +} + + + +.extract_global_plot_elements <- function(g) { + + element_list <- list() + + # Export list of elements. + if (is.null(g)) return(element_list) + + # Find names of all existing elements. + elements_names <- g$layout$name + + # Set names of all global elements. + global_elements <- c( + .all_gtable_guide_names(), + .all_gtable_strip_x_names(), + .all_gtable_strip_y_names(), + .all_gtable_label_x_names(), + .all_gtable_label_y_names(), + .all_gtable_title_names() + ) + + # Identify which global elements are present. + present_elements <- elements_names[sapply( + elements_names, + startswith_any, + prefix = global_elements + )] + if (length(present_elements) == 0L) return(element_list) + + # Add elements that are present in the table and are related to the global + # elements. + for (present_element in present_elements) { + element_list[[present_element]] <- .gtable_extract_grob( + g = g, + element = present_element + ) + } + + # # Filter zeroGrob and nullGrob classes, which represent empty elements. + element_list <- element_list[! + sapply( + lapply(element_list, class), + function(ii) any(ii %in% c("zeroGrob", "nullGrob")) + ) + ] + + return(element_list) +} + + + +.create_placeholder_figure <- function( + template_figure_row, + template_figure_col, + row_id, + col_id +) { + # Creates placeholder for missing figures in faceted panel, e.g. because no + # data were present. + if ( + !is(template_figure_row, "familiarPlot") || + !is(template_figure_col, "familiarPlot") + ) { + ..error_reached_unreachable_code("both templates should be familiarPlot objects.") + } + + # Use the row item as the initial template. + figure <- template_figure_row + + # Ensure that panels are removed. + figure@remove_panel <- TRUE + + # Drop global plot elements -- we will extract these again later. + figure@global_elements <- NULL + + # We need to update elements from the column template, e.g. axis-t, xlab-t, + # and strip-t-1. + col_element_names <- c( + .all_gtable_strip_x_names(), + .all_gtable_label_x_names(), + .all_gtable_axis_x_names() + ) + + # Find names of all existing elements. + updatable_elements <- figure@gtable$layout$name + updatable_elements <- updatable_elements[sapply( + updatable_elements, + startswith_any, + prefix = col_element_names + )] + + for (update_element in updatable_elements) { + figure@gtable <- .gtable_insert( + g = figure@gtable, + g_new = .gtable_extract_grob(template_figure_col@gtable, element = update_element), + where = c("replace", update_element) + ) + } + + # Update row_id and col_id. + figure@row_id <- row_id + figure@col_id <- col_id + + # Add global elements again. + figure@global_elements <- .extract_global_plot_elements(figure@gtable) + + return(figure) +} + + + +.set_figure_element_removal <- function( + object, + top_row_id, + bottow_row_id, + left_col_id, + right_col_id, + x_text_shared, + y_text_shared, + x_label_shared, + y_label_shared +) { + is_top_row <- object@row_id == top_row_id + is_bottom_row <- object@row_id == bottow_row_id + is_left_col <- object@col_id == left_col_id + is_right_col <- object@col_id == right_col_id + + # Facet strips + if (!is_top_row) { + object@remove_strip_x <- TRUE + } + if (!is_right_col) { + object@remove_strip_y <- TRUE + } + + # x-axis text. "individual" and "FALSE" do not lead to removal. + if (x_text_shared %in% c("overall", "TRUE")) { + object@remove_axis_text_x <- TRUE + + } else if (x_text_shared == "column" && !is_bottom_row) { + object@remove_axis_text_x <- TRUE + } + + # x-axis label. "individual" and "FALSE" do not lead to removal. + if (x_label_shared %in% c("overall", "TRUE")) { + object@remove_axis_label_x <- TRUE + + } else if (x_label_shared == "column" && !is_bottom_row) { + object@remove_axis_label_x <- TRUE + } + + # y-axis text. "individual" and "FALSE" do not lead to removal. + if (y_text_shared %in% c("overall", "TRUE")) { + object@remove_axis_text_y <- TRUE + + } else if (y_text_shared == "row" && !is_left_col) { + object@remove_axis_text_y <- TRUE + } + + # x-axis label. "individual" and "FALSE" do not lead to removal. + if (y_label_shared %in% c("overall", "TRUE")) { + object@remove_axis_label_y <- TRUE + + } else if (y_label_shared == "row" && !is_left_col) { + object@remove_axis_label_y <- TRUE + } + + return(object) +} + + + +.remove_figure_elements <- function( + object, + replace_by_zero_grob = FALSE +) { + + # Always remove guide and title. + base_elements <- c( + .all_gtable_guide_names(), + .all_gtable_title_names() + ) + + # First determine which stuff can be removed, and then match any elements in + # the gtable. + if (object@remove_strip_x) { + base_elements <- c(base_elements, .all_gtable_strip_x_names()) + } + if (object@remove_strip_y) { + base_elements <- c(base_elements, .all_gtable_strip_y_names()) + } + if (object@remove_axis_text_x) { + base_elements <- c(base_elements, .all_gtable_axis_x_names()) + } + if (object@remove_axis_text_y) { + base_elements <- c(base_elements, .all_gtable_axis_y_names()) + } + if (object@remove_axis_label_x) { + base_elements <- c(base_elements, .all_gtable_label_x_names()) + } + if (object@remove_axis_label_y) { + base_elements <- c(base_elements, .all_gtable_label_y_names()) + } + if (object@remove_panel) { + base_elements <- c(base_elements, .all_gtable_panel_names()) + } + + removable_elements <- object@gtable$layout$name + removable_elements <- removable_elements[sapply( + removable_elements, + startswith_any, + prefix = base_elements + )] + + # Iterate to remove or replace with zeroGrob. Any zeroGrobs that remain will + # be removed when composing the figure (.compose_figure). + zeroGrob <- ggplot2::zeroGrob() + for (removable_element in removable_elements) { + if (replace_by_zero_grob) { + object@gtable <- .gtable_insert( + g = object@gtable, + g_new = list(zeroGrob), + where = c("replace", removable_element) + ) + + } else { + object@gtable <- .gtable_remove( + g = object@gtable, + removed_element = removable_element + ) + } + } + + # Update widths and heights. + object@gtable <- .gtable_update_layout(g = object@gtable) + + return(object) +} diff --git a/R/PlotFeatureRanking.R b/R/PlotFeatureRanking.R index 256ae1b5..d2567c8a 100644 --- a/R/PlotFeatureRanking.R +++ b/R/PlotFeatureRanking.R @@ -20,13 +20,17 @@ NULL #' @param show_cluster (*optional*) Show which features were clustered together. #' Currently not available in combination with variable importance obtained #' during feature selection. -#' @param discrete_palette (*optional*) Palette to use for coloring bar plots, -#' in case a non-singular variable was provided to the `color_by` argument. -#' @param gradient_palette (*optional*) Palette to use for filling the bars in -#' case the `color_by` argument is not set. The bars are then coloured -#' according to the occurrence of features. By default, no gradient is used, -#' and the bars are not filled according to occurrence. Use `NULL` to fill the -#' bars using the default palette in `familiar`. +#' @param gradient_palette (*optional*) Palette for filling bars if the +#' `color_by` argument is not set. By default, bars are not coloured. If +#' `gradient_palette` is set, the palette will colour bars according to +#' feature importance. Use `NULL` to fill the bars using the `familiar` +#' default palette. Other palettes are supported by the `paletteer` package, +#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` +#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, +#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same +#' name in `grDevices`. You may also specify your own palette by providing a +#' vector of colour names listed by `grDevices::colors()` or through +#' hexadecimal RGB strings. #' @param height (*optional*) Height of the plot. A default value is derived #' from number of facets, and the length of the longest feature name (if #' `rotate_x_tick_labels` is `TRUE`). @@ -45,19 +49,10 @@ NULL #' features. #' #' The only allowed values for `split_by`, `color_by` or `facet_by` are -#' `fs_method` and `learner`, but note that `learner` has no effect when +#' `vimp_method` and `learner`, but note that `learner` has no effect when #' plotting variable importance of features acquired during feature selection. #' -#' Available palettes for `discrete_palette` and `gradient_palette` are those -#' listed by `grDevices::palette.pals()` (requires R >= 4.0.0), -#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, -#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the -#' palettes of the same name in `grDevices`. If not specified, a default -#' palette based on palettes in Tableau are used. You may also specify your -#' own palette by using colour names listed by `grDevices::colors()` or -#' through hexadecimal RGB strings. -#' -#' Labeling methods such as `set_feature_names` or `set_fs_method_names` can +#' Labeling methods such as `set_feature_names` or `set_vimp_method_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -98,14 +93,16 @@ setGeneric( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_variable_importance") } ) @@ -144,19 +141,22 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Set the data element. data_element <- switch( type, "feature_selection" = "fs_vimp", - "model" = "model_vimp") + "model" = "model_vimp" + ) # Attempt conversion to familiarCollection object. object <- do.call( @@ -170,8 +170,11 @@ setMethod( "feature_cluster_cut_method" = feature_cluster_cut_method, "feature_similarity_threshold" = feature_similarity_threshold, "aggregation_method" = aggregation_method, - "rank_threshold" = rank_threshold), - list(...))) + "rank_threshold" = rank_threshold + ), + list(...) + ) + ) return(do.call( plot_variable_importance, @@ -202,14 +205,18 @@ setMethod( "plot_title" = plot_title, "plot_sub_title" = plot_sub_title, "caption" = caption, + "limit_n_features" = limit_n_features, "y_range" = y_range, "y_n_breaks" = y_n_breaks, "y_breaks" = y_breaks, "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection), - list(...)))) + "export_collection" = export_collection + ), + list(...) + ) + )) } ) @@ -247,14 +254,16 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -284,6 +293,7 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, + limit_n_features = limit_n_features, y_range = y_range, y_n_breaks = y_n_breaks, y_breaks = y_breaks, @@ -291,7 +301,8 @@ setMethod( height = height, units = units, export_collection = export_collection, - ...)) + ... + )) } ) @@ -304,8 +315,11 @@ plot_feature_selection_occurrence <- function(...) { args = c( list( "type" = "feature_selection", - "aggregation_method" = "stability"), - list(...)))) + "aggregation_method" = "stability" + ), + list(...) + ) + )) } @@ -316,7 +330,9 @@ plot_feature_selection_variable_importance <- function(...) { plot_variable_importance, args = c( list("type" = "feature_selection"), - list(...)))) + list(...) + ) + )) } @@ -328,8 +344,11 @@ plot_model_signature_occurrence <- function(...) { args = c( list( "type" = "model", - "aggregation_method" = "stability"), - list(...)))) + "aggregation_method" = "stability" + ), + list(...) + ) + )) } @@ -339,7 +358,9 @@ plot_model_signature_variable_importance <- function(...) { plot_variable_importance, args = c( list("type" = "model"), - list(...)))) + list(...) + ) + )) } @@ -370,6 +391,7 @@ plot_model_signature_variable_importance <- function(...) { plot_title, plot_sub_title, caption, + limit_n_features, y_range, y_n_breaks, y_breaks, @@ -377,7 +399,8 @@ plot_model_signature_variable_importance <- function(...) { height, units, export_collection = FALSE, - ...) { + ... +) { # Suppress NOTES due to non-standard evaluation in data.table data_set <- NULL @@ -387,20 +410,25 @@ plot_model_signature_variable_importance <- function(...) { object = object, aggregation_method = aggregation_method, rank_threshold = rank_threshold, - aggregate_results = TRUE) + aggregate_results = TRUE + ) - available_splitting <- "fs_method" + available_splitting <- "vimp_method" + } else if (type == "model") { x <- export_model_vimp( object = object, aggregation_method = aggregation_method, rank_threshold = rank_threshold, - aggregate_results = TRUE) + aggregate_results = TRUE + ) - available_splitting <- c("fs_method", "learner") + available_splitting <- c("vimp_method", "learner") + } else { ..error_reached_unreachable_code(paste0( - ".plot_variable_importance: unknown value for type (", type, ")")) + ".plot_variable_importance: unknown value for type (", type, ")" + )) } # Check that the data are not empty. @@ -410,13 +438,14 @@ plot_model_signature_variable_importance <- function(...) { if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) { + if (length(x) > 1L) { ..error_reached_unreachable_code( - ".plot_variable_importance: list of data elements contains unmerged elements.") + ".plot_variable_importance: list of data elements contains unmerged elements." + ) } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -428,8 +457,10 @@ plot_model_signature_variable_importance <- function(...) { purpose = ifelse( type == "feature_selection", "to plot variable importance determined through feature selection methods", - "to plot model-based variable importance"), - message_type = "warning")) { + "to plot model-based variable importance" + ), + message_type = "warning" + )) { return(NULL) } @@ -439,7 +470,8 @@ plot_model_signature_variable_importance <- function(...) { .check_parameter_value_is_valid( x = show_cluster, var_name = "show_cluster", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) if (show_cluster) { # Get feature similarity data. @@ -452,7 +484,7 @@ plot_model_signature_variable_importance <- function(...) { export_dendrogram = FALSE, export_ordered_data = FALSE, export_clustering = TRUE - )[[1]] + )[[1L]] } else { feature_similarity <- NULL @@ -481,6 +513,7 @@ plot_model_signature_variable_importance <- function(...) { if (is.null(y_range) && x@rank_aggregation_method == "stability") { # for occurrence plots y_range <- c(0.0, 1.0) + } else if (is.null(y_range)) { # for variable importance score-based plots y_range <- c(0.0, max(x@data$score, na.rm = TRUE)) @@ -490,16 +523,18 @@ plot_model_signature_variable_importance <- function(...) { if (is.null(y_breaks)) { .check_input_plot_args( y_range = y_range, - y_n_breaks = y_n_breaks) + y_n_breaks = y_n_breaks + ) # Create breaks and update x_range y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) - y_range <- c(0, tail(y_breaks, n = 1)) + y_range <- c(0.0, tail(y_breaks, n = 1L)) } # Add default parameters. @@ -513,7 +548,8 @@ plot_model_signature_variable_importance <- function(...) { split_by = split_by, color_by = color_by, facet_by = facet_by, - available = available_splitting) + available = available_splitting + ) # Update splitting variables split_by <- split_var_list$split_by @@ -523,7 +559,8 @@ plot_model_signature_variable_importance <- function(...) { # legend_label legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) # Perform last checks prior to plotting .check_input_plot_args( @@ -536,7 +573,9 @@ plot_model_signature_variable_importance <- function(...) { rotate_x_tick_labels = rotate_x_tick_labels, facet_wrap_cols = facet_wrap_cols, y_range = y_range, - y_breaks = y_breaks) + y_breaks = y_breaks, + limit_n_features = limit_n_features + ) # Create plots --------------------------------------------------------------- @@ -562,7 +601,8 @@ plot_model_signature_variable_importance <- function(...) { data.table::setnames( x = x_sub, old = "name", - new = "feature") + new = "feature" + ) # Join cluster and univariate data. if (show_cluster) { @@ -572,10 +612,11 @@ plot_model_signature_variable_importance <- function(...) { y = feature_similarity@data, by.x = c("feature", available_splitting, "ensemble_model_name"), by.y = c("feature", available_splitting, "ensemble_model_name"), - allow.cartesian = TRUE) + allow.cartesian = TRUE + ) # Model-based ranking does not aggregate along data-set. - x_temporary <- x_temporary[data_set %in% c(unique(x_temporary$data_set)[1])] + x_temporary <- x_temporary[data_set %in% c(unique(x_temporary$data_set)[1L])] } # Check that the resulting data is not empty, because this would @@ -584,7 +625,8 @@ plot_model_signature_variable_importance <- function(...) { x_temporary <- data.table::copy(x_sub) x_temporary[, ":="( "cluster_id" = .I, - "cluster_size" = 1L)] + "cluster_size" = 1L + )] } # Replace x_sub @@ -595,14 +637,16 @@ plot_model_signature_variable_importance <- function(...) { plot_title <- ifelse( type == "feature_selection", "Feature selection-based variable importance", - "Model-based variable importance") + "Model-based variable importance" + ) } if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = list("aggregation_method" = x@rank_aggregation_method), - x = x_sub) + x = x_sub + ) } # Generate plot @@ -624,8 +668,10 @@ plot_model_signature_variable_importance <- function(...) { plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, + limit_n_features = limit_n_features, y_range = y_range, - y_breaks = y_breaks) + y_breaks = y_breaks + ) # Check empty output if (is.null(p)) next @@ -640,7 +686,8 @@ plot_model_signature_variable_importance <- function(...) { x = x_sub, facet_by = facet_by, facet_wrap_cols = facet_wrap_cols, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Save to file. do.call( @@ -655,10 +702,13 @@ plot_model_signature_variable_importance <- function(...) { "x" = x_sub, "split_by" = split_by, "additional" = list("aggregation_method" = x@rank_aggregation_method), - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list and export plot_list <- c(plot_list, list(p)) @@ -670,7 +720,8 @@ plot_model_signature_variable_importance <- function(...) { dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } @@ -693,16 +744,33 @@ plot_model_signature_variable_importance <- function(...) { plot_title, plot_sub_title, caption, + limit_n_features, y_range, - y_breaks) { + y_breaks +) { # Suppress NOTES due to non-standard evaluation in data.table - rank <- NULL + rank <- feature <- NULL # Create a local copy of x prior to making changes based on plot_data x <- data.table::copy(x) + + if (is.numeric(limit_n_features)) { + # Find the features with the lowest rank, and select these. + x_agg <- x[, list("rank" = min(rank)), by = c("feature")] + + # Explicitly select features based on threshold value instead of simply + # selecting the best features: features may have the same value because they + # belong to the same cluster. + threshold_value <- max(head(unique(sort(x_agg$rank)), n = limit_n_features)) + selected_features <- x_agg[rank <= threshold_value]$feature + + # Make slice. + x <- x[feature %in% selected_features, ] + } + + # We need to remove categories related to features that are no longer + # relevant. x$feature <- droplevels(x$feature) - - # Order by ascending rank. x <- x[order(rank)] # Update the ordering of features so that the features are ordered by @@ -713,7 +781,8 @@ plot_model_signature_variable_importance <- function(...) { guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- guide_list$data @@ -730,14 +799,17 @@ plot_model_signature_variable_importance <- function(...) { # Perform last checks prior to plotting .check_input_plot_args( y_range = y_range, - y_breaks = y_breaks) + y_breaks = y_breaks + ) # Create basic plot p <- ggplot2::ggplot( data = x, mapping = ggplot2::aes( x = !!sym("feature"), - y = !!sym("score"))) + y = !!sym("score") + ) + ) p <- p + ggtheme # Add fill colours. @@ -748,20 +820,23 @@ plot_model_signature_variable_importance <- function(...) { p <- p + ggplot2::geom_bar( stat = "identity", mapping = ggplot2::aes(fill = !!sym("color_breaks")), - position = "dodge") + position = "dodge" + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } else if (!is.waive(gradient_palette)) { # A gradient palette is used to colour the bars by value. p <- p + ggplot2::geom_bar( stat = "identity", mapping = ggplot2::aes(fill = !!sym("value")), - show.legend = FALSE) + show.legend = FALSE + ) # Determine gradient order. This is so that bars of more important features # are always colored with the high-range colors, independent of the @@ -770,8 +845,8 @@ plot_model_signature_variable_importance <- function(...) { gradient_order <- "identity" # Determine best and worst scores. - best_score <- x[rank == 1]$score[1] - worst_score <- x[rank == max(x$rank)]$score[1] + best_score <- x[rank == 1L]$score[1L] + worst_score <- x[rank == max(x$rank)]$score[1L] # Invert gradient if the worst score is higher than the best score. if (best_score < worst_score) gradient_order <- "reverse" @@ -779,12 +854,14 @@ plot_model_signature_variable_importance <- function(...) { # Get gradient colours gradient_colours <- .get_palette( x = gradient_palette, - palette_type = "sequential") + palette_type = "sequential" + ) p <- p + ggplot2::scale_fill_gradientn( colors = gradient_colours, limits = y_range, - trans = gradient_order) + trans = gradient_order + ) } else { # Bars are not coloured based on occurrence/importance. @@ -794,13 +871,15 @@ plot_model_signature_variable_importance <- function(...) { # Set breaks and limits on the y-axis p <- p + ggplot2::scale_y_continuous( breaks = y_breaks, - limits = y_range) + limits = y_range + ) # Determine how things are facetted facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -808,12 +887,14 @@ plot_model_signature_variable_importance <- function(...) { p <- p + ggplot2::facet_grid( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, - labeller = "label_context") + labeller = "label_context" + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, - labeller = "label_context") + labeller = "label_context" + ) } } @@ -826,25 +907,29 @@ plot_model_signature_variable_importance <- function(...) { p <- p + ggplot2::geom_text( ggplot2::aes( label = !!sym("cluster_name"), - y = 0.0), + y = 0.0 + ), colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, size = text_settings$geom_text_size, - vjust = "inward") + vjust = "inward" + ) } else { p <- p + ggplot2::geom_text( ggplot2::aes( label = !!sym("cluster_name"), y = 0.0, - group = !!sym("color_breaks")), + group = !!sym("color_breaks") + ), colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, size = text_settings$geom_text_size, vjust = "inward", - position = ggplot2::position_dodge(width = 0.9)) + position = ggplot2::position_dodge(width = 0.9) + ) } } @@ -854,7 +939,8 @@ plot_model_signature_variable_importance <- function(...) { y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Rotate x-axis ticks if (rotate_x_tick_labels) { @@ -862,7 +948,9 @@ plot_model_signature_variable_importance <- function(...) { axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } return(p) @@ -874,12 +962,14 @@ plot_model_signature_variable_importance <- function(...) { x, facet_by, facet_wrap_cols, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Get plot layout dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Determine the number of features within each facet. n_features <- data.table::uniqueN(x = x$feature) @@ -887,11 +977,11 @@ plot_model_signature_variable_importance <- function(...) { # Assume each feature takes up about 14 points (~5mm) with 2 point (0.07mm) # spacing. Then add some room for other plot elements. - default_width <- n_features * 0.5 + (n_features - 1) * 0.07 + 1.0 - default_width <- max(c(4, default_width)) + default_width <- n_features * 0.5 + (n_features - 1L) * 0.07 + 1.0 + default_width <- max(c(4.0, default_width)) # Set default height. - default_height <- 4 + default_height <- 4.0 # Reserve space for x-axis tick labels. Assume that the typical width of a # character is about 5 points (1.8 mm). For the x-axis we only reserve extra @@ -900,10 +990,10 @@ plot_model_signature_variable_importance <- function(...) { x_tick_space <- ifelse(rotate_x_tick_labels, longest_name * 0.18, 0.36) # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height + x_tick_space, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height + x_tick_space, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } diff --git a/R/PlotFeatureSimilarity.R b/R/PlotFeatureSimilarity.R index 2da68f90..aeb02889 100644 --- a/R/PlotFeatureSimilarity.R +++ b/R/PlotFeatureSimilarity.R @@ -14,7 +14,14 @@ NULL #' plots are saved to. Output is saved in the `feature_similarity` #' subdirectory. If `NULL` no figures are saved, but are returned instead. #' @param gradient_palette (*optional*) Sequential or divergent palette used to -#' colour the similarity or distance between features in a heatmap. +#' colour the similarity or distance between features in a heatmap. +#' `familiar` has a default palette. Other palettes are supported by the +#' `paletteer` package, `grDevices::palette.pals()` (requires R >= 4.0.0), +#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, +#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the +#' palettes of the same name in `grDevices`. You may also specify your own +#' palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param gradient_palette_range (*optional*) Numerical range used to span the #' gradient. This should be a range of two values, e.g. `c(0, 1)`. Lower or #' upper boundary can be unset by using `NA`. If not set, the full @@ -44,25 +51,20 @@ NULL #' #' @details This function generates area under the ROC curve plots. #' -#' Available splitting variables are: `fs_method`, `learner`, and `data_set`. -#' By default, the data is split by `fs_method` and `learner`, with facetting -#' by `data_set`. +#' Available splitting variables are: `vimp_method`, `learner`, and `data_set`. +#' By default, the data is split by `vimp_method`, `learner` and `data_set`, +#' since the features may be ordered differently for each data set. #' #' Note that similarity is determined based on the underlying data. Hence the #' ordering of features may differ between facets, and tick labels are #' maintained for each panel. #' -#' Available palettes for `gradient_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. -#' -#' Labeling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labeling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. +#' +#' This plot can be created from `dataObject`, or `data.table` objects. +#' For `data.table`, see \code{\link{as_data_object}} for additional arguments. #' #' @return `NULL` or list of plot objects, if `dir_path` is `NULL`. #' @@ -94,7 +96,7 @@ setGeneric( plot_sub_title = waiver(), caption = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_dendrogram = c("top", "right"), @@ -103,7 +105,8 @@ setGeneric( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_feature_similarity") } ) @@ -139,7 +142,7 @@ setMethod( plot_sub_title = waiver(), caption = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_dendrogram = c("top", "right"), @@ -148,7 +151,8 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, @@ -159,8 +163,11 @@ setMethod( "feature_cluster_method" = feature_cluster_method, "feature_linkage_method" = feature_linkage_method, "feature_cluster_cut_method" = feature_cluster_cut_method, - "feature_similarity_threshold" = feature_similarity_threshold), - list(...))) + "feature_similarity_threshold" = feature_similarity_threshold + ), + list(...) + ) + ) return(do.call( plot_feature_similarity, @@ -191,7 +198,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -226,7 +235,7 @@ setMethod( plot_sub_title = waiver(), caption = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_dendrogram = c("top", "right"), @@ -235,7 +244,8 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -247,20 +257,22 @@ setMethod( feature_cluster_cut_method = feature_cluster_cut_method, feature_similarity_threshold = feature_similarity_threshold, export_dendrogram = FALSE, - export_ordered_data = FALSE) + export_ordered_data = FALSE + ) # Check that the data are not empty. if (is_empty(x)) return(NULL) # Obtain data element from list. if (is.list(x)) { - if (length(x) > 1) { + if (length(x) > 1L) { ..error_reached_unreachable_code( - "plot_feature_similarity: list of data elements contains unmerged elements.") + "plot_feature_similarity: list of data elements contains unmerged elements." + ) } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -270,7 +282,8 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = TRUE), purpose = "to plot feature similarity heatmaps", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -315,20 +328,21 @@ setMethod( show_dendrogram <- NULL } - } else if (length(show_dendrogram) == 0) { + } else if (length(show_dendrogram) == 0L) { show_dendrogram <- NULL } else { .check_parameter_value_is_valid( x = show_dendrogram, var_name = "show_dendrogram", - values = c("top", "bottom", "left", "right")) + values = c("top", "bottom", "left", "right") + ) # Check that bottom and top, and left and right do not appear together. if (all(c("top", "bottom") %in% show_dendrogram)) { - stop("Dendrograms can not be drawn both above and below the plot.") + ..error("Dendrograms can not be drawn both above and below the plot.") } else if (all(c("left", "right") %in% show_dendrogram)) { - stop("Dendrograms can not be drawn both to the left and right of the plot.") + ..error("Dendrograms can not be drawn both to the left and right of the plot.") } } @@ -341,11 +355,11 @@ setMethod( # Add default splitting variables if (is.null(split_by) & is.null(facet_by)) { - # Split by feature selection method and learner - split_by <- c("fs_method", "learner") - - # Facet by dataset - facet_by <- "data_set" + # Split by variable importance method, learner and data set + split_by <- c("vimp_method", "learner", "data_set") + + # Do not use facets. + facet_by <- NULL } # Check splitting variables and generate sanitised output @@ -353,7 +367,8 @@ setMethod( x = x@data, split_by = split_by, facet_by = facet_by, - available = c("data_set", "fs_method", "learner")) + available = c("data_set", "vimp_method", "learner") + ) # Update splitting variables split_by <- split_var_list$split_by @@ -368,7 +383,8 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) ##### Create plots ------------------------------------------------- @@ -395,7 +411,8 @@ setMethod( plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = list("metric" = x@similarity_metric), - x = x_sub) + x = x_sub + ) } # Generate plot @@ -420,7 +437,8 @@ setMethod( y_breaks = y_breaks, rotate_x_tick_labels = rotate_x_tick_labels, show_dendrogram = show_dendrogram, - dendrogram_height = dendrogram_height) + dendrogram_height = dendrogram_height + ) # Check empty output if (is.null(p)) next @@ -440,7 +458,8 @@ setMethod( facet_wrap_cols = facet_wrap_cols, features = as.character(features), show_dendrogram = show_dendrogram, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Save to file. do.call( @@ -454,10 +473,14 @@ setMethod( "subtype" = "similarity", "x" = x_sub, "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) + } else { # Store as list for export. plot_list <- c(plot_list, list(p)) @@ -469,7 +492,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -496,7 +520,8 @@ setMethod( y_breaks, rotate_x_tick_labels, show_dendrogram, - dendrogram_height) { + dendrogram_height +) { # Suppress NOTES due to non-standard evaluation in data.table .NATURAL <- NULL @@ -505,30 +530,34 @@ setMethod( plot_layout_table <- .get_plot_layout_table( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Define the split in data required for faceting. - data_split <- split( + layout_split <- split( plot_layout_table, by = c("col_id", "row_id"), - sorted = TRUE) + sorted = TRUE + ) # Create plots to join figure_list <- list() extracted_element_list <- list() - for (current_split in data_split) { + for (current_split in layout_split) { # Generate the split in case there is a faceting variable. if (!is.null(facet_by)) { x_split <- methods::new( "familiarDataElementFeatureSimilarity", data, - data = x[current_split, on = .NATURAL, nomatch = NULL]) + data = x[current_split, on = .NATURAL, nomatch = NULL] + ) } else { x_split <- methods::new( "familiarDataElementFeatureSimilarity", data, - data = x) + data = x + ) } # Add in clustering information and a dendrogram. @@ -541,7 +570,8 @@ setMethod( # Complete the similarity data similarity_data <- .complete_feature_similarity_table( x = x_split@data, - similarity_metric = x_split@similarity_metric) + similarity_metric = x_split@similarity_metric + ) # Create similarity heatmap p_heatmap <- .create_feature_similarity_heatmap( @@ -559,18 +589,15 @@ setMethod( caption = caption, rotate_x_tick_labels = rotate_x_tick_labels, show_dendrogram = show_dendrogram, - similarity_metric = x_split@similarity_metric) - - # Extract plot elements from the heatmap. - extracted_elements <- .extract_plot_grobs(p = p_heatmap) - - # Remove extracted elements from the heatmap. - p_heatmap <- .remove_plot_grobs(p = p_heatmap) + similarity_metric = x_split@similarity_metric + ) - # Rename plot elements. + # Convert to gtable and append "main" to grob names. g_heatmap <- .rename_plot_grobs( g = .convert_to_grob(p_heatmap), - extension = "main") + extension = "main" + ) + if (!gtable::is.gtable(g_heatmap)) next # Add dendrogram if (!is.null(show_dendrogram) && inherits(dendrogram, "hclust")) { @@ -579,7 +606,7 @@ setMethod( h = dendrogram, similarity_metric = x_split@similarity_metric ) - + for (position in show_dendrogram) { # Plot dendrogram p_dendro <- .create_feature_similarity_dendrogram_plot( @@ -590,52 +617,76 @@ setMethod( y_n_breaks = y_n_breaks, y_breaks = y_breaks, plot_height = dendrogram_height, - rotate_x_tick_labels = rotate_x_tick_labels) - - # Determine the axis element - axis_element <- ifelse(position %in% c("top", "bottom"), "axis-l", "axis-b") - - # Extract dendrogram gtable, which consists of the panel and the height - # axis. - g_dendro <- .gtable_extract( + rotate_x_tick_labels = rotate_x_tick_labels + ) + + dendro_extension <- paste0("dendro-", position) + panel_element_name <- paste0("panel-", dendro_extension) + axis_element_name <- ifelse(position %in% c("top", "bottom"), "axis-l", "axis-b") + axis_element_name <- paste0(axis_element_name, "-", dendro_extension) + + # Convert to gtable + g_dendro <- .rename_plot_grobs( g = .convert_to_grob(p_dendro), - element = c("panel", axis_element), - partial_match = TRUE) - - # Insert the dendrogram at the position correct position around the - # heatmap. + extension = dendro_extension + ) + + where_panel <- switch( + position, + "top" = c("above", "panel-main"), + "bottom" = c("below", "panel-main"), + "left" = c("left", "panel-main"), + "right" = c("right", "panel-main") + ) + + # Insert panel-main next to panel-dendro. g_heatmap <- .gtable_insert( g = g_heatmap, - g_new = g_dendro, - where = position, - ref_element = "panel-main", - partial_match = TRUE) + g_new = .gtable_extract_grob(g_dendro, element = panel_element_name), + where = where_panel, + grob_name = panel_element_name, + spacer = .get_plot_panel_spacing( + ggtheme = ggtheme, + axis = ifelse(position %in% c("top", "bottom"), "y", "x") + ) + ) + + where_axis_element <- switch( + position, + "top" = c("intersect", "above", "axis-l-main", "left", panel_element_name), + "bottom" = c("intersect", "below", "axis-l-main", "left", panel_element_name), + "left" = c("intersect", "below", panel_element_name, "left", "axis-b-main"), + "right" = c("intersect", "below", panel_element_name, "right", "axis-b-main") + ) + + # Insert the axis element at the intersect of dendro-panel and the + # corresponding axis element of the main plot. + g_heatmap <- .gtable_insert( + g = g_heatmap, + g_new = .gtable_extract_grob(g_dendro, element = axis_element_name), + where = where_axis_element, + grob_name = axis_element_name + ) } } - - # Add combined grob to list - figure_list <- c(figure_list, list(g_heatmap)) - - # Add extract elements to the extracted_element_list - extracted_element_list <- c(extracted_element_list, list(extracted_elements)) + + # Attach to figure list. + figure_list[[paste0(current_split$row_id, ".", current_split$col_id)]] <- as_familiar_plot( + g = g_heatmap, + layout = current_split + ) } - - # Update the layout table. - plot_layout_table <- .update_plot_layout_table( + # Compose the final figure. + g <- .compose_figure( + figure_list = figure_list, plot_layout_table = plot_layout_table, - grobs = figure_list, - x_text_shared = FALSE, + x_text_shared = x_label_shared, x_label_shared = x_label_shared, - y_text_shared = FALSE, + y_text_shared = y_label_shared, y_label_shared = y_label_shared, - facet_wrap_cols = facet_wrap_cols) - - # Combine features. - g <- .arrange_plot_grobs( - grobs = figure_list, - plot_layout_table = plot_layout_table, - element_grobs = extracted_element_list, - ggtheme = ggtheme) + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme + ) return(g) } @@ -657,7 +708,8 @@ setMethod( caption, rotate_x_tick_labels, show_dendrogram, - similarity_metric) { + similarity_metric +) { if (is.null(gradient_palette_range) && !is.null(similarity_metric)) { # Find the palette range. @@ -666,9 +718,10 @@ setMethod( # Determine whether a sequential or divergent palette should be used by default. palette_type <- ifelse( - length(gradient_palette_range) > 2, + length(gradient_palette_range) > 2L, "divergent", - "sequential") + "sequential" + ) # Should the palette be inverted? This is because for some metrics, clusters # are those with least distance, not highest similarity. @@ -681,7 +734,8 @@ setMethod( p <- ggplot2::ggplot(data = x, mapping = ggplot2::aes( x = !!sym("feature_name_1"), y = !!sym("feature_name_2"), - fill = !!sym("value"))) + fill = !!sym("value") + )) p <- p + ggtheme if (!is_empty(x)) { @@ -695,18 +749,27 @@ setMethod( # Colors gradient_colours <- .get_palette( x = gradient_palette, - palette_type = palette_type, - diverge_to_white = TRUE) + palette_type = palette_type + ) if (invert_palette) gradient_colours <- rev(gradient_colours) - if (length(gradient_palette_range) > 0) { + if (length(gradient_palette_range) > 0L) { + transform <- "identity" + limits <- range(gradient_palette_range) + if (similarity_metric == "mutual_information") { + transform <- "log" + limits[1L] <- 1E-3 + } + # Add gradient palette. If the legend is not shown, legend_label equals # NULL. p <- p + ggplot2::scale_fill_gradientn( name = legend_label, colors = gradient_colours, - limits = range(gradient_palette_range), - oob = scales::squish) + limits = limits, + oob = scales::squish, + transform = transform + ) } # Show dendrogram determines where tick labels and axis labels are placed. By @@ -725,8 +788,8 @@ setMethod( # Specify both axes. Note that only the heatmap is shown, without additional # space between the plot area and the axes. - p <- p + ggplot2::scale_x_discrete(position = x_axis_position, expand = c(0, 0)) - p <- p + ggplot2::scale_y_discrete(position = y_axis_position, expand = c(0, 0)) + p <- p + ggplot2::scale_x_discrete(position = x_axis_position, expand = c(0.0, 0.0)) + p <- p + ggplot2::scale_y_discrete(position = y_axis_position, expand = c(0.0, 0.0)) # Set labels. p <- p + ggplot2::labs( @@ -734,14 +797,16 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Determine how plots are facetted. The actual facets are created in the # calling function, not here. facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -750,13 +815,15 @@ setMethod( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } } @@ -766,7 +833,9 @@ setMethod( axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } return(p) @@ -782,38 +851,43 @@ setMethod( y_n_breaks, y_breaks, plot_height, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Check if there is any data to plot. if (is_empty(x)) return(NULL) # Define the range along the x-axis. - x_range <- range(x$x_1) - x_range <- c(x_range[1] - 0.5, x_range[2] + 0.5) + x_range <- range(x$x_1, na.rm = TRUE) + x_range <- c(x_range[1L] - 0.5, x_range[2L] + 0.5) # y_range - if (is.null(y_range)) y_range <- range(c(x$y_1, x$y_2)) + if (is.null(y_range)) y_range <- range(c(x$y_1, x$y_2), na.rm = TRUE) # y_breaks if (is.null(y_breaks)) { .check_input_plot_args( y_range = y_range, - y_n_breaks = y_n_breaks) + y_n_breaks = y_n_breaks + ) # Create breaks and update y_range y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) y_range <- c( - head(y_breaks, n = 1), - tail(y_breaks, n = 1)) + head(y_breaks, n = 1L), + tail(y_breaks, n = 1L) + ) } .check_input_plot_args( y_range = y_range, - y_breaks = y_breaks) + y_breaks = y_breaks + ) # Create basic plot p <- ggplot2::ggplot( @@ -822,7 +896,9 @@ setMethod( x = !!sym("x_1"), y = !!sym("y_1"), xend = !!sym("x_2"), - yend = !!sym("y_2"))) + yend = !!sym("y_2") + ) + ) p <- p + ggtheme # Plot line segments. @@ -831,40 +907,52 @@ setMethod( if (position == "right") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) p <- p + ggplot2::scale_y_continuous( limits = y_range, - breaks = y_breaks) + breaks = y_breaks + ) p <- p + ggplot2::coord_flip() } else if (position == "bottom") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) p <- p + ggplot2::scale_y_reverse( limits = rev(y_range), - breaks = rev(y_breaks)) + breaks = rev(y_breaks) + ) } else if (position == "left") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) + p <- p + ggplot2::scale_y_reverse( limits = rev(y_range), - breaks = rev(y_breaks)) + breaks = rev(y_breaks) + ) p <- p + ggplot2::coord_flip() } else if (position == "top") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) + p <- p + ggplot2::scale_y_continuous( limits = y_range, - breaks = y_breaks) + breaks = y_breaks + ) + } else { ..error_reached_unreachable_code(paste0( ".create_feature_similarity_dendrogram_plot: unknown position encountered: ", - position)) + position + )) } # Remove some theme elements and reduce margins. The histogram height is left. @@ -873,7 +961,8 @@ setMethod( panel.background = ggplot2::element_blank(), panel.border = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank()) + axis.title.y = ggplot2::element_blank() + ) if (position %in% c("top", "bottom")) { # Remove x-axis @@ -895,7 +984,9 @@ setMethod( axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } } @@ -919,12 +1010,14 @@ setMethod( facet_wrap_cols, features, rotate_x_tick_labels, - show_dendrogram) { + show_dendrogram +) { # Obtain facetting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Determine the number of elements along the x-axis. x_n_elements <- y_n_elements <- length(features) @@ -949,10 +1042,10 @@ setMethod( dendro_width <- ifelse(any(c("left", "right") %in% show_dendrogram), 1.5, 0.0) # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * (default_height + x_tick_space + dendro_height), 27.7)) + height <- min(c(2.0 + plot_dims[1L] * (default_height + x_tick_space + dendro_height), 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * (default_width + y_tick_space + dendro_width), 19)) + width <- min(c(2.0 + plot_dims[2L] * (default_width + y_tick_space + dendro_width), 19.0)) return(c(height, width)) } @@ -981,12 +1074,13 @@ setMethod( # Add self-paired features. features <- unique(x$feature_name_1) - y <- x[rep(1, length(features))] + y <- x[rep(1.0, length(features))] y[, ":="("feature_name_1" = features, "feature_name_2" = features, "value" = 1.0, "label_order_1" = NULL, - "label_order_2" = NULL)] + "label_order_2" = NULL + )] y <- merge(x = y, y = feature_1_order, by = "feature_name_1", all = FALSE) y <- merge(x = y, y = feature_2_order, by = "feature_name_2", all = FALSE) @@ -996,10 +1090,12 @@ setMethod( # Reorder features x$feature_name_1 <- factor( x = x$feature_name_1, - levels = feature_1_order$feature_name_1[order(feature_1_order$label_order_1)]) + levels = feature_1_order$feature_name_1[order(feature_1_order$label_order_1)] + ) x$feature_name_2 <- factor( x = x$feature_name_2, - levels = feature_2_order$feature_name_2[order(feature_2_order$label_order_2)]) + levels = feature_2_order$feature_name_2[order(feature_2_order$label_order_2)] + ) return(x) } diff --git a/R/PlotGTable.R b/R/PlotGTable.R index 05c99cae..8337fbe0 100644 --- a/R/PlotGTable.R +++ b/R/PlotGTable.R @@ -1,3 +1,181 @@ +.all_gtable_guide_names <- function(type = "all") { + if (type == "all") { + return(c( + "guide-box-right", "guide-box-left", + "guide-box-top", "guide-box-bottom", "guide-box-inside" + )) + + } else if (type == "right") { + return("guide-box-right") + + } else if (type == "left") { + return("guide-box-left") + + } else if (type == "top") { + return("guide-box-top") + + } else if (type == "bottom") { + return("guide-box-bottom") + + } else if (type == "inside") { + return("guide-box-inside") + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + +.all_gtable_title_names <- function(type = "all") { + if (type == "all") { + return(c("title", "subtitle", "caption")) + + } else if (type == "title") { + return(c("title", "subtitle")) + + } else if (type == "caption") { + return("caption") + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + +.all_gtable_panel_names <- function() { + return("panel") +} + + + +.all_gtable_strip_x_names <- function() { + return(c("strip-t", "strip-b")) +} + + + +.all_gtable_strip_y_names <- function() { + return(c("strip-l", "strip-r")) +} + + + +.all_gtable_label_names <- function(type = "all") { + if (type == "all") { + return(c(.all_gtable_label_x_names(), .all_gtable_label_y_names())) + + } else if (type == "right") { + return(.all_gtable_label_y_names("right")) + + } else if (type == "left") { + return(.all_gtable_label_y_names("left")) + + } else if (type == "top") { + return(.all_gtable_label_x_names("top")) + + } else if (type == "bottom") { + return(.all_gtable_label_x_names("bottom")) + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + +.all_gtable_label_x_names <- function(type = "all") { + if (type == "all") { + return(c("xlab-b", "xlab-t")) + + } else if (type == "top") { + return("xlab-t") + + } else if (type == "bottom") { + return("xlab-b") + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + +.all_gtable_label_y_names <- function(type = "all") { + if (type == "all") { + return(c("ylab-l", "ylab-r")) + + } else if (type == "left") { + return("ylab-l") + + } else if (type == "right") { + return("ylab-r") + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + +.all_gtable_axis_names <- function(type = "all") { + if (type == "all") { + return(c(.all_gtable_axis_x_names(), .all_gtable_axis_y_names())) + + } else if (type == "right") { + return(.all_gtable_axis_y_names("right")) + + } else if (type == "left") { + return(.all_gtable_axis_y_names("left")) + + } else if (type == "top") { + return(.all_gtable_axis_x_names("top")) + + } else if (type == "bottom") { + return(.all_gtable_axis_x_names("bottom")) + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + +.all_gtable_axis_x_names <- function(type = "all") { + if (type == "all") { + return(c("axis-b", "axis-t")) + + } else if (type == "top") { + return("axis-t") + + } else if (type == "bottom") { + return("axis-b") + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + +.all_gtable_axis_y_names <- function(type = "all") { + if (type == "all") { + return(c("axis-l", "axis-r")) + + } else if (type == "left") { + return("axis-l") + + } else if (type == "right") { + return("axis-r") + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", type)) + } +} + + + .gtable_element_in_layout <- function(g, element, partial_match = FALSE) { if (partial_match) { return(any(grepl(pattern = element, x = g$layout$name))) @@ -13,55 +191,62 @@ element, where = NULL, partial_match = FALSE, - allow_multiple = FALSE) { + allow_multiple = FALSE +) { # Find position. if (partial_match) { # Based on partial matching. position <- g$layout[ grepl(pattern = element, x = g$layout$name), - c("t", "l", "b", "r")] + c("t", "l", "b", "r") + ] } else { # Based on exact matching. position <- g$layout[ g$layout$name == element, - c("t", "l", "b", "r")] + c("t", "l", "b", "r") + ] } - if (nrow(position) == 0) { + if (nrow(position) == 0L) { ..error_reached_unreachable_code( - ".gtable_get_position: element not found in layout table.") + ".gtable_get_position: element not found in layout table." + ) } if (is.null(where)) { - if (nrow(position) != 1) { + if (nrow(position) != 1L) { if (allow_multiple) { browser() } else { - stop(paste0("Multiple matches, please set where attribute.")) + ..error_reached_unreachable_code( + paste0("Multiple matches, please set where attribute.") + ) } } } else if (where == "top") { # Select the uppermost element. - position <- position[position$t == min(position$t), ][1, ] + position <- position[position$t == min(position$t), ][1L, ] } else if (where == "bottom") { # Select the bottommost element. - position <- position[position$b == max(position$b), ][1, ] + position <- position[position$b == max(position$b), ][1L, ] } else if (where == "left") { # Select the leftmost element - position <- position[position$l == min(position$l), ][1, ] + position <- position[position$l == min(position$l), ][1L, ] } else if (where == "right") { # Select the rightmost element - position <- position[position$r == max(position$r), ][1, ] + position <- position[position$r == max(position$r), ][1L, ] } else { - stop(..error_value_not_allowed( + ..error_value_not_allowed( x = where, var_name = "where", - values = c("top", "bottom", "left", "right"))) + values = c("top", "bottom", "left", "right") + ) } # Return as array. @@ -72,578 +257,565 @@ -.gtable_get_extent <- function(g, element, partial_match = FALSE) { - # Find position. - if (partial_match) { - # Based on partial matching. - position <- g$layout[ - grepl(pattern = element, x = g$layout$name), - c("t", "l", "b", "r")] - } else { - # Based on exact matching. - position <- g$layout[ - g$layout$name == element, - c("t", "l", "b", "r")] +.gtable_extract_grob <- function( + g, + element +) { + grob_id <- which(g$layout$name == element) + + if (length(grob_id) == 0L) { + ..error_reached_unreachable_code("element could not be found in gtable") + + } else if (length(grob_id) > 1L) { + ..error_reached_unreachable_code("more than one element was found in gtable") } + + return(g$grobs[[grob_id]]) +} - if (nrow(position) == 0) { - ..error_reached_unreachable_code( - ".gtable_get_extent: element not found in layout table.") + + +.gtable_insert_spacer <- function( + g, + position, + width = NULL, + height = NULL, + make_space = FALSE, + name = NULL +) { + # Generate name. + if (is.null(name)) name <- "spacer" + + # Create empty grob. + spacer <- grid::grob(cl = "spacerGrob", name = name) + + # Set width and height. + spacer$widths <- grid::unit(0.0, "cm") + if (!is.null(width)) spacer$widths <- width + spacer$heights <- grid::unit(0.0, "cm") + if (!is.null(height)) spacer$heights <- height + + # If make_space is TRUE, insert a column or row at the given position, and then + # place the spacer in the new column or row. Otherwise the spacer is inserted + # in place. + if (make_space) { + if (!is.null(width)) { + g <- gtable::gtable_add_cols( + x = g, + widths = width, + pos = position[["l"]] + ) + } + if (!is.null(height)) { + g <- gtable::gtable_add_rows( + x = g, + heights = height, + pos = position[["t"]] + ) + } } + + g <- gtable::gtable_add_grob( + g, + grobs = spacer, + t = position[["t"]], + b = position[["b"]], + l = position[["l"]], + r = position[["r"]], + name = name + ) + + return(g) +} - # Find extent by deriving the bounding box of the elements. - extent <- list() - extent$t <- min(position$t) - extent$b <- max(position$b) - extent$l <- min(position$l) - extent$r <- max(position$r) - # Return as array. - extent <- simplify2array(extent) - return(extent) +.gtable_remove <- function( + g, + removed_element = NULL, + trim = FALSE +) { + matched_elements <- !(g$layout$name %in% removed_element) + + # gtable::gtable_filter uses partial matching, which leads to issues with, + # e.g., "title" and "subtitle" elements. + g$layout <- g$layout[matched_elements, , drop = FALSE] + g$grobs <- g$grobs[matched_elements] + + if (trim) g <- gtable::gtable_trim(g) + + return(g) } -.gtable_extract <- function( +.gtable_insert <- function( g, - element, - partial_match = FALSE, - drop_empty = FALSE) { - # Extract partially matching elements - if (partial_match) { - extracted_table <- gtable::gtable_filter( - x = g, - pattern = paste0(element, collapse = "|")) + g_new, + where, + grob_name = NULL, + spacer = NULL +) { + # Intended for inserting elements that stretch multiple along_elements. It can + # also be used for inserting elements directly (without along_elements) and/or + # replacing existing elements (attempt_replace=TRUE) + if (length(g_new) == 0L) { + return(g) + } + + if (where[1L] == "at") { + position <- c( + "t" = as.integer(where[2L]), + "l" = as.integer(where[3L]), + "b" = as.integer(where[4L]), + "r" = as.integer(where[5L]) + ) + + g <- ..gtable_insert_at( + g = g, + g_new = g_new, + grob_name = grob_name, + position = position + ) + + } else if (where[1L] == "replace") { + g <- ..gtable_insert_replace( + g = g, + g_new = g_new, + ref_element = where[2L] + ) + + } else if (where[1L] == "intersect") { + g <- ..gtable_insert_intersect( + g = g, + g_new = g_new, + where_1 = where[2L], + ref_element_1 = where[3L], + where_2 = where[4L], + ref_element_2 = where[5L], + grob_name = grob_name + ) + + } else if (where[1L] == "left") { + g <- ..gtable_insert_left( + g = g, + g_new = g_new, + ref_element = where[2L], + grob_name = grob_name, + spacer = spacer + ) + + } else if (where[1L] == "right") { + g <- ..gtable_insert_right( + g = g, + g_new = g_new, + ref_element = where[2L], + grob_name = grob_name, + spacer = spacer + ) + + } else if (where[1L] == "above") { + g <- ..gtable_insert_above( + g = g, + g_new = g_new, + ref_element = where[2L], + grob_name = grob_name, + spacer = spacer + ) + + } else if (where[1L] == "below") { + g <- ..gtable_insert_below( + g = g, + g_new = g_new, + ref_element = where[2L], + grob_name = grob_name, + spacer = spacer + ) } else { - # Extract exactly matching elements - extracted_table <- .gtable_filter_exact( - g = g, - element = element) - } - - # Drop empty elements - if (drop_empty) { - extracted_table <- .gtable_drop_empty(g = extracted_table) - } - - if (length(extracted_table) == 0) { - extracted_table <- NULL + ..error_reached_unreachable_code( + "The first element of where should be one of replace, intersect, left, right, above or below." + ) } - return(extracted_table) + # Update widths and heights. + g <- .gtable_update_layout(g = g) + + return(g) } -.gtable_drop_empty <- function(g, trim = TRUE) { - # Find grob classes - grob_classes <- lapply(g$grobs, class) - - # Find zeroGrob and nullGrob classes, which represent empty elements. - matches <- sapply( - grob_classes, - function(ii) any(ii %in% c("zeroGrob", "nullGrob"))) - - # Filter layout and grobs of the gtable g by keeping non-empty elements. - g$layout <- g$layout[!matches, , drop = FALSE] - g$grobs <- g$grobs[!matches] - - if (trim) g <- gtable::gtable_trim(g) +..gtable_insert_at <- function(g, g_new, grob_name = NULL, position) { + # Set clip. + clip <- "on" + if (is(g_new, "TableGrob") || is(g_new, "gtable")) clip <- g_new$layout$clip[1L] + + # Set name. + name <- grob_name + if (is.null(name) && (is(g_new, "TableGrob") || is(g_new, "gtable"))) name <- g_new$layout$name[1L] + + # Insert new element. + g <- gtable::gtable_add_grob( + g, + grobs = g_new, + t = position[["t"]], + l = position[["l"]], + b = position[["b"]], + r = position[["r"]], + name = name, + clip = clip + ) + return(g) } -.gtable_filter_exact <- function( - g, - element, - trim = TRUE, - invert = FALSE) { - # Similar to gtable::gtable_filter, but with exact matching. - - # Find exact matches - matches <- g$layout$name %in% element - - # If invert is TRUE, select only non-matching entries. - if (invert) matches <- !matches - - # Filter layout and grobs of the gtable g. - g$layout <- g$layout[matches, , drop = FALSE] - g$grobs <- g$grobs[matches] - - if (trim) g <- gtable::gtable_trim(g) +..gtable_insert_replace <- function(g, g_new, ref_element) { + # Find position where new element is to be inserted. + position <- .gtable_get_position( + g = g, + element = ref_element + ) + + # Remove original element. + g <- .gtable_remove(g = g, removed_element = ref_element) + + # Insert at position. + g <- ..gtable_insert_at( + g = g, + g_new = g_new, + grob_name = ref_element, + position = position + ) + return(g) } -.gtable_insert <- function( - g, - g_new, - where = "top", - ref_element = "panel", - spacer = NULL, - partial_match = FALSE) { +..gtable_insert_intersect <- function( + g, + g_new, + where_1, + ref_element_1, + where_2, + ref_element_2, + grob_name = NULL +) { - if (length(g_new) == 0) return(g) - - # Create an offset. - offset <- integer(4) - names(offset) <- c("t", "l", "b", "r") - - # Find position to insert this element - ref_position <- .gtable_get_position( + # Check that where is correctly specified. + if ( + all(c(where_1, where_2) %in% c("above", "below")) || + all(c(where_1, where_2) %in% c("left", "right")) + ) { + ..error_reached_unreachable_code("where needs to be orthogonal positions") + } + + elem_position <- integer(4L) + names(elem_position) <- c("t", "l", "b", "r") + + # Get reference positions for each reference element. + ref_position_1 <- .gtable_get_position( g = g, - element = ref_element, - where = where, - partial_match = partial_match) - - # Add spacing - if (where %in% c("top", "bottom")) { - # Add space to top. - if (!is.null(spacer$t)) { - g_new <- gtable::gtable_add_rows( - g_new, - heights = spacer$t, - pos = 0) - } - - # Add space to bottom. - if (!is.null(spacer$b)) { - g_new <- gtable::gtable_add_rows( - g_new, - heights = spacer$b, - pos = -1) - } + element = ref_element_1 + ) + + ref_position_2 <- .gtable_get_position( + g = g, + element = ref_element_2 + ) + + if (where_1 %in% c("above", "below")) { + # Inherit l and r from the first reference element and t and b from the + # second. + elem_position[["l"]] <- ref_position_1[["l"]] + elem_position[["r"]] <- ref_position_1[["r"]] + elem_position[["t"]] <- ref_position_2[["t"]] + elem_position[["b"]] <- ref_position_2[["b"]] + } else { - # Add space to left. - if (!is.null(spacer$l)) { - g_new <- gtable::gtable_add_cols( - g_new, - widths = spacer$l, - pos = 0) - } - - # Add space to right. - if (!is.null(spacer$r)) { - g_new <- gtable::gtable_add_cols( - g_new, - widths = spacer$r, - pos = -1) - } + # Inherit t and b from the first reference element and l and r from the + # second. + elem_position[["t"]] <- ref_position_1[["t"]] + elem_position[["b"]] <- ref_position_1[["b"]] + elem_position[["l"]] <- ref_position_2[["l"]] + elem_position[["r"]] <- ref_position_2[["r"]] } + + # Add element to g. + g <- ..gtable_insert_at( + g = g, + g_new = g_new, + grob_name = grob_name, + position = elem_position + ) + + return(g) +} - # Make room to insert the stuff. - if (where == "top") { - # Add row below t-1 (i.e. at t, and move existing rows down). - g <- gtable::gtable_add_rows( - g, - heights = g_new$heights, - pos = ref_position[["t"]] - 1) - # This shifts the rest of the elements (including the reference element) - # down by a number of rows, which means that we need an offset. - offset[["t"]] <- offset[["b"]] <- length(g_new$heights) - - } else if (where == "bottom") { - # Add row below b (i.e. at b+1, and move existing rows down). +..gtable_insert_below <- function( + g, + g_new, + ref_element, + grob_name = NULL, + spacer = NULL +) { + # Create an offset. + spacer_ref_offset <- elem_ref_offset <- integer(4L) + names(spacer_ref_offset) <- c("t", "l", "b", "r") + names(elem_ref_offset) <- c("t", "l", "b", "r") + + # Find position of reference element. + ref_position <- .gtable_get_position( + g = g, + element = ref_element + ) + + # Force the "top" of the reference position to the bottom, because we don't + # need to copy the number of rows of the reference object. + ref_position[["t"]] <- ref_position[["b"]] + + # Add space between the reference element and the element to be inserted. + if (!is.null(spacer)) { g <- gtable::gtable_add_rows( g, - heights = g_new$heights, - pos = ref_position[["b"]]) - - # This does not shift the reference element down, which means that the - # offset is -1L. - offset[["t"]] <- offset[["b"]] <- -1L + heights = spacer, + pos = ref_position[["b"]] + ) - } else if (where == "left") { - # Add column at l-1 (i.e. at l, and move existing columns to right) - g <- gtable::gtable_add_cols( - g, - widths = g_new$widths, - pos = ref_position[["l"]] - 1) - - # This shifts the rest of the elements (including the reference element) to - # the right by a number of rows, which means that we need an offset. - offset[["l"]] <- offset[["r"]] <- length(g_new$widths) - - } else if (where == "right") { - # Add column at r (i.e. at r+1, and move existing columns to the right). - g <- gtable::gtable_add_cols( - g, - widths = g_new$widths, - pos = ref_position[["r"]]) - - # This does not shift the reference element to the right, which means that - # the offset can is -1L. - offset[["l"]] <- offset[["r"]] <- -1L + # Update offsets for spacer and new grob. + spacer_ref_offset[["t"]] <- spacer_ref_offset[["b"]] <- 1L + elem_ref_offset[["t"]] <- elem_ref_offset[["b"]] <- 1L - } else { - ..error_reached_unreachable_code(paste0( - "Unknown where argument: ", where)) - } - - # Re-establish position of reference element. - ref_position <- .gtable_get_position( - g = g, - element = ref_element, - where = where, - partial_match = partial_match) - - for (ii in seq_len(nrow(g_new$layout))) { - # Find element name - element_name <- g_new$layout$name[ii] - - # Find the element position. - element_position <- .gtable_get_position( - g = g_new, - element = element_name) - - # Find the reference position of the similar-named element in g. - sim_position <- .gtable_get_position( - g = g, element = element_name, - where = where, - partial_match = partial_match) - - # Set new position. Note that element_position receives an offset of 1 - # because, position starts at 1, not 0, and we are only interest in the - # internal shift for element_position with regard to the origin. - new_position <- ref_position - offset - (element_position - 1L) - - # Align with similarly-named element in g. This only refers to vertical or - # horizontal placement. - if (where %in% c("top", "bottom")) { - new_position[["l"]] <- sim_position[["l"]] - new_position[["r"]] <- sim_position[["r"]] - } else { - new_position[["t"]] <- sim_position[["t"]] - new_position[["b"]] <- sim_position[["b"]] - } - - # Update width (for inserted rows) or height (for inserted height). - if (where %in% c("top", "bottom")) { - # Rows are inserted, and we need to update column width for new elements - # that span a single column. - if (new_position[["l"]] == new_position[["r"]]) { - if (!is.null(g_new$grobs[[ii]]$width)) { - g$widths[new_position[["l"]]] <- max(grid::unit.c( - g$widths[new_position[["l"]]], - g_new$grobs[[ii]]$width)) - } - } - } else { - # Columns are inserted, and we need to update row heights for new elements - # that span a single row. - if (new_position[["t"]] == new_position[["b"]]) { - if (!is.null(g_new$grobs[[ii]]$height)) { - g$heights[new_position[["t"]]] <- max(grid::unit.c( - g$heights[new_position[["t"]]], - g_new$grobs[[ii]]$height)) - } - } - } - - # Add element to g. - g <- gtable::gtable_add_grob( - g, - grobs = g_new$grobs[[ii]], - t = new_position[["t"]], - l = new_position[["l"]], - b = new_position[["b"]], - r = new_position[["r"]], - name = element_name, - clip = g_new$layout$clip[ii]) + # Add spacer. + g <- .gtable_insert_spacer( + g = g, + position = ref_position + spacer_ref_offset, + height = spacer + ) } + + # Add row below b or below spacer. + g <- gtable::gtable_add_rows( + g, + heights = g_new$heights, + pos = ref_position[["b"]] + elem_ref_offset[["b"]] + ) + + elem_ref_offset[["t"]] <- elem_ref_offset[["t"]] + 1L + elem_ref_offset[["b"]] <- elem_ref_offset[["b"]] + length(g_new$heights) + + # Set new position + new_position <- ref_position + elem_ref_offset + # Add element to g. + g <- ..gtable_insert_at( + g = g, + g_new = g_new, + grob_name = grob_name, + position = new_position + ) + return(g) } -.gtable_insert_along <- function( +..gtable_insert_above <- function( g, - g_new, - where = "top", - ref_element = "panel", - along_element = ref_element, - spacer = NULL, - attempt_replace = FALSE, - partial_match_ref = FALSE, - partial_match_along = FALSE, - update_dimensions = TRUE) { - # Intended for inserting elements that stretch multiple along_elements. It can - # also be used for inserting elements directly (without along_elements) and/or - # replacing existing elements (attempt_replace=TRUE) - - if (length(g_new) == 0) { - return(g) - } else if (length(g_new) > 1) { - ..error_variable_has_too_many_values( - x = g_new, - var_name = "g_new", - req_length = 1) - } - + g_new, + ref_element, + grob_name = NULL, + spacer = NULL +) { # Create an offset. - offset <- integer(4) - names(offset) <- c("t", "l", "b", "r") - - spacer_offset <- integer(4) - names(spacer_offset) <- c("t", "l", "b", "r") - - # Find position to insert this element + spacer_ref_offset <- elem_ref_offset <- integer(4L) + names(spacer_ref_offset) <- c("t", "l", "b", "r") + names(elem_ref_offset) <- c("t", "l", "b", "r") + + # Find position of reference element. ref_position <- .gtable_get_position( g = g, - element = ref_element, - where = where, - partial_match = partial_match_ref) - - # Add spacing - if (where %in% c("top", "bottom")) { - # Add space to top. - if (!is.null(spacer$t)) { - g_new <- gtable::gtable_add_rows( - g_new, - heights = spacer$t, - pos = 0) - - # This shifts the actual element downward. - spacer_offset[["t"]] <- spacer_offset[["b"]] <- 1L - } - - # Add space to bottom. - if (!is.null(spacer$b)) { - g_new <- gtable::gtable_add_rows( - g_new, - heights = spacer$b, - pos = -1) - } - - } else { - # Add space to left. - if (!is.null(spacer$l)) { - g_new <- gtable::gtable_add_cols( - g_new, - widths = spacer$l, - pos = 0) - - # This shifts the actual element to the right. - spacer_offset[["r"]] <- spacer_offset[["l"]] <- 1L - } - - # Add space to right. - if (!is.null(spacer$r)) { - g_new <- gtable::gtable_add_cols( - g_new, - widths = spacer$r, - pos = -1) - } - - } - - if (attempt_replace) { - # Find if there is a grob with the same name at the intended position. - g_index <- .gtable_which_aligned(g, - element = g_new$layout$name, - ref_element = ref_element, - where = where, - partial_match_ref = partial_match_ref) - - if (!is.null(g_index)) { - # Replace the grob. - g$grobs[[g_index]] <- g_new - - # Update heights and widths to get the accurate figures. - g <- .gtable_update_layout(g) - - return(g) - } - } - - # Make room to insert the stuff. - if (where == "top") { - # Add row below t-1 (i.e. at t, and move existing rows down). + element = ref_element + ) + + # Force the "top" of the reference position to the bottom, because we don't + # need to copy the number of rows of the reference object. + ref_position[["t"]] <- ref_position[["b"]] + + # Add space between the element that should be inserted and the reference + # element. + if (!is.null(spacer)) { g <- gtable::gtable_add_rows( g, - heights = g_new$heights, - pos = ref_position[["t"]] - 1) + heights = spacer, + pos = ref_position[["t"]] - 1L + ) + + # Add spacer. + g <- .gtable_insert_spacer( + g = g, + position = ref_position, + height = spacer + ) + } + + g <- gtable::gtable_add_rows( + g, + heights = g_new$heights, + pos = ref_position[["t"]] - 1L + ) + + # Set new position + new_position <- ref_position + new_position[["b"]] <- new_position[["b"]] + length(g_new$heights) - 1L + + # Add element to g. + g <- ..gtable_insert_at( + g = g, + g_new = g_new, + grob_name = grob_name, + position = new_position + ) + + return(g) +} - # This shifts the rest of the elements (including the reference element) - # down by a number of rows, which means that we need an offset. - offset[["t"]] <- offset[["b"]] <- length(g_new$heights) - - } else if (where == "bottom") { - # Add row below b (i.e. at b+1, and move existing rows down). - g <- gtable::gtable_add_rows( - g, - heights = g_new$heights, - pos = ref_position[["b"]]) - # This does not shift the reference element down, which means that the - # offset is -1L. - offset[["t"]] <- offset[["b"]] <- -1L - - } else if (where == "left") { - # Add column at l-1 (i.e. at l, and move existing columns to right) - g <- gtable::gtable_add_cols( - g, - widths = g_new$widths, - pos = ref_position[["l"]] - 1) - # This shifts the rest of the elements (including the reference element) to - # the right by a number of rows, which means that we need an offset. - offset[["l"]] <- offset[["r"]] <- length(g_new$widths) - - } else if (where == "right") { - # Add column at r (i.e. at r+1, and move existing columns to the right). +..gtable_insert_left <- function( + g, + g_new, + ref_element, + grob_name = NULL, + spacer = NULL +) { + # Create an offset. + spacer_ref_offset <- elem_ref_offset <- integer(4L) + names(spacer_ref_offset) <- c("t", "l", "b", "r") + names(elem_ref_offset) <- c("t", "l", "b", "r") + + # Find position of reference element. + ref_position <- .gtable_get_position( + g = g, + element = ref_element + ) + + # Force the "left" of the reference position to the right, because we don't + # need to copy the number of columns of the reference object. + ref_position[["l"]] <- ref_position[["r"]] + + # Add space between the element that should be inserted and the reference + # element. + if (!is.null(spacer)) { g <- gtable::gtable_add_cols( g, - widths = g_new$widths, - pos = ref_position[["r"]]) - - # This does not shift the reference element to the right, which means that - # the offset can is -1L. - offset[["l"]] <- offset[["r"]] <- -1L + widths = spacer, + pos = ref_position[["l"]] - 1L + ) - } else { - ..error_reached_unreachable_code(paste0( - "Unknown where argument: ", where)) + # Add spacer. + g <- .gtable_insert_spacer( + g = g, + position = ref_position, + width = spacer + ) } - - # Re-establish position of reference element. - ref_position <- .gtable_get_position( - g = g, - element = ref_element, - where = where, - partial_match = partial_match_ref) - - # Find element name - element_name <- g_new$layout$name[1] - - # Find the extent of the along_elements - extent <- .gtable_get_extent( - g = g, - element = along_element, - partial_match = partial_match_along) - + + # Make room for the grob that we want to insert. + g <- gtable::gtable_add_cols( + g, + widths = g_new$widths, + pos = ref_position[["l"]] - 1L + ) + # Set new position - new_position <- ref_position + spacer_offset - offset - - if (where %in% c("top", "bottom")) { - new_position[["l"]] <- extent[["l"]] - new_position[["r"]] <- extent[["r"]] - } else { - new_position[["t"]] <- extent[["t"]] - new_position[["b"]] <- extent[["b"]] - } - + new_position <- ref_position + new_position[["r"]] <- new_position[["r"]] + length(g_new$widths) - 1L + # Add element to g. - g <- gtable::gtable_add_grob(g, - grobs = g_new$grobs[[1]], - t = new_position[["t"]], - l = new_position[["l"]], - b = new_position[["b"]], - r = new_position[["r"]], - name = element_name, - clip = g_new$layout$clip[1] + g <- ..gtable_insert_at( + g = g, + g_new = g_new, + grob_name = grob_name, + position = new_position ) - # Update widths and heights. - g <- .gtable_update_layout(g = g) - return(g) } -.gtable_which_aligned <- function( +..gtable_insert_right <- function( g, - element, + g_new, ref_element, - where, - partial_match_ref = FALSE, - only_nearby = TRUE) { - # Identify the element that is located as close as possible to the reference - # element, and is aligned with it. - - # Find position of the reference element. + grob_name = NULL, + spacer = NULL +) { + # Create an offset. + spacer_ref_offset <- elem_ref_offset <- integer(4L) + names(spacer_ref_offset) <- c("t", "l", "b", "r") + names(elem_ref_offset) <- c("t", "l", "b", "r") + + # Find position of reference element. ref_position <- .gtable_get_position( - g = g, - element = ref_element, - where = where, - partial_match = partial_match_ref) - - # As a list - ref_position <- as.list(ref_position) - - # Identify candidates - if (where == "top") { - # Any candidates should span the left-right extent of the reference element, - # and be entirely above it. - candidates <- which(g$layout$name == element & - g$layout$l == ref_position$l & - g$layout$r == ref_position$r & - g$layout$t < ref_position$t & - g$layout$b < ref_position$t) - - } else if (where == "bottom") { - # Any candidates should span the left-right extent of the reference element, - # and be entirely below it. - candidates <- which(g$layout$name == element & - g$layout$l == ref_position$l & - g$layout$r == ref_position$r & - g$layout$t > ref_position$b & - g$layout$b > ref_position$b) - - } else if (where == "left") { - # Any candidates should span the top-bottom extent of the reference element, - # and be entirely to the left it. - candidates <- which(g$layout$name == element & - g$layout$l < ref_position$l & - g$layout$r < ref_position$l & - g$layout$t == ref_position$t & - g$layout$b == ref_position$b) + g = g, + element = ref_element + ) + + # Force the "left" of the reference position to the right, because we don't + # need to copy the number of rows of the reference object. + ref_position[["l"]] <- ref_position[["r"]] + + # Add space between the reference element and the element to be inserted. + if (!is.null(spacer)) { + g <- gtable::gtable_add_cols( + g, + widths = spacer, + pos = ref_position[["r"]] + ) - } else if (where == "right") { - # Any candidates should span the top-bottom extent of the reference element, - # and be entirely to the right it. - candidates <- which(g$layout$name == element & - g$layout$l > ref_position$r & - g$layout$r > ref_position$r & - g$layout$t == ref_position$t & - g$layout$b == ref_position$b) + # Update offsets for spacer and new grob. + spacer_ref_offset[["l"]] <- spacer_ref_offset[["r"]] <- 1L + elem_ref_offset[["l"]] <- elem_ref_offset[["r"]] <- 1L - } else { - stop("Unknown where argument.") - } - - if (length(candidates) == 0) { - return(NULL) + # Add spacer. + g <- .gtable_insert_spacer( + g = g, + position = ref_position + spacer_ref_offset, + width = spacer + ) } + + # Add row below b or below spacer. + g <- gtable::gtable_add_cols( + g, + widths = g_new$widths, + pos = ref_position[["r"]] + elem_ref_offset[["r"]] + ) + + elem_ref_offset[["l"]] <- elem_ref_offset[["l"]] + 1L + elem_ref_offset[["r"]] <- elem_ref_offset[["r"]] + length(g_new$widths) + + # Set new position + new_position <- ref_position + elem_ref_offset + + # Add element to g. + g <- ..gtable_insert_at( + g = g, + g_new = g_new, + grob_name = grob_name, + position = new_position + ) + + return(g) +} - if (length(candidates) > 1 && only_nearby) { - # Identify the candidate that is located nearest to the reference element. - layout_table <- g$layout[candidates, ] - - if (where == "top") { - distance <- ref_position$t - layout_table$t - } else if (where == "bottom") { - distance <- layout_table$b - ref_position$b - } else if (where == "left") { - distance <- ref_position$l - layout_table$l - } else if (where == "right") { - distance <- layout_table$r - ref_position$r - } - - # Select the candidate with minimal distance. - candidates <- candidates[which.min(distance)[1]] - } - return(candidates) -} @@ -652,17 +824,19 @@ old, new, partial_match = FALSE, - allow_missing = FALSE) { + allow_missing = FALSE +) { if (!.gtable_element_in_layout( g = g, element = old, - partial_match = partial_match)) { + partial_match = partial_match + )) { if (allow_missing) { return(g) } - stop(".gtable_rename_element: element not found in layout table.") + ..error(".gtable_rename_element: element not found in layout table.") } if (partial_match) { @@ -671,8 +845,8 @@ updated_element <- g$layout$name == old } - if (sum(updated_element) > 1) { - warning(".gtable_rename_element: multiple elements will be updated.") + if (sum(updated_element) > 1L) { + ..warning(".gtable_rename_element: multiple elements will be updated.") } g$layout$name[updated_element] <- new @@ -682,55 +856,62 @@ -.gtable_update_layout <- function(g) { +.gtable_update_panel_aspects <- function(g) { + # Make panels inherit heights and widths, if they don't have any. This is done + # to ensure that panels retain heights and widths, even if supporting elements + # such as the axis text and label elements are stripped on figure composition. + element_names <- g$layout$name + panel_elements <- element_names[sapply( + element_names, + startswith_any, + prefix = .all_gtable_panel_names() + )] - ..get_aspect <- function(grob_id, g, aspect = "width") { - - if (aspect == "width") { - aspect_names <- c("widths", "width") - - } else if (aspect == "height") { - aspect_names <- c("heights", "height") - - } else { - ..error_reached_unreachable_code("aspect was not height or width") - } - - if (grid::is.unit(g$grobs[[grob_id]][[aspect_names[1L]]])) { - grob_size <- g$grobs[[grob_id]][[aspect_names[1L]]] - grob_size <- ..filter_aspect_sizes(grob_size) - if (length(grob_size) > 1L) grob_size <- sum(grob_size) + for (panel_element in panel_elements) { + for (aspect in c("height", "width")) { + grob_id <- which(element_names == panel_element) + panel_size <- .gtable_get_aspect_size( + grob_id = grob_id, + g = g, + aspect = aspect + ) - } else if (grid::is.unit(g$grobs[[grob_id]][[aspect_names[2L]]])) { - grob_size <- g$grobs[[grob_id]][[aspect_names[2L]]] - - } else { - grob_size <- NULL + # Only inherit aspect size if the panel element does not have its own + # size set. + if (is.null(panel_size)) { + if (aspect == "height") { + position <-g$layout[grob_id, "t", drop = TRUE] + panel_size <- g$heights[position] + g$grobs[[grob_id]]$height <- panel_size + + } else { + position <- g$layout[grob_id, "l", drop = TRUE] + panel_size <- g$widths[position] + g$grobs[[grob_id]]$width <- panel_size + } + } } - - return(grob_size) - } - - - ..filter_aspect_sizes <- function(x) { - if (length(x) == 0L) return(NULL) - - # Filter items that have no dimension. - grob_zero <- as.numeric(x) == 0.0 - x <- x[!grob_zero] - if (length(x) == 0L) return(grid::unit(0.0, "points")) - - # npc is only relevant if there are no other grobs with more specific unit - # types. - grob_npc <- grid::unitType(x) == "npc" - if (any(grob_npc) && !all(grob_npc)) x <- x[!grob_npc] - - return(x) } + return(g) +} + + + +.gtable_update_layout <- function(g) { + # gtable uses its heights and widths attributes to structure and plot an + # image. Because we sometimes work with composite plots in familiar, we + # need to update the gtable object. In particular, we need to set heights and + # widths attributes correctly. + # + # To do so, we read the heights and widths of individual objects in a column + # or row, depending on the aspect. These sizes are then converted to absolute + # measures (points), with the exception of objects that have non-zero npc or + # null as size. In that case, null elements take precedence over absolute + # values. For example, the figure panel has 1null height and 1null width, + # making it resizable. ..get_updated_aspect <- function(g, aspect = "width") { - if (aspect == "width") { new_sizes <- g$widths aspect_length <- ncol(g) @@ -743,11 +924,7 @@ ..error_reached_unreachable_code("aspect was not height or width") } - for (ii in seq_len(aspect_length)) { - # Do not update "null" elements. - if (any(unlist(grid::unitType(new_sizes[ii], recurse=TRUE)) == "null")) next - # Select candidates. if (aspect == "width") { candidates <- which(g$layout$l == ii & g$layout$r == ii) @@ -760,9 +937,8 @@ new_sizes[ii] <- grid::unit(0.0, "points") next } - # Identify the aspect size of the grobs. - grob_sizes <- lapply(candidates, ..get_aspect, g=g, aspect=aspect) + grob_sizes <- lapply(candidates, .gtable_get_aspect_size, g = g, aspect = aspect) grob_sizes <- grob_sizes[sapply(grob_sizes, grid::is.unit)] # Skip if there are no valid aspect sizes. @@ -773,15 +949,24 @@ # Set grob sizes. grob_sizes <- do.call(grid::unit.c, grob_sizes) - grob_sizes <- ..filter_aspect_sizes(grob_sizes) + grob_sizes <- ..gtable_filter_aspect_sizes(grob_sizes) + + # Check if there any non-zero sizes. + if (all(as.numeric(grob_sizes) == 0.0)) { + new_sizes[ii] <- grid::unit(0.0, "points") + next + } if (length(grob_sizes) > 1L) grob_sizes <- max(grob_sizes) + + # Update size based on elements that are present, as long as the + # previously provided size did not contain "null" size types. new_sizes[ii] <- grob_sizes } return(new_sizes) } - + new_heights <- ..get_updated_aspect(g = g, aspect = "height") new_widths <- ..get_updated_aspect(g = g, aspect = "width") @@ -791,3 +976,77 @@ return(g) } + + + +.gtable_get_aspect_size <- function(grob_id, g, aspect = "width") { + + grob_size <- .gtable_get_grob_aspect_size( + grob = g$grobs[[grob_id]], + aspect = aspect + ) + + return(grob_size) +} + + + +.gtable_get_grob_aspect_size <- function(grob, aspect = "width") { + + if (aspect == "width") { + aspect_names <- c("widths", "width") + + } else if (aspect == "height") { + aspect_names <- c("heights", "height") + + } else { + ..error_reached_unreachable_code("aspect was not height or width") + } + + grob_size <- NULL + + # Attempt to get the size of the grob in absolute units, but maintain size + # if this is null or npc. + for (aspect_name in aspect_names) { + current_size <- grob[[aspect_name]] + if (!is.null(current_size)) { + if (all(grid::unitType(current_size) %in% c("null", "npc"))) { + grob_size <- current_size + break + + } else { + grob_size <- sum(grid::convertUnit(current_size, "points")) + break + } + } + } + + return(grob_size) +} + + + +..gtable_filter_aspect_sizes <- function(x) { + if (length(x) == 0L) return(NULL) + + # Filter items that have no dimension. + grob_zero <- as.numeric(x) == 0.0 + if (length(x) == 1L && all(grob_zero)) return(grid::unit(0.0, "points")) + + x <- x[!grob_zero] + if (length(x) == 0L) return(grid::unit(0.0, "points")) + + # null overrides everything else. + grob_null <- grid::unitType(x) == "null" + if (any(grob_null)) { + x <- x[grob_null] + return(grid::unit(max(as.numeric(x)), "null")) + } + + # npc is only relevant if there are no other grobs with more specific unit + # types. + grob_npc <- grid::unitType(x) == "npc" + if (any(grob_npc) && !all(grob_npc)) x <- x[!grob_npc] + + return(x) +} diff --git a/R/PlotICE.R b/R/PlotICE.R index f71d43ab..24ab529e 100644 --- a/R/PlotICE.R +++ b/R/PlotICE.R @@ -15,13 +15,27 @@ NULL #' conditional expectation plots are saved to. Output is saved in the #' `explanation` subdirectory. If `NULL`, figures are written to the folder, #' but are returned instead. -#' @param discrete_palette (*optional*) Palette to use to colour the different -#' plot elements in case a value was provided to the `color_by` argument. For -#' 2D individual conditional expectation plots without novelty, the initial -#' colour determines the colour of the points indicating sample values. +#' @param discrete_palette (*optional*) Palette for colouring plot elements +#' indicated by the `color_by` argument (if any). For 2D individual +#' conditional expectation plots without novelty, the initial colour +#' determines the colour of the points indicating sample values. `familiar` +#' has a default palette. Other palettes are supported by the `paletteer` +#' package, `grDevices::palette.pals()` (requires R >= 4.0.0), +#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, +#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the +#' palettes of the same name in `grDevices`. You may also specify your own +#' palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param gradient_palette (*optional*) Sequential or divergent palette used to #' colour the raster in 2D individual conditional expectation or partial -#' dependence plots. This argument is not used for 1D plots. +#' dependence plots. This argument is not used for 1D plots. `familiar` has a +#' default palette. Other palettes are supported by the `paletteer` package, +#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` +#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, +#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same +#' name in `grDevices`. You may also specify your own palette by providing a +#' vector of colour names listed by `grDevices::colors()` or through +#' hexadecimal RGB strings. #' @param gradient_palette_range (*optional*) Numerical range used to span the #' gradient for 2D plots. This should be a range of two values, e.g. `c(0, #' 1)`. By default, values are determined from the data, dependent on the @@ -92,29 +106,18 @@ NULL #' predicted value as a function of two features. #' #' Available splitting variables are: `feature_x`, `feature_y` (2D only), -#' `fs_method`, `learner`, `data_set` and `positive_class` (categorical +#' `vimp_method`, `learner`, `data_set` and `positive_class` (categorical #' outcomes) or `evaluation_time` (survival outcomes). By default, for 1D ICE -#' plots the data are split by `feature_x`, `fs_method` and `learner`, with +#' plots the data are split by `feature_x`, `vimp_method` and `learner`, with #' faceting by `data_set`, `positive_class` or `evaluation_time`. If only #' partial dependence is shown, `positive_class` and `evaluation_time` are #' used to set colours instead. For 2D plots, by default the data are split by -#' `feature_x`, `fs_method` and `learner`, with faceting by `data_set`, +#' `feature_x`, `vimp_method` and `learner`, with faceting by `data_set`, #' `positive_class` or `evaluation_time`. The `color_by` argument cannot be #' used with 2D plots, and attempting to do so causes an error. Attempting to #' specify `feature_x` or `feature_y` for `color_by` will likewise result in #' an error, as multiple features cannot be shown in the same facet. #' -#' The splitting variables indicated by `color_by` are coloured according to -#' the `discrete_palette` parameter. This parameter is therefore only used for -#' 1D plots. Available palettes for `discrete_palette` and `gradient_palette` -#' are those listed by `grDevices::palette.pals()` (requires R >= 4.0.0), -#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, -#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the -#' palettes of the same name in `grDevices`. If not specified, a default -#' palette based on palettes in Tableau are used. You may also specify your -#' own palette by using colour names listed by `grDevices::colors()` or -#' through hexadecimal RGB strings. -#' #' Bootstrap confidence intervals of the partial dependence plots can be shown #' using various styles set by `conf_int_style`: #' @@ -133,7 +136,7 @@ NULL #' plots. To avoid clutter, only point estimates for individual samples are #' shown. #' -#' Labelling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labelling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -158,20 +161,20 @@ setGeneric( x_label = waiver(), y_label = waiver(), legend_label = waiver(), - plot_title = NULL, - plot_sub_title = NULL, + plot_title = waiver(), + plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, ice_default_alpha = 0.6, n_max_samples_shown = 50L, show_ice = TRUE, @@ -182,7 +185,8 @@ setGeneric( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_ice") } ) @@ -210,20 +214,20 @@ setMethod( x_label = waiver(), y_label = waiver(), legend_label = waiver(), - plot_title = NULL, - plot_sub_title = NULL, + plot_title = waiver(), + plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, ice_default_alpha = 0.6, n_max_samples_shown = 50L, show_ice = TRUE, @@ -234,15 +238,19 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "ice_data"), - list(...))) + "data_element" = "ice_data" + ), + list(...) + ) + ) return(do.call( plot_ice, @@ -284,7 +292,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -308,13 +318,13 @@ setMethod( #' a function of two features. #' #' Available splitting variables are: `feature_x`, `feature_y` (2D only), -#' `fs_method`, `learner`, `data_set` and `positive_class` (categorical +#' `vimp_method`, `learner`, `data_set` and `positive_class` (categorical #' outcomes) or `evaluation_time` (survival outcomes). By default, for 1D ICE -#' plots the data are split by `feature_x`, `fs_method` and `learner`, with +#' plots the data are split by `feature_x`, `vimp_method` and `learner`, with #' faceting by `data_set`, `positive_class` or `evaluation_time`. If only #' partial dependence is shown, `positive_class` and `evaluation_time` are #' used to set colours instead. For 2D plots, by default the data are split by -#' `feature_x`, `fs_method` and `learner`, with faceting by `data_set`, +#' `feature_x`, `vimp_method` and `learner`, with faceting by `data_set`, #' `positive_class` or `evaluation_time`. The `color_by` argument cannot be #' used with 2D plots, and attempting to do so causes an error. Attempting to #' specify `feature_x` or `feature_y` for `color_by` will likewise result in @@ -344,7 +354,7 @@ setMethod( #' * `none`: confidence intervals are not shown. The point estimate of the #' partial dependence is shown as usual. #' -#' Labelling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labelling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -373,23 +383,24 @@ setGeneric( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_novelty = TRUE, anchor_values = NULL, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_pd") } ) @@ -421,31 +432,35 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_novelty = TRUE, anchor_values = NULL, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "ice_data"), - list(...))) + "data_element" = "ice_data" + ), + list(...) + ) + ) return(do.call( plot_ice, @@ -486,7 +501,8 @@ setMethod( "height" = height, "units" = units, "export_collection" = export_collection - ))) + ) + )) } ) @@ -517,16 +533,16 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, ice_default_alpha = 0.6, n_max_samples_shown = 50L, show_ice = TRUE, @@ -537,7 +553,8 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table # Make sure the collection object is updated. @@ -546,35 +563,40 @@ setMethod( # Get input data. ice_data <- export_ice_data( object = object, - aggregate_results = TRUE) - + aggregate_results = TRUE + ) + pd_data <- export_partial_dependence_data( object = object, - aggregate_results = TRUE) + aggregate_results = TRUE + ) # Check anchor values. - if (length(ice_data) > 0 && !is.null(anchor_values)) { + if (length(ice_data) > 0L && !is.null(anchor_values)) { # Determine feature names. feature_names <- unique(c( sapply(ice_data, function(x) (x@identifiers$feature_x)), - sapply(ice_data, function(x) (x@identifiers$feature_y)))) + sapply(ice_data, function(x) (x@identifiers$feature_y)) + )) # Check if names are provided to anchor values. - if (length(feature_names) > 1 && length(names(anchor_values)) == 0) { - stop(paste0( + if (length(feature_names) > 1L && length(names(anchor_values)) == 0L) { + ..error(paste0( "Data for plotting individual conditional expectation plots for more ", "than one feature are present. However, the anchor values for ", "centering the plots could not be assigned because they were not named. ", - "Please provide a named vector or list.")) + "Please provide a named vector or list." + )) } # Check if the names provided to anchor values match existing values. - if (length(setdiff(names(anchor_values), feature_names)) > 0) { - warning(paste0( + if (length(setdiff(names(anchor_values), feature_names)) > 0L) { + ..warning(paste0( "One or more feature names specified as anchor values do not exist ", "as features for which data for plotting individual conditional ", "expectation plots were computed: ", - paste_s(setdiff(names(anchor_values), feature_names)))) + paste_s(setdiff(names(anchor_values), feature_names)) + )) } } @@ -602,15 +624,16 @@ setMethod( .check_number_in_valid_range( x = n_max_samples_shown, var_name = "n_max_samples_shown", - range = c(0, Inf)) + range = c(0L, Inf) + ) } # If the maximum number of ICE samples shown equal 0, set to NULL. - if (n_max_samples_shown == 0) { + if (n_max_samples_shown == 0L) { show_ice <- FALSE n_max_samples_shown <- NULL } - + # Update the output so that it is more consistent. data <- mapply( .update_ice_and_pd_output, @@ -618,21 +641,41 @@ setMethod( pd_data = pd_data, MoreArgs = list( "outcome_type" = object@outcome_type, + "class_levels" = get_outcome_class_levels(object), "anchor_values" = anchor_values, "n_samples" = n_max_samples_shown, - "seed" = sample.int(n = 10000L, size = 1L)), - SIMPLIFY = FALSE) + "seed" = sample.int(n = 10000L, size = 1L) + ), + SIMPLIFY = FALSE + ) # Flatten nested list. data <- .flatten_nested_list(data) ice_data <- data$ice_data pd_data <- data$pd_data - + + # Add in sample to ice_data, and drop identifier columns. + ice_data <- lapply( + ice_data, + function(x) { + x@data[, "sample" := get_unique_row_names(x = x@data)] + for (id_column in get_id_columns()) { + x@data[, (id_column) := NULL] + } + + x@grouping_column <- setdiff(x@grouping_column, get_id_columns()) + x@grouping_column <- c(x@grouping_column, "sample") + + return(x) + } + ) + # Check that show_pd and show_ice are not both FALSE. if (!show_pd && !show_ice) { - warning(paste0( + ..warning(paste0( "One or both of \"show_pd\" and \"show_ice\" should be TRUE to plot ", - "individual conditional expectation and/or partial dependence plots.")) + "individual conditional expectation and/or partial dependence plots." + )) return(NULL) } @@ -640,7 +683,8 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = TRUE), purpose = "to create ICE/PD plots", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -652,7 +696,8 @@ setMethod( # Determine whether 1D or 2D plots are shown. show_2d <- any(sapply( ice_data, - function(x) (!is.null(x@identifiers$feature_y)))) + function(x) (!is.null(x@identifiers$feature_y)) + )) # If the y-axis will contain a feature, only the partial dependence # can be shown. @@ -662,8 +707,8 @@ setMethod( } # conf_int_style - if (length(conf_int_style) > 1) { - conf_int_style <- head(conf_int_style, n = 1) + if (length(conf_int_style) > 1L) { + conf_int_style <- head(conf_int_style, n = 1L) } # Set the style of the confidence interval to none, in case no confidence @@ -671,7 +716,8 @@ setMethod( if (show_pd && !show_2d) { if (!all(sapply( pd_data, - function(x) (x@estimation_type %in% c("bci", "bootstrap_confidence_interval"))))) { + function(x) (x@estimation_type %in% c("bci", "bootstrap_confidence_interval")) + ))) { conf_int_style <- "none" } @@ -687,27 +733,29 @@ setMethod( } else { dropped_identifiers <- c("feature_x_value") } - + # Determine splitting variables present in the dataset. if (show_ice) { plot_data <- identify_element_sets( ice_data, ignore_grouping_column = FALSE, ignore_list_identifier = FALSE, - drop_identiers = dropped_identifiers) + drop_identiers = dropped_identifiers + ) } else { plot_data <- identify_element_sets( pd_data, ignore_grouping_column = FALSE, ignore_list_identifier = FALSE, - drop_identiers = dropped_identifiers) + drop_identiers = dropped_identifiers + ) } # Set default splitting variables. if (is.null(split_by) && is.null(facet_by) && is.null(color_by)) { if (show_2d) { - split_by <- c("fs_method", "learner", "feature_x", "feature_y") + split_by <- c("vimp_method", "learner", "feature_x", "feature_y") facet_by <- c("data_set") if (object@outcome_type == "multinomial") { @@ -720,7 +768,7 @@ setMethod( color_by <- NULL } else if (show_ice) { - split_by <- c("fs_method", "learner", "feature_x") + split_by <- c("vimp_method", "learner", "feature_x") facet_by <- c("data_set") if (object@outcome_type == "multinomial") { @@ -733,7 +781,7 @@ setMethod( color_by <- NULL } else if (show_pd) { - split_by <- c("fs_method", "learner", "feature_x") + split_by <- c("vimp_method", "learner", "feature_x") facet_by <- c("data_set") color_by <- NULL @@ -747,7 +795,7 @@ setMethod( } # Determine splitting variables. - available_splitting_vars <- c("fs_method", "learner", "data_set", "feature_x") + available_splitting_vars <- c("vimp_method", "learner", "data_set", "feature_x") if (show_2d) { available_splitting_vars <- c(available_splitting_vars, "feature_y") } @@ -760,10 +808,11 @@ setMethod( # Check that the color_by parameter is not set for 2d plots. if (show_2d && !is.null(color_by)) { - stop(paste0( + ..error(paste0( "The \"color_by\" parameter cannot be used when creating 2D ", "individual conditional expection and partial dependence plots, ", - "as additional colour-coding would making interpretation very difficult.")) + "as additional colour-coding would making interpretation very difficult." + )) } # Check splitting variables and generate sanitised output @@ -772,7 +821,8 @@ setMethod( split_by = split_by, color_by = color_by, facet_by = facet_by, - available = available_splitting_vars) + available = available_splitting_vars + ) # Update splitting variables split_by <- split_var_list$split_by @@ -780,25 +830,28 @@ setMethod( facet_by <- split_var_list$facet_by if ("feature_x" %in% color_by || "feature_y" %in% color_by) { - stop("Features cannot be used to specify colors.") + ..error("Features cannot be used to specify colors.") } # Create a legend label if (show_2d & is.waive(legend_label)) { - legend_label <- switch(object@outcome_type, + legend_label <- switch( + object@outcome_type, "binomial" = "probability", "multinomial" = "probability", "count" = "value", "continuous" = "value", "survival" = "probability", - "competing_risk" = "probability") + "competing_risk" = "probability" + ) } else if (!show_2d) { legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) } - + # Check input arguments for validity. .check_input_plot_args( conf_int_alpha = conf_int_alpha, @@ -809,7 +862,8 @@ setMethod( legend_label = legend_label, plot_title = plot_title, plot_sub_title = plot_sub_title, - caption = caption) + caption = caption + ) # Set unused data to NULL. if (!show_ice) ice_data <- NULL @@ -823,13 +877,15 @@ setMethod( .check_parameter_value_is_valid( x = value_scales, var_name = "value_scales", - values = c("fixed", "figure")) + values = c("fixed", "figure") + ) } else { .check_parameter_value_is_valid( x = value_scales, var_name = "value_scales", - values = c("fixed", "figure", "feature", "facet")) + values = c("fixed", "figure", "feature", "facet") + ) } # Set value ranges. @@ -837,15 +893,17 @@ setMethod( # The value range is provided by the user. value_range <- unique(plot_data[, c("feature_x", "feature_y")]) value_range[, ":="( - "min_value" = gradient_palette_range[1], - "max_value" = gradient_palette_range[2])] + "min_value" = gradient_palette_range[1L], + "max_value" = gradient_palette_range[2L] + )] } else if (!show_2d && !is.null(y_range)) { # The value range is provided by the user. value_range <- unique(plot_data[, c("feature_x")]) value_range[, ":="( - "min_value" = y_range[1], - "max_value" = y_range[2])] + "min_value" = y_range[1L], + "max_value" = y_range[2L] + )] } else if (show_2d & value_scales == "fixed") { # The value range is the same for all features. @@ -853,7 +911,8 @@ setMethod( x = pd_data, scale_method = "fixed", outcome_type = object@outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } else if (!show_2d & value_scales == "fixed") { # The value range is the same for all features. @@ -862,14 +921,16 @@ setMethod( x = ice_data, scale_method = "fixed", outcome_type = object@outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } else { value_range <- .create_ice_plot_value_range( x = pd_data, scale_method = "fixed", outcome_type = object@outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } } else if (!show_2d & value_scales == "feature") { @@ -879,14 +940,16 @@ setMethod( x = ice_data, scale_method = "feature", outcome_type = object@outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } else { value_range <- .create_ice_plot_value_range( x = pd_data, scale_method = "feature", outcome_type = object@outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } } else { @@ -903,13 +966,15 @@ setMethod( .check_parameter_value_is_valid( x = novelty_scales, var_name = "novelty_scales", - values = c("fixed", "figure")) + values = c("fixed", "figure") + ) if (!is.null(novelty_range)) { # The value range is provided by the user. novelty_range <- unique(plot_data[, c("feature_x", "feature_y")])[, ":="( - "min_value" = novelty_range[1], - "max_value" = novelty_range[2])] + "min_value" = novelty_range[1L], + "max_value" = novelty_range[2L] + )] } else if (novelty_scales == "fixed") { # The novelty range is the same for all features. @@ -917,13 +982,15 @@ setMethod( novelty_range <- .create_ice_plot_novelty_range( x = ice_data, scale_method = "fixed", - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) } else { novelty_range <- .create_ice_plot_novelty_range( x = pd_data, scale_method = "fixed", - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) } } else { @@ -934,7 +1001,8 @@ setMethod( .check_number_in_valid_range( x = ice_default_alpha, var_name = "ice_default_alpha", - range = c(0.0, 1.0)) + range = c(0.0, 1.0) + ) # Set plot function. if (show_2d) { @@ -967,7 +1035,8 @@ setMethod( plot_title <- ifelse( show_ice, "Individual conditional expectation", - "Partial dependence") + "Partial dependence" + ) } # Declare subtitle components. @@ -975,20 +1044,24 @@ setMethod( # Add evaluation time as subtitle component if it is not used # otherwise. - if (!"evaluation_time" %in% c(split_by, color_by, facet_by) && - object@outcome_type %in% c("survival")) { + if ( + !"evaluation_time" %in% c(split_by, color_by, facet_by) && + object@outcome_type %in% c("survival") + ) { additional_subtitle <- c( additional_subtitle, - .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1])) + .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1L]) + ) } if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = additional_subtitle, - x = x_split[[ii]]) + x = x_split[[ii]] + ) } - + # Generate plot p <- .plot_ice( x = x_split[[ii]], @@ -1025,7 +1098,8 @@ setMethod( show_ice = show_ice, show_pd = show_pd, show_2d = show_2d, - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) # Check empty output if (is.null(p)) next @@ -1043,7 +1117,8 @@ setMethod( def_plot_dims <- .determine_ice_plot_dimensions( x = x_split[[ii]], facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Save to file. do.call( @@ -1057,10 +1132,13 @@ setMethod( "subtype" = subtype, "x" = x_split[[ii]], "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list for export. @@ -1073,7 +1151,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -1116,18 +1195,28 @@ setMethod( show_ice, show_pd, show_2d, - outcome_type) { + outcome_type +) { # Split by facet. This generates a list of data splits with faceting # information that allows for positioning. plot_layout_table <- .get_plot_layout_table( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Split data into facets. This is done by row. data_facet_list <- .split_data_by_plot_facet( x = x, - plot_layout_table = plot_layout_table) + plot_layout_table = plot_layout_table + ) + + # Used for ordering of composite figures. + layout_split <- split( + plot_layout_table, + by = c("col_id", "row_id"), + sorted = TRUE + ) # Set value scales. if (is.null(value_range) && value_scales == "figure") { @@ -1140,17 +1229,19 @@ setMethod( x = plot_ice_data, scale_method = "figure", outcome_type = outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } else { value_range <- .create_ice_plot_value_range( x = plot_pd_data, scale_method = "figure", outcome_type = outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } } - + # Set novelty scales if (is.null(novelty_range) && novelty_scales == "figure") { # Keep only data that are used to set the scale. @@ -1161,13 +1252,15 @@ setMethod( novelty_range <- .create_ice_plot_novelty_range( x = plot_ice_data, scale_method = "figure", - outcome_type = outcome_type) + outcome_type = outcome_type + ) } else { novelty_range <- .create_ice_plot_novelty_range( x = plot_pd_data, scale_method = "figure", - outcome_type = outcome_type) + outcome_type = outcome_type + ) } } @@ -1176,7 +1269,7 @@ setMethod( # Default value. x_label_shared <- "column" - if (length(facet_by) > 1) { + if (length(facet_by) > 1L) { if ("feature_x" %in% c(tail(facet_by, n = length(facet_by) - 1L))) { # Same feature is used row-wise, not column-wise. x_label_shared <- "individual" @@ -1192,8 +1285,9 @@ setMethod( if (value_scales == "facet") { # If y-axis is scaled per individual facet y_label_shared <- "individual" - } else if (show_2d && length(facet_by) > 0) { - if ("feature_y" == facet_by[1]) { + + } else if (show_2d && length(facet_by) > 0L) { + if ("feature_y" == facet_by[1L]) { # Same feature is used column-wise, not row-wise. y_label_shared <- "individual" } @@ -1203,22 +1297,24 @@ setMethod( # Check label sharing. .check_input_plot_args( x_label_shared = x_label_shared, - y_label_shared = y_label_shared) + y_label_shared = y_label_shared + ) # Placeholders for plots and plot elements. figure_list <- list() extracted_element_list <- list() # Iterate over facets - for (ii in names(data_facet_list)) { + for (ii in names(layout_split)) { # Set facet_data facet_data <- data_facet_list[[ii]] + if (is_empty(data_facet_list[[ii]])) next # Keep only data that are used to set the scale. facet_ice_data <- .select_ice_plot_data(x = facet_data, data = ice_data) facet_pd_data <- .select_ice_plot_data(x = facet_data, data = pd_data) - p_main <- do.call( + p_ice <- do.call( plot_function, args = list( "facet_data" = facet_data, @@ -1252,44 +1348,35 @@ setMethod( "show_novelty" = show_novelty, "show_ice" = show_ice, "show_pd" = show_pd, - "outcome_type" = outcome_type)) + "outcome_type" = outcome_type + ) + ) - # Extract plot elements from the main calibration plot. - extracted_elements <- .extract_plot_grobs(p = p_main) - - # Remove extracted elements from the plot. - p_main <- .remove_plot_grobs(p = p_main) - # Rename plot elements. - g_calibration <- .rename_plot_grobs( - g = .convert_to_grob(p_main), - extension = "main") - - # Add combined grob to list - figure_list <- c(figure_list, list(g_calibration)) - - # Add extract elements to the grob_element_list - extracted_element_list <- c( - extracted_element_list, - list(extracted_elements)) + g_ice <- .rename_plot_grobs( + g = .convert_to_grob(p_ice), + extension = "main" + ) + if (!gtable::is.gtable(g_ice)) next + + # Attach to figure list. + figure_list[[paste0(layout_split[[ii]]$row_id, ".", layout_split[[ii]]$col_id)]] <- as_familiar_plot( + g = g_ice, + layout = layout_split[[ii]] + ) } - - # Update the layout table. - plot_layout_table <- .update_plot_layout_table( + + # Compose the final figure. Magic. + g <- .compose_figure( + figure_list = figure_list, plot_layout_table = plot_layout_table, - grobs = figure_list, x_text_shared = x_label_shared, x_label_shared = x_label_shared, y_text_shared = y_label_shared, y_label_shared = y_label_shared, - facet_wrap_cols = facet_wrap_cols) - - # Combine features. - g <- .arrange_plot_grobs( - grobs = figure_list, - plot_layout_table = plot_layout_table, - element_grobs = extracted_element_list, - ggtheme = ggtheme) + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme + ) return(g) } @@ -1326,7 +1413,8 @@ setMethod( show_ice, show_pd, outcome_type, - ...) { + ... +) { # Suppress NOTES due to non-standard evaluation in data.table feature_x <- color_breaks <- sample <- NULL @@ -1335,22 +1423,22 @@ setMethod( # Get the data that determines the main plot characteristics. if (show_ice) { - if (!is_empty(ice_data[[1]])) { - plot_data <- data.table::copy(ice_data[[1]]@data) + if (!is_empty(ice_data[[1L]])) { + plot_data <- data.table::copy(ice_data[[1L]]@data) } else { plot_data <- facet_data data_present <- FALSE } } else { - if (!is_empty(pd_data[[1]])) { - plot_data <- data.table::copy(pd_data[[1]]@data) + if (!is_empty(pd_data[[1L]])) { + plot_data <- data.table::copy(pd_data[[1L]]@data) } else { plot_data <- facet_data data_present <- FALSE } } - + # Set value range if (is.null(value_range) && value_scales == "facet" && data_present) { if (show_ice) { @@ -1358,14 +1446,16 @@ setMethod( x = ice_data, scale_method = "facet", outcome_type = outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } else { value_range <- .create_ice_plot_value_range( x = pd_data, scale_method = "facet", outcome_type = outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } } @@ -1373,8 +1463,9 @@ setMethod( if (is.numeric(plot_data$feature_x_value)) { if (is.null(x_range)) { x_range <- c( - min(plot_data$feature_x_value), - max(plot_data$feature_x_value)) + min(plot_data$feature_x_value, na.rm = TRUE), + max(plot_data$feature_x_value, na.rm = TRUE) + ) } # x_breaks @@ -1384,14 +1475,16 @@ setMethod( # Create breaks and update x_range x_breaks <- labeling::extended( m = x_n_breaks, - dmin = x_range[1], - dmax = x_range[2], - only.loose = TRUE) + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) # Update x_range x_range <- c( - head(x_breaks, n = 1), - tail(x_breaks, n = 1)) + head(x_breaks, n = 1L), + tail(x_breaks, n = 1L) + ) } .check_input_plot_args(x_range = x_range) @@ -1401,9 +1494,10 @@ setMethod( } # Find the correct y-range - value_range <- value_range[feature_x == as.character(plot_data$feature_x[1])] + value_range <- value_range[feature_x == as.character(plot_data$feature_x[1L])] if (is_empty(value_range)) { y_range <- c(NA_real_, NA_real_) + } else { y_range <- c(value_range$min_value, value_range$max_value) @@ -1414,14 +1508,16 @@ setMethod( # Create breaks and update y_range y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) # Update y-range y_range <- c( - head(y_breaks, n = 1), - tail(y_breaks, n = 1)) + head(y_breaks, n = 1L), + tail(y_breaks, n = 1L) + ) } } @@ -1429,8 +1525,8 @@ setMethod( # Set x-label if (is.waive(x_label)) { - if (!is.na(plot_data$feature_x[1])) { - x_label <- as.character(plot_data$feature_x[1]) + if (!is.na(plot_data$feature_x[1L])) { + x_label <- as.character(plot_data$feature_x[1L]) } else { x_label <- NULL } @@ -1451,14 +1547,15 @@ setMethod( .check_input_plot_args( x_label = x_label, - y_label = y_label) - + y_label = y_label + ) + # Update show_novelty to check for non-finite values in the novelty data. - show_novelty <- show_novelty && all(is.finite(plot_data$novelty)) + show_novelty <- show_novelty && !is.null(plot_data$novelty) && all(is.finite(plot_data$novelty)) if (show_novelty) { # Find the correct novelty-range - novelty_range <- novelty_range[feature_x == as.character(plot_data$feature_x[1])] + novelty_range <- novelty_range[feature_x == as.character(plot_data$feature_x[1L])] if (is_empty(novelty_range)) { novelty_range <- c(NA_real_, NA_real_) @@ -1471,13 +1568,15 @@ setMethod( # single legend. if (show_ice && data_present) { ice_guide_list <- .create_plot_guide_table( - x = ice_data[[1]]@data, + x = ice_data[[1L]]@data, color_by = color_by, discrete_palette = discrete_palette, - combine_legend = FALSE) + combine_legend = FALSE + ) # Add column to force proper grouping of lines. ice_guide_list$data[, "color_breaks_sample" := paste0(color_breaks, "_", sample)] + } else { ice_guide_list <- NULL } @@ -1486,14 +1585,15 @@ setMethod( # single legend. if (show_pd && data_present) { pd_guide_list <- .create_plot_guide_table( - x = pd_data[[1]]@data, + x = pd_data[[1L]]@data, color_by = color_by, discrete_palette = discrete_palette, - combine_legend = FALSE) + combine_legend = FALSE + ) # Set grouping variable to deal with point-group complaints. if (is.factor(pd_guide_list$data$feature_x_value)) { - pd_group_variable <- 1 + pd_group_variable <- 1L } else { pd_group_variable <- NULL @@ -1505,7 +1605,7 @@ setMethod( # Make pd line thicker than ice lines. ice_line_size <- 0.5 * ..get_plot_theme_linewidth(ggtheme = ggtheme) - pd_line_size <- 6 * ice_line_size + pd_line_size <- 6.0 * ice_line_size # In case only partial dependency plots are shown, update ice_default_alpha if (!show_ice) ice_default_alpha <- 1.0 @@ -1515,7 +1615,9 @@ setMethod( data = plot_data, mapping = ggplot2::aes( x = !!sym("feature_x_value"), - y = !!sym("value"))) + y = !!sym("value") + ) + ) p <- p + ggtheme if (!all(is.finite(y_range))) { @@ -1526,230 +1628,131 @@ setMethod( } else if (show_novelty) { # Plot with novelty. - - if (utils::packageVersion("ggplot2") >= "3.4.0") { - # Version 3.4.0 introduces the linewidth element for geom_line, and will - # produce deprecation warnings if the size argument is used instead. - - if (show_ice) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - alpha = !!sym("novelty"), - colour = !!sym("color_breaks"), - group = !!sym("color_breaks_sample")), - linewidth = ice_line_size) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = !!sym("sample"), - alpha = !!sym("novelty")), - linewidth = ice_line_size) - } - } - - if (show_pd) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - alpha = !!sym("novelty"), - colour = !!sym("color_breaks"), - group = pd_group_variable), - linewidth = pd_line_size) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - alpha = !!sym("novelty"), - group = pd_group_variable), - linewidth = pd_line_size) - } - } - } else { - # For backward compatibility with versions of ggplot2 before version - # 3.4.0. - if (show_ice) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - alpha = !!sym("novelty"), - colour = !!sym("color_breaks"), - group = !!sym("color_breaks_sample")), - size = ice_line_size) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = !!sym("sample"), - alpha = !!sym("novelty")), - size = ice_line_size) - } + if (show_ice) { + if (!is.null(color_by)) { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = ice_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + alpha = !!sym("novelty"), + colour = !!sym("color_breaks"), + group = !!sym("color_breaks_sample") + ), + linewidth = ice_line_size + ) + + } else { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = ice_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + group = !!sym("sample"), + alpha = !!sym("novelty") + ), + linewidth = ice_line_size + ) } - - if (show_pd) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - alpha = !!sym("novelty"), - colour = !!sym("color_breaks"), - group = pd_group_variable), - size = pd_line_size) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - alpha = !!sym("novelty"), - group = pd_group_variable), - size = pd_line_size) - } + } + + if (show_pd) { + if (!is.null(color_by)) { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = pd_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + alpha = !!sym("novelty"), + colour = !!sym("color_breaks"), + group = pd_group_variable + ), + linewidth = pd_line_size + ) + + } else { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = pd_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + alpha = !!sym("novelty"), + group = pd_group_variable + ), + linewidth = pd_line_size + ) } } - + # Invert novelty values, since higher values indicates greater novelty. p <- p + ggplot2::scale_alpha( trans = "reverse", limits = novelty_range, - range = c(0.1, 1.0) * ice_default_alpha) + range = c(0.1, 1.0) * ice_default_alpha + ) } else { # Plot without novelty. - - if (utils::packageVersion("ggplot2") >= "3.4.0") { - # Version 3.4.0 introduces the linewidth element for geom_line, and will - # produce deprecation warnings if the size argument is used instead. - if (show_ice) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = !!sym("color_breaks_sample"), - colour = !!sym("color_breaks")), - linewidth = ice_line_size, - alpha = ice_default_alpha) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = !!sym("sample")), - linewidth = ice_line_size, - alpha = ice_default_alpha) - } - } - - if (show_pd) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - colour = !!sym("color_breaks"), - group = pd_group_variable), - linewidth = pd_line_size) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = pd_group_variable), - linewidth = pd_line_size) - } - } - } else { - # For backwards compatibility with ggplot2 versions prior to version - # 3.4.0. - if (show_ice) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = !!sym("color_breaks_sample"), - colour = !!sym("color_breaks")), - size = ice_line_size, - alpha = ice_default_alpha) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = ice_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = !!sym("sample")), - size = ice_line_size, - alpha = ice_default_alpha) - } + + if (show_ice) { + if (!is.null(color_by)) { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = ice_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + group = !!sym("color_breaks_sample"), + colour = !!sym("color_breaks") + ), + linewidth = ice_line_size, + alpha = ice_default_alpha + ) + + } else { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = ice_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + group = !!sym("sample") + ), + linewidth = ice_line_size, + alpha = ice_default_alpha + ) } + } - if (show_pd) { - if (!is.null(color_by)) { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - colour = !!sym("color_breaks"), - group = pd_group_variable), - size = pd_line_size) - - } else { - # Create lines with alpha. - p <- p + ggplot2::geom_line( - data = pd_guide_list$data, - mapping = ggplot2::aes( - x = !!sym("feature_x_value"), - y = !!sym("value"), - group = pd_group_variable), - size = pd_line_size) - } + if (show_pd) { + if (!is.null(color_by)) { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = pd_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + colour = !!sym("color_breaks"), + group = pd_group_variable + ), + linewidth = pd_line_size + ) + + } else { + # Create lines with alpha. + p <- p + ggplot2::geom_line( + data = pd_guide_list$data, + mapping = ggplot2::aes( + x = !!sym("feature_x_value"), + y = !!sym("value"), + group = pd_group_variable + ), + linewidth = pd_line_size + ) } } } @@ -1767,7 +1770,8 @@ setMethod( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } # Update x and y scales @@ -1775,22 +1779,26 @@ setMethod( if (!is.null(y_range)) p <- p + ggplot2::scale_y_continuous(breaks = y_breaks) # Plot confidence intervals. - if (conf_int_style[1] != "none") { - if (conf_int_style[1] == "step") { + if (conf_int_style[1L] != "none") { + if (conf_int_style[1L] == "step") { if (is.null(color_by)) { p <- p + ggplot2::geom_step( data = pd_guide_list$data, mapping = ggplot2::aes( x = !!sym("feature_x_value"), - y = !!sym("value_ci_low")), - linetype = "dashed") + y = !!sym("value_ci_low") + ), + linetype = "dashed" + ) p <- p + ggplot2::geom_step( data = pd_guide_list$data, mapping = ggplot2::aes( x = !!sym("feature_x_value"), - y = !!sym("value_ci_up")), - linetype = "dashed") + y = !!sym("value_ci_up") + ), + linetype = "dashed" + ) } else { p <- p + ggplot2::geom_step( @@ -1798,23 +1806,27 @@ setMethod( mapping = ggplot2::aes( x = !!sym("feature_x_value"), y = !!sym("value_ci_low"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) p <- p + ggplot2::geom_step( data = pd_guide_list$data, mapping = ggplot2::aes( x = !!sym("feature_x_value"), y = !!sym("value_ci_up"), - colour = !!sym("color_breaks")), - linetype = "dashed") + colour = !!sym("color_breaks") + ), + linetype = "dashed" + ) } # Remove linetype from the legend. - p <- p + ggplot2::scale_linetype(guide = FALSE) + p <- p + ggplot2::scale_linetype(guide = "none") - } else if (conf_int_style[1] == "ribbon") { + } else if (conf_int_style[1L] == "ribbon") { if (show_novelty) conf_int_alpha <- conf_int_alpha * ice_default_alpha if (is.null(color_by)) { @@ -1823,8 +1835,10 @@ setMethod( mapping = ggplot2::aes( x = !!sym("feature_x_value"), ymin = !!sym("value_ci_low"), - ymax = !!sym("value_ci_up")), - alpha = conf_int_alpha) + ymax = !!sym("value_ci_up") + ), + alpha = conf_int_alpha + ) } else { p <- p + ggplot2::geom_ribbon( @@ -1833,8 +1847,10 @@ setMethod( x = !!sym("feature_x_value"), ymin = !!sym("value_ci_low"), ymax = !!sym("value_ci_up"), - fill = !!sym("color_breaks")), - alpha = conf_int_alpha) + fill = !!sym("color_breaks") + ), + alpha = conf_int_alpha + ) } } } @@ -1843,7 +1859,8 @@ setMethod( facet_by_list <- .parse_plot_facet_by( x = plot_data, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -1851,12 +1868,14 @@ setMethod( p <- p + ggplot2::facet_grid( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, - labeller = "label_context") + labeller = "label_context" + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, - labeller = "label_context") + labeller = "label_context" + ) } } @@ -1866,7 +1885,8 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Plot to Cartesian coordinates. p <- p + ggplot2::coord_cartesian(xlim = x_range, ylim = y_range) @@ -1904,13 +1924,14 @@ setMethod( conf_int_alpha, show_novelty, outcome_type, - ...) { + ... +) { # Suppress NOTES due to non-standard evaluation in data.table feature_x <- feature_y <- feature_x_value <- feature_y_value <- NULL # Get the data that determines the plot characteristics. - if (!is_empty(pd_data[[1]])) { - plot_data <- data.table::copy(pd_data[[1]]@data)[order(feature_x_value, feature_y_value)] + if (!is_empty(pd_data[[1L]])) { + plot_data <- data.table::copy(pd_data[[1L]]@data)[order(feature_x_value, feature_y_value)] } else { plot_data <- facet_data } @@ -1921,12 +1942,14 @@ setMethod( x = pd_data, scale_method = "facet", outcome_type = outcome_type, - confidence_interval = conf_int_style != "none") + confidence_interval = conf_int_style != "none" + ) } else if (is.null(value_range)) { ..error_reached_unreachable_code(paste0( ".create_2d_ice_plot: No value range was set, and value_scales ", - "was not recognised either.")) + "was not recognised either." + )) } # x_range @@ -1934,7 +1957,8 @@ setMethod( if (is.null(x_range)) { x_range <- c( min(plot_data$feature_x_value, na.rm = TRUE), - max(plot_data$feature_x_value, na.rm = TRUE)) + max(plot_data$feature_x_value, na.rm = TRUE) + ) } # x_breaks @@ -1944,14 +1968,16 @@ setMethod( # Create breaks and update x_range x_breaks <- labeling::extended( m = x_n_breaks, - dmin = x_range[1], - dmax = x_range[2], - only.loose = TRUE) + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) # Update x_range x_range <- c( - head(x_breaks, n = 1), - tail(x_breaks, n = 1)) + head(x_breaks, n = 1L), + tail(x_breaks, n = 1L) + ) } .check_input_plot_args(x_range = x_range) @@ -1965,7 +1991,8 @@ setMethod( if (is.null(y_range)) { y_range <- c( min(plot_data$feature_y_value, na.rm = TRUE), - max(plot_data$feature_y_value, na.rm = TRUE)) + max(plot_data$feature_y_value, na.rm = TRUE) + ) } # y_breaks @@ -1975,14 +2002,16 @@ setMethod( # Create breaks and update y_range y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) # Update y_range y_range <- c( - head(y_breaks, n = 1), - tail(y_breaks, n = 1)) + head(y_breaks, n = 1L), + tail(y_breaks, n = 1L) + ) } .check_input_plot_args(y_range = y_range) @@ -1992,8 +2021,11 @@ setMethod( } # Find the correct value-range - value_range <- value_range[feature_x == as.character(plot_data$feature_x[1]) & - feature_y == as.character(plot_data$feature_y[1])] + value_range <- value_range[ + feature_x == as.character(plot_data$feature_x[1L]) & + feature_y == as.character(plot_data$feature_y[1L]) + ] + if (is_empty(value_range)) { value_range <- c(NA_real_, NA_real_) } else { @@ -2001,13 +2033,15 @@ setMethod( } # Update show_novelty to check for non-finite values in the novelty data. - show_novelty <- show_novelty && all(is.finite(plot_data$novelty)) + show_novelty <- show_novelty && !is.null(plot_data$novelty) && all(is.finite(plot_data$novelty)) if (show_novelty) { # Find the correct novelty-range novelty_range <- novelty_range[ - feature_x == as.character(plot_data$feature_x[1]) & - feature_y == as.character(plot_data$feature_y[1])] + feature_x == as.character(plot_data$feature_x[1L]) & + feature_y == as.character(plot_data$feature_y[1L]) + ] + if (is_empty(novelty_range)) { novelty_range <- c(NA_real_, NA_real_) } else { @@ -2017,8 +2051,8 @@ setMethod( # Set x-label if (is.waive(x_label)) { - if (!is.na(plot_data$feature_x[1])) { - x_label <- as.character(plot_data$feature_x[1]) + if (!is.na(plot_data$feature_x[1L])) { + x_label <- as.character(plot_data$feature_x[1L]) } else { x_label <- NULL } @@ -2026,8 +2060,8 @@ setMethod( # Set y-label if (is.waive(y_label)) { - if (!is.na(plot_data$feature_y[1])) { - y_label <- as.character(plot_data$feature_y[1]) + if (!is.na(plot_data$feature_y[1L])) { + y_label <- as.character(plot_data$feature_y[1L]) } else { y_label <- NULL } @@ -2035,20 +2069,28 @@ setMethod( .check_input_plot_args( x_label = x_label, - y_label = y_label) + y_label = y_label + ) + # Set colours used for plotting + gradient_colours <- .get_palette( + x = gradient_palette, + palette_type = "sequential" + ) + # Create basic plot. p <- ggplot2::ggplot( data = plot_data, mapping = ggplot2::aes( x = !!sym("feature_x_value"), - y = !!sym("feature_y_value"))) + y = !!sym("feature_y_value") + ) + ) p <- p + ggtheme - + if (!all(is.finite(value_range))) { # Blank elements in case the value range is unset, e.g. because the model - # cannot compute survival probabilities. This happens for some mboost - # learners. + # cannot compute survival probabilities. p <- p + ggplot2::geom_blank() p <- p + ggplot2::theme( axis.line.x = ggplot2::element_blank(), @@ -2056,7 +2098,8 @@ setMethod( axis.text.x = ggplot2::element_blank(), axis.line.y = ggplot2::element_blank(), axis.ticks.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank()) + axis.text.y = ggplot2::element_blank() + ) } else if (show_novelty) { # Create point cloud with size of points by novelty -> bubblechart. @@ -2064,12 +2107,22 @@ setMethod( data = plot_data, mapping = ggplot2::aes( colour = !!sym("value"), - size = !!sym("novelty"))) + size = !!sym("novelty") + ) + ) # Invert novelty values, since higher values indicates greater novelty. p <- p + ggplot2::scale_size( trans = "reverse", - limits = novelty_range) + limits = novelty_range + ) + + # Add gradient palette as fill. + p <- p + ggplot2::scale_colour_gradientn( + name = legend_label, + colors = gradient_colours, + limits = value_range + ) } else { # Set colour for value points. @@ -2077,19 +2130,32 @@ setMethod( colour <- .get_palette( x = discrete_palette, n = 1L, - palette_type = "qualitative") + palette_type = "qualitative" + ) } else { colour <- "white" } # Specify coordinates for rectangle. - plot_data[, c("xmin", "xmax") := ..set_edge_points( - feature_x_value, range = x_range, type = "x"), - by = "feature_y_value"] - plot_data[, c("ymin", "ymax") := ..set_edge_points( - feature_y_value, range = y_range, type = "y"), - by = "feature_x_value"] + plot_data[ + , + c("xmin", "xmax") := ..set_edge_points( + feature_x_value, + range = x_range, + type = "x" + ), + by = "feature_y_value" + ] + plot_data[ + , + c("ymin", "ymax") := ..set_edge_points( + feature_y_value, + range = y_range, + type = "y" + ), + by = "feature_x_value" + ] # Insert points. This will help set up the figure - otherwise the plot # cannot be drawn. @@ -2103,23 +2169,21 @@ setMethod( xmax = !!sym("xmax"), ymin = !!sym("ymin"), ymax = !!sym("ymax"), - fill = !!sym("value"))) + fill = !!sym("value") + ) + ) + # Add gradient palette as fill. + p <- p + ggplot2::scale_fill_gradientn( + name = legend_label, + colors = gradient_colours, + limits = value_range + ) + # Draw points on top. p <- p + ggplot2::geom_point(colour = colour) } - # Set colours used for plotting - gradient_colours <- .get_palette( - x = gradient_palette, - palette_type = "sequential") - - # Add gradient palette as fill. - p <- p + ggplot2::scale_fill_gradientn( - name = legend_label, - colors = gradient_colours, - limits = value_range) - # Update x and y scales if (!is.null(x_range)) p <- p + ggplot2::scale_x_continuous(breaks = x_breaks) if (!is.null(y_range)) p <- p + ggplot2::scale_y_continuous(breaks = y_breaks) @@ -2128,7 +2192,8 @@ setMethod( facet_by_list <- .parse_plot_facet_by( x = plot_data, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -2136,12 +2201,14 @@ setMethod( p <- p + ggplot2::facet_grid( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, - labeller = "label_context") + labeller = "label_context" + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, - labeller = "label_context") + labeller = "label_context" + ) } } @@ -2151,12 +2218,11 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Plot to Cartesian coordinates. - p <- p + ggplot2::coord_cartesian( - xlim = x_range, - ylim = y_range) + p <- p + ggplot2::coord_cartesian(xlim = x_range, ylim = y_range) return(p) } @@ -2166,22 +2232,24 @@ setMethod( .determine_ice_plot_dimensions <- function( x, facet_by, - facet_wrap_cols) { + facet_wrap_cols +) { # Obtain faceting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Set default height and width for each subplot (in cm). - default_width <- 6 - default_height <- 4 + default_width <- 6.0 + default_height <- 4.0 # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } @@ -2192,7 +2260,8 @@ setMethod( x, scale_method, outcome_type, - confidence_interval = FALSE) { + confidence_interval = FALSE +) { # Suppress NOTES due to non-standard evaluation in data.table min_value <- max_value <- NULL @@ -2204,10 +2273,12 @@ setMethod( value_range <- lapply( x, ..create_ice_plot_value_range, - confidence_interval = confidence_interval) + confidence_interval = confidence_interval + ) value_range <- data.table::rbindlist( value_range, - use.names = TRUE) + use.names = TRUE + ) if (scale_method %in% c("fixed", "figure")) { if (outcome_type %in% c("binomial", "multinomial", "survival")) { @@ -2215,34 +2286,43 @@ setMethod( if (all(value_range$min_value >= 0.0) && all(value_range$max_value <= 1.0)) { value_range[, ":="( "min_value" = 0.0, - "max_value" = 1.0)] + "max_value" = 1.0 + )] } else { value_range[, ":="( "min_value" = min(min_value), - "max_value" = max(max_value))] + "max_value" = max(max_value) + )] } } else { value_range[, ":="( "min_value" = min(min_value), - "max_value" = max(max_value))] + "max_value" = max(max_value) + )] } } else if (scale_method == "facet") { # Facet scaling does not make the value ranges nice (i.e. map to (0,1) in # case of probabilities.) value_range[, ":="( "min_value" = min(min_value), - "max_value" = max(max_value))] + "max_value" = max(max_value) + )] } else if (scale_method == "feature") { - value_range[, ":="( - "min_value" = min(min_value), - "max_value" = max(max_value)), - by = c("feature_x")] + value_range[ + , + ":="( + "min_value" = min(min_value), + "max_value" = max(max_value) + ), + by = c("feature_x") + ] } else { ..error_reached_unreachable_code(paste0( ".create_ice_plot_value_range: unknown scale_method encountered: ", - scale_method)) + scale_method + )) } return(value_range) @@ -2260,19 +2340,28 @@ setMethod( if (!is.null(x@identifiers$feature_y)) { value_range <- c( value_range, - list("feature_y" = x@identifiers$feature_y)) + list("feature_y" = x@identifiers$feature_y) + ) } # Get minimum and maximum values. if (confidence_interval) { - value_range <- c(value_range, list( - "min_value" = min(x@data$value_ci_low), - "max_value" = max(x@data$value_ci_up))) + value_range <- c( + value_range, + list( + "min_value" = min(x@data$value_ci_low), + "max_value" = max(x@data$value_ci_up) + ) + ) } else { - value_range <- c(value_range, list( - "min_value" = min(x@data$value), - "max_value" = max(x@data$value))) + value_range <- c( + value_range, + list( + "min_value" = min(x@data$value), + "max_value" = max(x@data$value) + ) + ) } # Return as data.table. @@ -2290,22 +2379,26 @@ setMethod( } # Obtain value ranges. - novelty_range <- lapply( - x, - ..create_ice_plot_novelty_range) + novelty_range <- lapply(x, ..create_ice_plot_novelty_range) novelty_range <- data.table::rbindlist( novelty_range, - use.names = TRUE) + use.names = TRUE + ) - if (any(is.finite(novelty_range$min_novelty)) && - any(is.finite(novelty_range$max_novelty))) { + if ( + any(is.finite(novelty_range$min_novelty)) && + any(is.finite(novelty_range$max_novelty)) + ) { novelty_range[, ":="( "min_novelty" = min(min_novelty, na.rm = TRUE), - "max_novelty" = max(max_novelty, na.rm = TRUE))] + "max_novelty" = max(max_novelty, na.rm = TRUE) + )] + } else { novelty_range[, ":="( "min_novelty" = NA_real_, - "max_novelty" = NA_real_)] + "max_novelty" = NA_real_ + )] } return(novelty_range) @@ -2321,18 +2414,29 @@ setMethod( # Get the y-feature, if present. if (!is.null(x@identifiers$feature_y)) { - novelty_range <- c(novelty_range, list("feature_y" = x@identifiers$feature_y)) + novelty_range <- c( + novelty_range, + list("feature_y" = x@identifiers$feature_y) + ) } if (any(is.finite(x@data$novelty))) { # Get minimum and maximum novelty features. - novelty_range <- c(novelty_range, list( - "min_novelty" = min(x@data$novelty, na.rm = TRUE), - "max_novelty" = max(x@data$novelty, na.rm = TRUE))) + novelty_range <- c( + novelty_range, + list( + "min_novelty" = min(x@data$novelty, na.rm = TRUE), + "max_novelty" = max(x@data$novelty, na.rm = TRUE) + ) + ) } else { - novelty_range <- c(novelty_range, list( - "min_novelty" = NA_real_, - "max_novelty" = NA_real_)) + novelty_range <- c( + novelty_range, + list( + "min_novelty" = NA_real_, + "max_novelty" = NA_real_ + ) + ) } # Return as data.table. @@ -2348,7 +2452,8 @@ setMethod( return(lapply( split(x, by = "list_id"), ..select_ice_plot_data, - data = data)) + data = data + )) } @@ -2358,7 +2463,7 @@ setMethod( .NATURAL <- NULL # Get list identifier. - selected_list_index <- x$list_id[1] + selected_list_index <- x$list_id[1L] # Check if data exists or is NA. if (is.na(selected_list_index)) return(NULL) diff --git a/R/PlotInputArguments.R b/R/PlotInputArguments.R index 1aca725d..1e287e2a 100644 --- a/R/PlotInputArguments.R +++ b/R/PlotInputArguments.R @@ -18,6 +18,9 @@ #' @param conf_int_style (*optional*) Confidence interval style. See details for #' allowed styles. #' @param conf_int_default Sets the default options for the confidence interval. +#' @param limit_n_features (*optional*) The number of features that should be +#' included in the plot. Only the most important features are shown. By +#' default, the number of features is not limited. #' @param facet_wrap_cols (*optional*) Number of columns to generate when facet #' wrapping. If NULL, a facet grid is produced instead. #' @param x_label (*optional*) Label to provide to the x-axis. If NULL, no label @@ -79,6 +82,7 @@ conf_int_alpha = waiver(), conf_int_style = waiver(), conf_int_default = c("step", "ribbon", "none"), + limit_n_features = waiver(), facet_wrap_cols = waiver(), x_label = waiver(), y_label = waiver(), @@ -90,74 +94,87 @@ combine_legend = waiver(), plot_title = waiver(), plot_sub_title = waiver(), - caption = waiver()) { + caption = waiver() +) { # x and y ranges if (!is.waive(x_range)) { .check_input_plot_range( range_var = x_range, - var_name = "x_range") + var_name = "x_range" + ) } if (!is.waive(y_range)) { .check_input_plot_range( range_var = y_range, - var_name = "y_range") + var_name = "y_range" + ) } # x and y number of breaks if (!is.waive(x_n_breaks)) { .check_input_plot_n_breaks( n_break_var = x_n_breaks, - var_name = "x_n_breaks") + var_name = "x_n_breaks" + ) } if (!is.waive(y_n_breaks)) { .check_input_plot_n_breaks( n_break_var = y_n_breaks, - var_name = "y_n_breaks") + var_name = "y_n_breaks" + ) } # x and y breaks if (!is.waive(x_breaks)) { .check_input_plot_break( break_var = x_breaks, - var_name = "x_breaks") + var_name = "x_breaks" + ) } if (!is.waive(y_breaks)) { .check_input_plot_break( break_var = y_breaks, - var_name = "y_breaks") + var_name = "y_breaks" + ) } # labels if (!is.waive(x_label)) { .check_input_plot_label( label_var = x_label, - var_name = "x_label") + var_name = "x_label" + ) } if (!is.waive(y_label)) { .check_input_plot_label( label_var = y_label, - var_name = "y_label") + var_name = "y_label" + ) } if (!is.waive(legend_label)) { .check_input_plot_legend( label_var = legend_label, - var_name = "legend_label") + var_name = "legend_label" + ) } if (!is.waive(plot_title)) { .check_input_plot_label( label_var = plot_title, - var_name = "plot_title") + var_name = "plot_title" + ) } if (!is.waive(plot_sub_title)) { .check_input_plot_label( label_var = plot_sub_title, - var_name = "plot_sub_title") + var_name = "plot_sub_title" + ) } if (!is.waive(caption)) { .check_input_plot_label( label_var = caption, - var_name = "caption") + var_name = "caption" + ) } # Legend combination flag @@ -165,7 +182,8 @@ .check_parameter_value_is_valid( x = combine_legend, var_name = "combine_legend", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) } # Transparency values @@ -173,8 +191,9 @@ .check_number_in_valid_range( x = conf_int_alpha, var_name = "conf_int_alpha", - range = c(0, 1), - closed = c(TRUE, TRUE)) + range = c(0.0, 1.0), + closed = c(TRUE, TRUE) + ) } # Confidence intervals. Note that a confidence interval of 0.0 (equals FALSE) @@ -183,17 +202,32 @@ .check_number_in_valid_range( x = conf_int, var_name = "conf_int", - range = c(0, 1), - closed = c(TRUE, FALSE)) + range = c(0.0, 1.0), + closed = c(TRUE, FALSE) + ) } - + + # Limits to number of shown features. + if (!is.waive(limit_n_features) && !is.null(limit_n_features)) { + .check_is_integerish( + x = limit_n_features, + var_name = "limit_n_features" + ) + .check_number_in_valid_range( + x = limit_n_features, + var_name = "limit_n_features", + range = c(1L, Inf) + ) + } + # Facet wrap cols if (!is.waive(facet_wrap_cols) && !is.null(facet_wrap_cols)) { .check_number_in_valid_range( x = facet_wrap_cols, var_name = "facet_wrap_cols", - range = c(1, Inf), - closed = c(TRUE, TRUE)) + range = c(1L, Inf), + closed = c(TRUE, TRUE) + ) } # Style of confidence intervals @@ -201,7 +235,8 @@ .check_parameter_value_is_valid( x = conf_int_style, var_name = "conf_int_style", - values = conf_int_default) + values = conf_int_default + ) } # Sharing of x-axis labels @@ -209,7 +244,8 @@ .check_parameter_value_is_valid( x = x_label_shared, var_name = "x_label_shared", - values = c("overall", "column", "individual")) + values = c("overall", "column", "individual") + ) } # Sharing of y-axis labels @@ -217,7 +253,8 @@ .check_parameter_value_is_valid( x = y_label_shared, var_name = "y_label_shared", - values = c("overall", "row", "individual")) + values = c("overall", "row", "individual") + ) } # Rotation of tick labels on the x-axis by 90 degrees @@ -225,7 +262,8 @@ .check_parameter_value_is_valid( x = rotate_x_tick_labels, var_name = "rotate_x_tick_labels", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) } # Rotation of tick labels on the y-axis by 45 degrees @@ -233,7 +271,8 @@ .check_parameter_value_is_valid( x = rotate_y_tick_labels, var_name = "rotate_y_tick_labels", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) } return(invisible(TRUE)) @@ -244,32 +283,52 @@ .check_input_plot_range <- function(range_var, var_name) { # Generic range check if (!is.numeric(range_var)) { - stop(paste0( - "The ", var_name, "argument should be a numerical vector of length 2, ", - "indicating min and max of the range. Use NA to indicate an unset upper ", - "or lower boundary.")) + ..error( + paste0( + "The ", var_name, "argument should be a numerical vector of length 2, ", + "indicating min and max of the range. Use NA to indicate an unset upper ", + "or lower boundary." + ), + error_class = "input_argument_error" + ) - } else if (length(range_var) != 2) { - stop(paste0( - "The ", var_name, " argument should be a numerical vector of length 2, ", - "indicating min and max of the range. Use NA to indicate an unset upper ", - "or lower boundary.")) + } else if (length(range_var) != 2L) { + ..error( + paste0( + "The ", var_name, " argument should be a numerical vector of length 2, ", + "indicating min and max of the range. Use NA to indicate an unset upper ", + "or lower boundary." + ), + error_class = "input_argument_error" + ) } else if (any(is.infinite(range_var))) { - stop(paste0( - "The range provided by the ", var_name, " argument cannot have Inf or -Inf values. ", - "Use NA to indicate an unset upper or lower boundary.")) + ..error( + paste0( + "The range provided by the ", var_name, " argument cannot have Inf or -Inf values. ", + "Use NA to indicate an unset upper or lower boundary." + ), + error_class = "input_argument_error" + ) - } else if (!any(is.na(range_var))) { - if (range_var[1] == range_var[2]) { - stop(paste0( - "The range provided by the ", var_name, " argument cannot have the ", - "same value for the lower and upper boundary.")) + } else if (!anyNA(range_var)) { + if (range_var[1L] == range_var[2L]) { + ..error( + paste0( + "The range provided by the ", var_name, " argument cannot have the ", + "same value for the lower and upper boundary." + ), + error_class = "input_argument_error" + ) - } else if (range_var[1] > range_var[2]) { - stop(paste0( - "The range provided by the ", var_name, " argument cannot have a lower ", - "boundary with a higher value than the upper boundary.")) + } else if (range_var[1L] > range_var[2L]) { + ..error( + paste0( + "The range provided by the ", var_name, " argument cannot have a lower ", + "boundary with a higher value than the upper boundary." + ), + error_class = "input_argument_error" + ) } } @@ -281,21 +340,31 @@ .check_input_plot_n_breaks <- function(n_break_var, var_name) { # Generic number of breaks check if (!is.numeric(n_break_var)) { - stop(paste0( - "The ", var_name, " argument should be a single integer value of 2 or larger.")) + ..error( + paste0("The ", var_name, " argument should be a single integer value of 2 or larger."), + error_class = "input_argument_error" + ) - } else if (length(n_break_var) != 1) { - stop(paste0( - "The ", var_name, " argument should be a single integer value of 2 or larger.")) + } else if (length(n_break_var) != 1L) { + ..error( + paste0("The ", var_name, " argument should be a single integer value of 2 or larger."), + error_class = "input_argument_error" + ) } else if (!is.finite(n_break_var)) { - stop(paste0( - "The ", var_name, " argument should be a single integer value of 2 or larger. ", - "It cannot be infinite or NA.")) + ..error( + paste0( + "The ", var_name, " argument should be a single integer value of 2 or larger. ", + "It cannot be infinite or NA." + ), + error_class = "input_argument_error" + ) - } else if (n_break_var < 2.0) { - stop(paste0( - "The ", var_name, " argument should be a single integer value of 2 or larger.")) + } else if (n_break_var < 2L) { + ..error( + paste0("The ", var_name, " argument should be a single integer value of 2 or larger."), + error_class = "input_argument_error" + ) } return(invisible(TRUE)) @@ -308,16 +377,22 @@ if (is.null(break_var)) return(invisible(TRUE)) if (is.numeric(break_var) && !all(is.finite(break_var))) { - stop(paste0( - "The ", var_name, " argument contains NA or infite values.")) + ..error( + paste0("The ", var_name, " argument contains NA or infite values."), + error_class = "input_argument_error" + ) - } else if (any(is.na(break_var))) { - stop(paste0( - "The ", var_name, " argument contains NA or infite values.")) + } else if (anyNA(break_var)) { + ..error( + paste0("The ", var_name, " argument contains NA or infite values."), + error_class = "input_argument_error" + ) - } else if (any(duplicated(break_var))) { - stop(paste0( - "Some breaks in the ", var_name, " argument are duplicates.")) + } else if (anyDuplicated(break_var) > 0L) { + ..error( + paste0("Some breaks in the ", var_name, " argument are duplicates."), + error_class = "input_argument_error" + ) } return(invisible(TRUE)) @@ -332,13 +407,19 @@ } if (!(is.numeric(label_var) || is.character(label_var))) { - stop(paste0( - "The ", var_name, " argument should be NULL, a single number, a single string, ", - "or a call or expression interpreted by grDevices::plotmath.")) + ..error( + paste0( + "The ", var_name, " argument should be NULL, a single number, a single string, ", + "or a call or expression interpreted by grDevices::plotmath." + ), + error_class = "input_argument_error" + ) - } else if (length(label_var) != 1) { - stop(paste0( - "The ", var_name, " argument contains multiple labels, whereas a single label is expected.")) + } else if (length(label_var) != 1L) { + ..error( + paste0("The ", var_name, " argument contains multiple labels, whereas a single label is expected."), + error_class = "input_argument_error" + ) } return(invisible(TRUE)) @@ -357,19 +438,26 @@ sapply( label_var, .check_input_plot_label, - var_name = var_name) + var_name = var_name + ) return(invisible(TRUE)) } if (!(is.numeric(label_var) || is.character(label_var))) { - stop(paste0( - "The ", var_name, " argument should be NULL, a single number, a single string, ", - "or a call or expression interpreted by grDevices::plotmath.")) + ..error( + paste0( + "The ", var_name, " argument should be NULL, a single number, a single string, ", + "or a call or expression interpreted by grDevices::plotmath." + ), + error_class = "input_argument_error" + ) - } else if (length(label_var) != 1) { - stop(paste0( - "The ", var_name, " argument contains multiple labels, whereas a single label is expected.")) + } else if (length(label_var) != 1L) { + ..error( + paste0("The ", var_name, " argument contains multiple labels, whereas a single label is expected."), + error_class = "input_argument_error" + ) } return(invisible(TRUE)) @@ -379,9 +467,13 @@ .check_plot_grid_unit <- function(x, var_name) { if (!grid::is.unit(x)) { - stop(paste0( - "The ", var_name, " argument should be a grid unit (see ?grid::unit), ", - "but instead is ", paste_s(class(x)))) + ..error( + paste0( + "The ", var_name, " argument should be a grid unit (see ?grid::unit), ", + "but instead is ", paste_s(class(x)) + ), + error_class = "input_argument_error" + ) } return(invisible(TRUE)) diff --git a/R/PlotKaplanMeier.R b/R/PlotKaplanMeier.R index 811816a8..3aae02db 100644 --- a/R/PlotKaplanMeier.R +++ b/R/PlotKaplanMeier.R @@ -14,9 +14,6 @@ NULL #' @param dir_path (*optional*) Path to the directory where created figures are #' saved to. Output is saved in the `stratification` subdirectory. If `NULL` #' no figures are saved, but are returned instead. -#' @param discrete_palette (*optional*) Palette to use to color the different -#' risk strata in case a non-singular variable was provided to the `color_by` -#' argument. #' @param censoring (*optional*) Flag to indicate whether censored samples #' should be indicated on the survival curve. #' @param censor_shape (*optional*) Shape used to indicate censored samples on @@ -25,7 +22,7 @@ NULL #' @param show_logrank (*optional*) Specifies whether the results of a logrank #' test to assess differences between the risk strata is annotated in the #' plot. A log-rank test can only be shown when `color_by` and `linestyle_by` -#' are either unset, or only contain `risk_group`. +#' are either unset, or only contain `group`. #' @param show_survival_table (*optional*) Specifies whether a survival table is #' shown below the Kaplan-Meier survival curves. Survival in the risk strata #' is assessed for each of the breaks in `x_breaks`. @@ -49,19 +46,11 @@ NULL #' survival the y-axis represents. It is therefore recommended to provide #' `x_label` and `y_label` arguments. #' -#' Available splitting variables are: `fs_method`, `learner`, `data_set`, -#' `risk_group` and `stratification_method`. By default, separate figures are -#' created for each combination of `fs_method` and `learner`, with faceting by +#' Available splitting variables are: `vimp_method`, `learner`, `data_set`, +#' `group` and `stratification_method`. By default, separate figures are +#' created for each combination of `vimp_method` and `learner`, with faceting by #' `data_set`, colouring of the strata in each individual plot by -#' `risk_group`. -#' -#' Available palettes for `discrete_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. +#' `group`. #' #' Greenwood confidence intervals of the Kaplan-Meier curve can be shown using #' various styles set by `conf_int_style`: @@ -108,14 +97,14 @@ setGeneric( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_range = c(0, 1), - y_n_breaks = 5, + y_range = c(0.0, 1.0), + y_n_breaks = 5L, y_breaks = NULL, confidence_level = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, censoring = TRUE, censor_shape = "plus", show_logrank = TRUE, @@ -124,7 +113,8 @@ setGeneric( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_kaplan_meier") } ) @@ -158,14 +148,14 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_range = c(0, 1), - y_n_breaks = 5, + y_range = c(0.0, 1.0), + y_n_breaks = 5L, y_breaks = NULL, confidence_level = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, censoring = TRUE, censor_shape = "plus", show_logrank = TRUE, @@ -174,15 +164,20 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "risk_stratification_data"), - list(...))) + "data_element" = "risk_stratification_data", + ".no_features_required" = TRUE + ), + list(...) + ) + ) return(do.call( plot_kaplan_meier, @@ -222,7 +217,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -255,14 +252,14 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_range = c(0, 1), - y_n_breaks = 5, + y_range = c(0.0, 1.0), + y_n_breaks = 5L, y_breaks = NULL, confidence_level = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, censoring = TRUE, censor_shape = "plus", show_logrank = TRUE, @@ -271,9 +268,10 @@ setMethod( height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table - risk_group <- .NATURAL <- NULL + outcome_event <- .NATURAL <- NULL # Make sure the collection object is updated. object <- update_object(object = object) @@ -281,7 +279,8 @@ setMethod( # Get input data x <- export_risk_stratification_data( object = object, - export_strata = FALSE) + export_strata = FALSE + ) # Check that the data are not empty. if (is_empty(x)) return(NULL) @@ -296,25 +295,29 @@ setMethod( if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) ..error_reached_unreachable_code( - "plot_kaplan_meier: list of data elements contains unmerged elements.") + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_kaplan_meier: list of data elements contains unmerged elements." + ) + } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } - + # Check that the data are not empty. if (is_empty(x)) return(NULL) - if (!all_predictions_valid(x@data, outcome_type = "survival")) return(NULL) + if (!all_predictions_valid(x)) return(NULL) # Remove non-valid risk groups - x@data <- x@data[!is.na(risk_group)] + x <- remove_invalid_predictions(x) # Check package requirements for plotting. if (!require_package( x = ..required_plotting_packages(extended = TRUE), purpose = "to create kaplan-meier survival curves", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -336,9 +339,15 @@ setMethod( } else { y_label_shared <- "row" } - + # x_range - if (is.null(x_range)) x_range <- c(0, x@time) + if (is.null(x_range)) { + time_max <- object@outcome_info@time + if (is.infinite(time_max)) { + time_max <- .get_default_time_max(x@data[outcome_event == 1L, ]$outcome_time) + } + x_range <- c(0.0, time_max) + } # x_breaks if (is.null(x_breaks)) { @@ -347,15 +356,16 @@ setMethod( # Create breaks and update x_range x_breaks <- labeling::extended( m = x_n_breaks, - dmin = x_range[1], - dmax = x_range[2], - only.loose = TRUE) + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) - x_range <- c(0, tail(x_breaks, n = 1)) + x_range <- c(0.0, tail(x_breaks, n = 1L)) } # y_range - if (is.null(y_range)) y_range <- c(0, 1) + if (is.null(y_range)) y_range <- c(0.0, 1.0) # y_breaks if (is.null(y_breaks)) { @@ -364,10 +374,11 @@ setMethod( # Create breaks and update y_range y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2]) + dmin = y_range[1L], + dmax = y_range[2L] + ) - y_range <- c(0, tail(y_breaks, n = 1)) + y_range <- c(0.0, tail(y_breaks, n = 1L)) } # confidence level @@ -376,7 +387,8 @@ setMethod( x = confidence_level, var_name = "confidence_level", range = c(0.0, 1.0), - closed = c(FALSE, FALSE)) + closed = c(FALSE, FALSE) + ) # Attach to object. x@confidence_level <- confidence_level @@ -384,8 +396,8 @@ setMethod( # conf_int_style - if (length(conf_int_style) > 1) { - conf_int_style <- head(conf_int_style, n = 1) + if (length(conf_int_style) > 1L) { + conf_int_style <- head(conf_int_style, n = 1L) } # Store plots to list in case no dir_path is provided @@ -396,8 +408,8 @@ setMethod( is.null(color_by) && is.null(linetype_by) && is.null(facet_by)) { - split_by <- c("fs_method", "learner", "stratification_method") - color_by <- c("risk_group") + split_by <- c("vimp_method", "learner", "stratification_method") + color_by <- c("group") facet_by <- c("data_set") } @@ -409,8 +421,9 @@ setMethod( linetype_by = linetype_by, facet_by = facet_by, available = c( - "fs_method", "learner", "data_set", - "risk_group", "stratification_method")) + "vimp_method", "learner", "data_set", "group", "stratification_method" + ) + ) # Update splitting variables split_by <- split_var_list$split_by @@ -423,12 +436,13 @@ setMethod( user_label = legend_label, color_by = color_by, linetype_by = linetype_by, - combine_legend = combine_legend) + combine_legend = combine_legend + ) # Set show_logrank to FALSE in case color_by and linetype_by - # contain more than risk_group at most. + # contain more than group at most. if (!is.null(union(color_by, linetype_by))) { - if (!all(union(color_by, linetype_by) == "risk_group")) { + if (!all(union(color_by, linetype_by) == "group")) { show_logrank <- FALSE } } @@ -447,7 +461,8 @@ setMethod( legend_label = legend_label, plot_title = plot_title, plot_sub_title = plot_sub_title, - caption = caption) + caption = caption + ) # Create plots ------------------------------------------------------------- @@ -459,7 +474,8 @@ setMethod( data_split <- split( unique(x@data[, mget(split_by)]), by = split_by, - drop = TRUE) + drop = TRUE + ) } else { data_split <- list(NULL) @@ -473,9 +489,10 @@ setMethod( # Generate split. if (!is.null(current_split)) { x_split <- methods::new( - "familiarDataElementRiskStratification", + "predictionTableRiskGroups", x, - data = x@data[current_split, on = .NATURAL]) + data = x@data[current_split, on = .NATURAL] + ) } else { x_split <- x @@ -483,13 +500,11 @@ setMethod( if ("stratification_method" %in% split_by) { # Check that only relevant risk groups are present. - x_split@data$risk_group <- droplevels(x_split@data$risk_group) + x_split@data$group <- droplevels(x_split@data$group) } if (is_empty(x_split)) next - if (!any_predictions_valid(x_split@data, outcome_type = "survival")) { - return(NULL) - } + if (!any_predictions_valid(x_split)) next if (is.waive(plot_title)) { plot_title <- "Kaplan-Meier survival curve" @@ -498,19 +513,12 @@ setMethod( # Declare subtitle components. additional_subtitle <- NULL - # Add evaluation time as subtitle component if it is not used - # otherwise. - if (!"evaluation_time" %in% c(split_by, color_by, linetype_by, facet_by)) { - additional_subtitle <- c( - additional_subtitle, - .add_time_to_plot_subtitle(x_split@time)) - } - if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = additional_subtitle, - x = current_split) + x = current_split + ) } # Create plot @@ -540,7 +548,8 @@ setMethod( censoring = censoring, censor_shape = censor_shape, show_logrank = show_logrank, - show_survival_table = show_survival_table) + show_survival_table = show_survival_table + ) # Check empty output if (is.null(p)) next @@ -555,7 +564,8 @@ setMethod( x = x_split@data, facet_by = facet_by, facet_wrap_cols = facet_wrap_cols, - show_survival_table = show_survival_table) + show_survival_table = show_survival_table + ) # Save to file. do.call( @@ -568,10 +578,13 @@ setMethod( "type" = "stratification", "x" = current_split, "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list @@ -584,7 +597,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -616,7 +630,8 @@ setMethod( censoring, censor_shape, show_logrank, - show_survival_table) { + show_survival_table +) { # Suppress NOTES due to non-standard evaluation in data.table .NATURAL <- NULL @@ -625,33 +640,40 @@ setMethod( plot_layout_table <- .get_plot_layout_table( x = x@data, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Define the split in data required for faceting. - data_split <- split( + layout_split <- split( plot_layout_table, by = c("col_id", "row_id"), - sorted = TRUE) - + sorted = TRUE + ) + # Create plots to join figure_list <- list() extracted_element_list <- list() - for (current_split in data_split) { + for (current_split in layout_split) { # Generate the split in case there is a faceting variable. if (!is.null(facet_by)) { x_split <- methods::new( - "familiarDataElementRiskStratification", + "predictionTableRiskGroups", x, data = x@data[current_split, on = .NATURAL] ) + } else { x_split <- x } - + + # Skip if the split doesn't contain any information. + if (is_empty(x_split@data) || all(is.na(x_split@data$outcome_time))) next + # Compute strata for the current split. strata <- .compute_risk_stratification_curves( x = x_split, - time_range = x_range) + time_range = x_range + ) # Compute logrank test value. if (show_logrank) { @@ -688,20 +710,17 @@ setMethod( conf_int_alpha = conf_int_alpha, censoring = censoring, censor_shape = censor_shape, - show_logrank = show_logrank) - - # Extract plot elements from the Kaplan-Meier plot. - extracted_elements <- .extract_plot_grobs(p = p_kaplan_meier) + show_logrank = show_logrank + ) - # Remove extracted elements from the Kaplan-Meier plot. - p_kaplan_meier <- .remove_plot_grobs(p = p_kaplan_meier) - - # Rename plot elements. + # Rename plot elements and convert to gtable. g_kaplan_meier <- .rename_plot_grobs( g = .convert_to_grob(p_kaplan_meier), - extension = "main") + extension = "main" + ) + if (!gtable::is.gtable(g_kaplan_meier)) next - if (show_survival_table && gtable::is.gtable(g_kaplan_meier)) { + if (show_survival_table) { # Survival tables p_survival_table <- .create_survival_table_subplot( x = strata, @@ -710,48 +729,51 @@ setMethod( ggtheme = ggtheme, discrete_palette = discrete_palette, x_range = x_range, - x_breaks = x_breaks) - - # Extract survival gtable, which consists of the panel and the left axis. - g_survival_table <- .gtable_extract( + x_breaks = x_breaks + ) + + # Convert to gtable + g_survival_table <- .rename_plot_grobs( g = .convert_to_grob(p_survival_table), - element = c("panel", "axis-l"), - partial_match = TRUE) - - # Insert survival table into the kaplan-meier table. Use partial matching - # to match elements from g_survival_table with those in g_kaplan_meier. + extension = "surv" + ) + + # Insert panel-surv below xlab-b-main. + g_kaplan_meier <- .gtable_insert( + g = g_kaplan_meier, + g_new = .gtable_extract_grob(g_survival_table, element = "panel-surv"), + where = c("below", "xlab-b-main"), + grob_name = "panel-surv", + spacer = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "y") + ) + + # Insert axis-l-surv at the intersection of panel-surv and axis-l-main g_kaplan_meier <- .gtable_insert( g = g_kaplan_meier, - g_new = g_survival_table, - where = "bottom", - ref_element = "xlab-b-main", - partial_match = TRUE) + g_new = .gtable_extract_grob(g_survival_table, element = "axis-l-surv"), + grob_name = "axis-l-surv", + where = c("intersect", "below", "axis-l-main", "left", "panel-surv") + ) } - # Add combined grob to list - figure_list <- c(figure_list, list(g_kaplan_meier)) - - # Add extract elements to the extracted_element_list - extracted_element_list <- c(extracted_element_list, list(extracted_elements)) + # Attach to figure list. + figure_list[[paste0(current_split$row_id, ".", current_split$col_id)]] <- as_familiar_plot( + g = g_kaplan_meier, + layout = current_split + ) } - - # Update the layout table. Note that the axis text and labels share the same - # behaviour. - plot_layout_table <- .update_plot_layout_table( + + # Compose the final figure. Magic. + g <- .compose_figure( + figure_list = figure_list, plot_layout_table = plot_layout_table, - grobs = figure_list, x_text_shared = x_label_shared, x_label_shared = x_label_shared, y_text_shared = y_label_shared, y_label_shared = y_label_shared, - facet_wrap_cols = facet_wrap_cols) - - # Combine features. - g <- .arrange_plot_grobs( - grobs = figure_list, - plot_layout_table = plot_layout_table, - element_grobs = extracted_element_list, - ggtheme = ggtheme) + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme + ) return(g) } @@ -782,9 +804,10 @@ setMethod( conf_int_alpha, censoring, censor_shape, - show_logrank) { + show_logrank +) { # Suppress NOTES due to non-standard evaluation in data.table - n_censor <- risk_group_1 <- NULL + n_censor <- group_1 <- NULL if (!is_empty(x)) x <- x@data if (!is_empty(h)) h <- h@data @@ -795,7 +818,8 @@ setMethod( color_by = color_by, linetype_by = linetype_by, discrete_palette = discrete_palette, - combine_legend = combine_legend) + combine_legend = combine_legend + ) # Extract data x <- guide_list$data @@ -805,7 +829,10 @@ setMethod( data = x, mapping = ggplot2::aes( x = !!sym("time"), - y = !!sym("survival"))) + y = !!sym("survival") + ) + ) + p <- p + ggtheme # Create step function @@ -813,17 +840,29 @@ setMethod( p <- p + ggplot2::geom_step() } else if (!is.null(color_by) && is.null(linetype_by)) { - p <- p + ggplot2::geom_step(mapping = ggplot2::aes( - colour = !!sym("color_breaks"))) + p <- p + ggplot2::geom_step( + mapping = ggplot2::aes( + colour = !!sym("color_breaks") + ), + show.legend = TRUE + ) } else if (is.null(color_by) && !is.null(linetype_by)) { - p <- p + ggplot2::geom_step(mapping = ggplot2::aes( - linetype = !!sym("linetype_breaks"))) + p <- p + ggplot2::geom_step( + mapping = ggplot2::aes( + linetype = !!sym("linetype_breaks") + ), + show.legend = TRUE + ) } else { - p <- p + ggplot2::geom_step(mapping = ggplot2::aes( - colour = !!sym("color_breaks"), - linetype = !!sym("linetype_breaks"))) + p <- p + ggplot2::geom_step( + mapping = ggplot2::aes( + colour = !!sym("color_breaks"), + linetype = !!sym("linetype_breaks") + ), + show.legend = TRUE + ) } # Set colour @@ -835,13 +874,15 @@ setMethod( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } # Set line style @@ -853,13 +894,15 @@ setMethod( name = legend_label$guide_linetype, values = g_linetype$linetype_values, breaks = g_linetype$linetype_breaks, - drop = FALSE) + drop = FALSE + ) } if (show_logrank && !is_empty(h)) { # Parse p-value p_value_label <- paste0( - "p: ", as.character(signif(h[risk_group_1 == "all"]$p_value, 2))) + "p: ", as.character(signif(h[group_1 == "all"]$p_value, 2L)) + ) # Obtain default settings. text_settings <- .get_plot_geom_text_settings(ggtheme = ggtheme) @@ -867,46 +910,59 @@ setMethod( # Show in plot p <- p + ggplot2::annotate( "text", - x = x_range[1], - y = y_range[1], + x = x_range[1L], + y = y_range[1L], label = p_value_label, colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, size = text_settings$geom_text_size, vjust = "inward", - hjust = "inward") + hjust = "inward" + ) } - + # Plot confidence intervals - if (conf_int_style[1] != "none" && !is_empty(x)) { - if (conf_int_style[1] == "step") { + if (conf_int_style[1L] != "none" && !is_empty(x)) { + if (conf_int_style[1L] == "step") { if (is.null(color_by)) { - p <- p + ggplot2::geom_step(mapping = ggplot2::aes( - y = !!sym("ci_low"), - linetype = "ci_up", - na.rm = TRUE)) - - p <- p + ggplot2::geom_step(mapping = ggplot2::aes( - y = !!sym("ci_low"), - linetype = "ci_up", - na.rm = TRUE)) + p <- p + ggplot2::geom_step( + mapping = ggplot2::aes( + y = !!sym("ci_low") + ), + linetype = "dashed", + na.rm = TRUE + ) + + p <- p + ggplot2::geom_step( + mapping = ggplot2::aes( + y = !!sym("ci_up") + ), + linetype = "dashed", + na.rm = TRUE + ) } else { - p <- p + ggplot2::geom_step(mapping = ggplot2::aes( - y = !!sym("ci_low"), - linetype = "ci_up", - colour = !!sym("color_breaks"), - na.rm = TRUE)) - - p <- p + ggplot2::geom_step(mapping = ggplot2::aes( - y = !!sym("ci_low"), - linetype = "ci_up", - colour = !!sym("color_breaks"), - na.rm = TRUE)) + p <- p + ggplot2::geom_step( + mapping = ggplot2::aes( + y = !!sym("ci_low"), + colour = !!sym("color_breaks") + ), + linetype = "dashed", + na.rm = TRUE + ) + + p <- p + ggplot2::geom_step( + mapping = ggplot2::aes( + y = !!sym("ci_up"), + colour = !!sym("color_breaks") + ), + linetype = "dashed", + na.rm = TRUE + ) } - } else if (conf_int_style[1] == "ribbon") { + } else if (conf_int_style[1L] == "ribbon") { if (is.null(color_by)) { # Create special data for ribbon so that it becomes a step ribbon. x_ribbon <- .prepare_km_conf_int_plot_data(x = x) @@ -916,15 +972,18 @@ setMethod( mapping = ggplot2::aes( x = !!sym("time"), ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), + ymax = !!sym("ci_up") + ), alpha = conf_int_alpha, - na.rm = TRUE) + na.rm = TRUE + ) } else { # Create special data for ribbon so that it becomes a step ribbon. x_ribbon <- data.table::rbindlist(lapply( split(x, by = "color_breaks"), - .prepare_km_conf_int_plot_data)) + .prepare_km_conf_int_plot_data + )) p <- p + ggplot2::geom_ribbon( data = x_ribbon, @@ -932,9 +991,12 @@ setMethod( x = !!sym("time"), ymin = !!sym("ci_low"), ymax = !!sym("ci_up"), - fill = !!sym("color_breaks")), + fill = !!sym("color_breaks") + ), alpha = conf_int_alpha, - na.rm = TRUE) + na.rm = TRUE, + show.legend = TRUE + ) } } } @@ -943,18 +1005,21 @@ setMethod( if (censoring) { if (is.null(color_by)) { p <- p + ggplot2::geom_point( - data = x[n_censor > 0], + data = x[n_censor > 0L], shape = censor_shape, - show.legend = FALSE) + show.legend = FALSE + ) } else { p <- p + ggplot2::geom_point( - data = x[n_censor > 0], + data = x[n_censor > 0L], mapping = ggplot2::aes( colour = !!sym("color_breaks"), - fill = !!sym("color_breaks")), + fill = !!sym("color_breaks") + ), shape = censor_shape, - show.legend = FALSE) + show.legend = FALSE + ) } } @@ -968,13 +1033,15 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Determine how things are facetted. facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -983,20 +1050,20 @@ setMethod( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } } # Plot to Cartesian coordinates. - p <- p + ggplot2::coord_cartesian( - xlim = x_range, - ylim = y_range) + p <- p + ggplot2::coord_cartesian(xlim = x_range, ylim = y_range) return(p) } @@ -1010,7 +1077,8 @@ setMethod( ggtheme, discrete_palette, x_range, - x_breaks) { + x_breaks +) { # Suppress NOTES due to non-standard evaluation in data.table id <- missing_entry <- NULL @@ -1019,7 +1087,8 @@ setMethod( # Parse the table to obtain group sizes at x_breaks survival_table <- ..get_survival_breakpoints( x@data, - x_breaks = x_breaks) + x_breaks = x_breaks + ) survival_table[, ":="("group_name" = "")] @@ -1028,12 +1097,14 @@ setMethod( survival_list <- lapply( split(x@data, by = c(color_by, linetype_by)), ..get_survival_breakpoints, - x_breaks = x_breaks) + x_breaks = x_breaks + ) # Combine into list survival_table <- data.table::rbindlist( survival_list, - use.names = TRUE) + use.names = TRUE + ) unique_vars <- unique(c(color_by, linetype_by)) @@ -1041,32 +1112,37 @@ setMethod( guide_table <- data.table::data.table(expand.grid(lapply( rev(unique_vars), function(ii, x) (levels(x[[ii]])), - x = survival_table))) + x = survival_table + ))) # Rename variables data.table::setnames( x = guide_table, - rev(unique_vars)) + rev(unique_vars) + ) # Convert to factors for (ii in unique_vars) { guide_table[[ii]] <- factor( x = guide_table[[ii]], - levels = levels(x@data[[ii]])) + levels = levels(x@data[[ii]]) + ) } # Order columns according to unique_vars data.table::setcolorder( x = guide_table, - neworder = unique_vars) + neworder = unique_vars + ) # Order data set by columns data.table::setorderv( x = guide_table, - cols = unique_vars) + cols = unique_vars + ) # Set breaks - breaks <- apply(guide_table, 1, paste, collapse = ", ") + breaks <- apply(guide_table, 1L, paste, collapse = ", ") # Update guide_table guide_table$group_name <- factor(breaks, levels = breaks) @@ -1081,25 +1157,28 @@ setMethod( x = x, y = y, by = by, - all = FALSE))) + all = FALSE + ))) }, y = survival_table, - by = unique_vars) + by = unique_vars + ) if (any(guide_table$missing_entry)) { # Find a suitable prototype and then create a prototype table. - available_prototype <- head(guide_table[missing_entry == FALSE]$id, 1) + available_prototype <- head(guide_table[missing_entry == FALSE]$id, 1L) proto_table <- merge( x = survival_table, - y = guide_table[id == available_prototype, mget(unique_vars)]) + y = guide_table[id == available_prototype, mget(unique_vars)] + ) # Iterate over missing entries. new_survival_list <- lapply( split(guide_table[missing_entry == TRUE], by = "id"), function(x, proto_table, unique_vars) { # Make a copy of the prototype and replace the group size by 0. - y <- data.table::copy(proto_table)[, "group_size" := 0] + y <- data.table::copy(proto_table)[, "group_size" := 0L] # Insert the correct values for each plotting variable that was # previously missing. @@ -1110,24 +1189,28 @@ setMethod( return(y) }, proto_table = proto_table, - unique_vars = unique_vars) + unique_vars = unique_vars + ) # Add the placeholder entries to the table. survival_table <- data.table::rbindlist( c(list(survival_table), new_survival_list), - use.names = TRUE) + use.names = TRUE + ) # Remove superfluous columns from guide_table guide_table[, ":="( "id" = NULL, - "missing_entry" = NULL)] + "missing_entry" = NULL + )] } # Combine the guide table with the survival table to add in the group names. survival_table <- merge( x = survival_table, y = guide_table, - by = unique_vars) + by = unique_vars + ) } # Obtain default settings. @@ -1142,23 +1225,28 @@ setMethod( mapping = ggplot2::aes( x = !!sym("time"), y = !!sym("group_name"), - label = !!sym("group_size"))) + label = !!sym("group_size") + ) + ) # Annotate survival in strata. p <- p + ggplot2::geom_text( colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, - size = text_settings$geom_text_size) + size = text_settings$geom_text_size + ) # Adapt axes. p <- p + ggplot2::scale_x_continuous( breaks = x_breaks, - limits = x_range) + limits = x_range + ) p <- p + ggplot2::scale_y_discrete( breaks = rev(levels(survival_table$group_name)), - limits = rev(levels(survival_table$group_name))) + limits = rev(levels(survival_table$group_name)) + ) # Set main theme p <- p + ggtheme @@ -1172,7 +1260,8 @@ setMethod( axis.text.x = ggplot2::element_blank(), axis.ticks.x = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank()) + axis.title.y = ggplot2::element_blank() + ) # Convert to gtable g <- ggplot2::ggplotGrob(p) @@ -1180,7 +1269,7 @@ setMethod( # Set the height on the panel element to n * fontsize + (n-1) * lineheight n_lines <- data.table::uniqueN(survival_table$group_name) grob_height <- n_lines * fontsize * fontsize_rel + - (n_lines - 1) * fontsize * fontsize_rel * lineheight + 4 + (n_lines - 1L) * fontsize * fontsize_rel * lineheight + 4.0 # Find the panel panel_row_t <- g$layout[g$layout$name == "panel", "t"] @@ -1189,10 +1278,10 @@ setMethod( g$heights[panel_row_t] <- grid::unit(x = grob_height, "pt") # Set to p - p$custom_grob <- list( - "heights" = list( - "name" = "panel", - "height" = grid::unit(grob_height, "pt"))) + p$custom_grob <- list("heights" = list( + "name" = "panel", + "height" = grid::unit(grob_height, "pt") + )) class(p) <- c("familiar_ggplot", class(p)) @@ -1210,19 +1299,21 @@ setMethod( x_breaks, function(break_time, x) { # Find the nearest candidate entry - candidate_entry <- data.table::copy(tail(x[time <= break_time, ], n = 1)) + candidate_entry <- data.table::copy(tail(x[time <= break_time, ], n = 1L)) # In case the number of survivors is 0, the group size is also 0. - candidate_entry[survival == 0, "group_size" := 0] + candidate_entry[survival == 0L, "group_size" := 0L] return(candidate_entry) }, - x = x) + x = x + ) # Convert to a new data.table survival_table <- data.table::rbindlist( survival_list, - use.names = TRUE) + use.names = TRUE + ) # Update time to x_breaks survival_table[, "time" := x_breaks] @@ -1236,22 +1327,24 @@ setMethod( x, facet_by, facet_wrap_cols, - show_survival_table) { + show_survival_table +) { # Obtain facetting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Set default height and width for each subplot (in cm). - default_width <- 6 - default_height <- ifelse(show_survival_table, 6, 4) + default_width <- 6.0 + default_height <- ifelse(show_survival_table, 6.0, 4.0) # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } @@ -1266,8 +1359,8 @@ setMethod( # Make sure that the surv_lower and surv_upper coordinate sets are correct. x <- data.table::copy(x)[order(time)] - y <- data.table::copy(x)[1:nrow(x) - 1] - y[, "time" := x$time[2:nrow(x)]] + y <- data.table::copy(x)[1L:(nrow(x) - 1L)] + y[, "time" := x$time[2L:nrow(x)]] # Combine and order correctly. x <- rbind(x, y)[order(time, -ci_low, -ci_up)] diff --git a/R/PlotModelPerformance.R b/R/PlotModelPerformance.R index 4a5ae989..880a1af4 100644 --- a/R/PlotModelPerformance.R +++ b/R/PlotModelPerformance.R @@ -22,12 +22,24 @@ NULL #' #' The choice for `plot_type` affects several other arguments, e.g. `color_by` #' is not used for `heatmap` and `y_axis_by` is only used by `heatmap`. -#' @param discrete_palette (*optional*) Palette to use to color the different -#' plot elements in case a value was provided to the `color_by` argument. Only -#' used when `plot_type` is not `heatmap`. +#' @param discrete_palette (*optional*) Palette for colouring plot elements +#' indicated by the `color_by` argument (if any). Only used if `plot_type` is +#' not `heatmap`. `familiar` has a default palette. Other palettes are +#' supported by the `paletteer` package, `grDevices::palette.pals()` (requires +#' R >= 4.0.0), `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, +#' `heat.colors`, `terrain.colors`, `topo.colors` and `cm.colors`, which +#' correspond to the palettes of the same name in `grDevices`. You may also +#' specify your own palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param gradient_palette (*optional*) Sequential or divergent palette used to #' color the raster in `heatmap` plots. This argument is not used for other -#' `plot_type` value. +#' `plot_type` value. `familiar` has a default palette. Other palettes are +#' supported by the `paletteer` package, `grDevices::palette.pals()` (requires +#' R >= 4.0.0), `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, +#' `heat.colors`, `terrain.colors`, `topo.colors` and `cm.colors`, which +#' correspond to the palettes of the same name in `grDevices`. You may also +#' specify your own palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param gradient_palette_range (*optional*) Numerical range used to span the #' gradient. This should be a range of two values, e.g. `c(0, 1)`. Lower or #' upper boundary can be unset by using `NA`. If not set, the full @@ -47,12 +59,12 @@ NULL #' @details This function plots model performance based on empirical bootstraps, #' using various plot representations. #' -#' Available splitting variables are: `fs_method`, `learner`, `data_set`, +#' Available splitting variables are: `vimp_method`, `learner`, `data_set`, #' `evaluation_time` (survival outcome only) and `metric`. The default for #' `heatmap` is to split by `metric`, facet by `data_set` and -#' `evaluation_time`, position `learner` along the x-axis and `fs_method` +#' `evaluation_time`, position `learner` along the x-axis and `vimp_method` #' along the y-axis. The `color_by` argument is not used. The only valid -#' options for `x_axis_by` and `y_axis_by` are `learner` and `fs_method`. +#' options for `x_axis_by` and `y_axis_by` are `learner` and `vimp_method`. #' #' For other plot types (`barplot`, `boxplot` and `violinplot`), depends on #' the number of learners and feature selection methods: @@ -64,25 +76,16 @@ NULL #' `metric`, facet by `data_set` and have `learner` along the x-axis. #' #' * *multiple feature selection methods and one learner*: the default is to -#' split by `metric`, facet by `data_set` and have `fs_method` along the +#' split by `metric`, facet by `data_set` and have `vimp_method` along the #' x-axis. #' #' * *multiple feature selection methods and learners*: the default is to split -#' by `metric`, facet by `data_set`, colour by `fs_method` and have `learner` +#' by `metric`, facet by `data_set`, colour by `vimp_method` and have `learner` #' along the x-axis. #' #' If applicable, additional faceting is performed for `evaluation_time`. #' -#' Available palettes for `discrete_palette` and `gradient_palette` are those -#' listed by `grDevices::palette.pals()` (requires R >= 4.0.0), -#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, -#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the -#' palettes of the same name in `grDevices`. If not specified, a default -#' palette based on palettes in Tableau are used. You may also specify your -#' own palette by using colour names listed by `grDevices::colors()` or -#' through hexadecimal RGB strings. -#' -#' Labeling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labeling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -116,14 +119,15 @@ setGeneric( caption = NULL, rotate_x_tick_labels = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), units = waiver(), annotate_performance = NULL, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_model_performance") } ) @@ -159,22 +163,26 @@ setMethod( caption = NULL, rotate_x_tick_labels = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), units = waiver(), annotate_performance = NULL, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "model_performance"), - list(...))) + "data_element" = "model_performance" + ), + list(...) + ) + ) return(do.call( plot_model_performance, @@ -207,7 +215,9 @@ setMethod( "height" = height, "units" = units, "annotate_performance" = annotate_performance, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -242,14 +252,15 @@ setMethod( caption = NULL, rotate_x_tick_labels = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), units = waiver(), annotate_performance = NULL, export_collection = FALSE, - ...) { + ... + ) { # Make sure the collection object is updated. object <- update_object(object = object) @@ -269,7 +280,8 @@ setMethod( .check_parameter_value_is_valid( x = plot_type, var_name = "plot_type", - values = c("heatmap", "barplot", "boxplot", "violinplot")) + values = c("heatmap", "barplot", "boxplot", "violinplot") + ) } else { # Set default to violin plot. @@ -282,7 +294,8 @@ setMethod( # Load the data. x <- export_model_performance( object = object, - aggregate_results = TRUE) + aggregate_results = TRUE + ) # Check that the data are not empty. if (is_empty(x)) return(NULL) @@ -291,24 +304,29 @@ setMethod( # Load the data. x <- export_model_performance( object = object, - aggregate_results = FALSE) + aggregate_results = FALSE + ) # Check that the data are not empty. if (is_empty(x)) return(NULL) # Check that data are disaggregated if (any(sapply(x, function(x) (x@is_aggregated)))) { - warning(paste0( + ..warning(paste0( "Creating a ", plot_type, " requires de-aggregated data, ", - "which are not available.")) + "which are not available." + )) + return(NULL) } # Check that data are not point estimates. if (all(sapply(x, function(x) (x@estimation_type == "point")))) { - warning(paste0( + ..warning(paste0( "Creating a ", plot_type, " requires bias-corrected estimates or ", - "bootstrap confidence interval estimates instead of point estimates.")) + "bootstrap confidence interval estimates instead of point estimates." + )) + return(NULL) } @@ -330,11 +348,14 @@ setMethod( if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) ..error_reached_unreachable_code( - "plot_model_performance: list of data elements contains unmerged elements.") + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_model_performance: list of data elements contains unmerged elements." + ) + } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -344,7 +365,8 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = FALSE), purpose = "to plot model performance", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -356,11 +378,13 @@ setMethod( } # Add default splitting variables. - if (is.null(split_by) && - is.null(color_by) && - is.null(facet_by) && - is.null(x_axis_by) && - is.null(y_axis_by)) { + if ( + is.null(split_by) && + is.null(color_by) && + is.null(facet_by) && + is.null(x_axis_by) && + is.null(y_axis_by) + ) { if (plot_type == "heatmap") { # Split by metric. split_by <- c("metric") @@ -373,32 +397,32 @@ setMethod( # Set y-axis variables. This splitting variable is only used in # heatmaps. - y_axis_by <- c("fs_method") + y_axis_by <- c("vimp_method") } else { - # Determine the number of learners and feature_selection methods. + # Determine the number of learners and variable importance methods. n_learner <- nlevels(x@data$learner) - n_fs_method <- nlevels(x@data$fs_method) + n_vimp_method <- nlevels(x@data$vimp_method) # Split by metric. split_by <- c("metric") # Set facetting variables. - if (n_learner > 1 || n_fs_method > 1) { + if (n_learner > 1L || n_vimp_method > 1L) { facet_by <- c("data_set") } # Set color variables. This splitting variable is only used in # non-heatmap plots. - if (n_learner > 1 && n_fs_method > 1) { - color_by <- c("fs_method") + if (n_learner > 1L && n_vimp_method > 1L) { + color_by <- c("vimp_method") } # Set x-axis variables. - if (n_learner == 1 && n_fs_method == 1) { + if (n_learner == 1L && n_vimp_method == 1L) { x_axis_by <- c("data_set") - } else if (n_learner == 1 && n_fs_method > 1) { - x_axis_by <- c("fs_method") + } else if (n_learner == 1L && n_vimp_method > 1L) { + x_axis_by <- c("vimp_method") } else { x_axis_by <- c("learner") } @@ -413,7 +437,7 @@ setMethod( # Check if the color_by argument is provided. if (!is.null(color_by)) { - warning("The color_by argument is ignored for heatmaps.") + ..warning("The color_by argument is ignored for heatmaps.") color_by <- NULL } @@ -424,13 +448,14 @@ setMethod( x_axis_by = x_axis_by, y_axis_by = y_axis_by, available = c( - "metric", "data_set", "fs_method", - "learner", split_variable) + "metric", "data_set", "vimp_method", + "learner", split_variable + ) ) } else { # Check if the y_axis_by argument is provided. if (!is.null(y_axis_by)) { - warning("The y_axis_by argument is ignored for non-heatmap plots.") + ..warning("The y_axis_by argument is ignored for non-heatmap plots.") } # Check splitting variables and generate sanitised output @@ -441,8 +466,10 @@ setMethod( facet_by = facet_by, x_axis_by = x_axis_by, available = c( - "metric", "data_set", "fs_method", - "learner", split_variable)) + "metric", "data_set", "vimp_method", + "learner", split_variable + ) + ) } # Update splitting variables @@ -457,24 +484,25 @@ setMethod( } if (plot_type == "heatmap") { - # Check that x_axis_by and y_axis_by only take fs_method or learner. - if (!x_axis_by %in% c("fs_method", "learner", "data_set", split_variable)) { - stop("The x_axis_by argument should be one of fs_method, learner or data_set.") + # Check that x_axis_by and y_axis_by only take vimp_method or learner. + if (!x_axis_by %in% c("vimp_method", "learner", "data_set", split_variable)) { + ..error("The x_axis_by argument should be one of vimp_method, learner or data_set.") } - if (!y_axis_by %in% c("fs_method", "learner", "data_set", split_variable)) { - stop("The y_axis_by argument should be one of fs_method, learner or data_set.") + if (!y_axis_by %in% c("vimp_method", "learner", "data_set", split_variable)) { + ..error("The y_axis_by argument should be one of vimp_method, learner or data_set.") } } if (is.null(x_axis_by)) { x_axis_by <- setdiff( - c("metric", "data_set", "fs_method", "learner", split_variable), - c(split_by, color_by, facet_by, y_axis_by)) - if (length(x_axis_by) == 0) stop("The x_axis_by argument should be set.") - if (length(x_axis_by) > 1 && "metric" %in% c(x_axis_by)) { + c("metric", "data_set", "vimp_method", "learner", split_variable), + c(split_by, color_by, facet_by, y_axis_by) + ) + if (length(x_axis_by) == 0L) ..error("The x_axis_by argument should be set.") + if (length(x_axis_by) > 1L && "metric" %in% c(x_axis_by)) { x_axis_by <- "metric" } else { - x_axis_by <- x_axis_by[1] + x_axis_by <- x_axis_by[1L] } } @@ -483,10 +511,11 @@ setMethod( x_label <- switch( x_axis_by, learner = "learner", - fs_method = "feature selection method", + vimp_method = "feature selection method", data_set = "dataset", metric = "metric", - evaluation_time = "time") + evaluation_time = "time" + ) } # annotate_performance @@ -498,7 +527,8 @@ setMethod( .check_parameter_value_is_valid( x = annotate_performance, var_name = "annotate_performance", - values = c("none", "value", "value_ci")) + values = c("none", "value", "value_ci") + ) .check_input_plot_args( facet_wrap_cols = facet_wrap_cols, @@ -506,7 +536,8 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Create plots ------------------------------------------------------------- @@ -518,7 +549,8 @@ setMethod( x_split <- split( x@data, by = split_by, - drop = FALSE) + drop = FALSE + ) } else { x_split <- list("null.name" = x@data) @@ -539,11 +571,13 @@ setMethod( # Add evaluation time as subtitle component if it is not used # otherwise. - if (!"evaluation_time" %in% c(split_by, color_by, facet_by) && - object@outcome_type %in% c("survival")) { + if ( + !"evaluation_time" %in% c(split_by, color_by, facet_by) && + object@outcome_type %in% c("survival") + ) { additional_subtitle <- c( additional_subtitle, - .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1]) + .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1L]) ) } @@ -551,7 +585,8 @@ setMethod( plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = additional_subtitle, - x = x_split[[ii]]) + x = x_split[[ii]] + ) } # Generate plot @@ -578,7 +613,8 @@ setMethod( y_n_breaks = y_n_breaks, y_breaks = y_breaks, annotate_performance = annotate_performance, - outcome_type = object@outcome_type) + outcome_type = object@outcome_type + ) # Check empty output if (is.null(p)) next @@ -596,7 +632,8 @@ setMethod( y_axis_by = y_axis_by, facet_by = facet_by, facet_wrap_cols = facet_wrap_cols, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Save to file. do.call( @@ -610,10 +647,13 @@ setMethod( "subtype" = plot_type, "x" = x_split[[ii]], "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list for export. @@ -626,7 +666,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -655,7 +696,8 @@ setMethod( y_n_breaks, y_breaks, annotate_performance, - outcome_type) { + outcome_type +) { # Suppress NOTES due to non-standard evaluation in data.table value <- metric <- median <- ci_low <- ci_up <- NULL @@ -669,7 +711,8 @@ setMethod( metric_ranges <- lapply( metrics, .get_metric_default_range, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Give a name to the list elements. names(metric_ranges) <- metrics @@ -683,21 +726,23 @@ setMethod( # Replace any positive infinite value by the max range in the data. if (any(metric_range == Inf)) { metric_range[metric_range == Inf] <- max( - x[metric == current_metric, value], na.rm = TRUE) + x[metric == current_metric, value], na.rm = TRUE + ) } # Replace any negative infinite value by the min range in the data. if (any(metric_range == -Inf)) { metric_range[metric_range == -Inf] <- min( - x[metric == current_metric, value], na.rm = TRUE) + x[metric == current_metric, value], na.rm = TRUE + ) } - if (y_range[1] > min(metric_range)) { - y_range[1] <- min(metric_range) + if (y_range[1L] > min(metric_range)) { + y_range[1L] <- min(metric_range) } - if (y_range[2] < max(metric_range)) { - y_range[2] <- max(metric_range) + if (y_range[2L] < max(metric_range)) { + y_range[2L] <- max(metric_range) } } } else { @@ -708,16 +753,18 @@ setMethod( if (is.null(y_breaks)) { .check_input_plot_args( y_range = y_range, - y_n_breaks = y_n_breaks) + y_n_breaks = y_n_breaks + ) # Create breaks and update x_range y_breaks <- labeling::extended( m = y_n_breaks, - dmin = y_range[1], - dmax = y_range[2], - only.loose = TRUE) + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) - y_range <- c(0, tail(y_breaks, n = 1)) + y_range <- c(0.0, tail(y_breaks, n = 1L)) } else { .check_input_plot_args(y_breaks = y_breaks) @@ -725,13 +772,14 @@ setMethod( # y_label for non-heatmap plots if (is.waive(y_label)) { - y_label <- ifelse(length(metrics) == 1, metrics, "value") + y_label <- ifelse(length(metrics) == 1L, metrics, "value") } # Create a legend label legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) } else { # y-label for heatmap plots @@ -739,35 +787,39 @@ setMethod( y_label <- switch( y_axis_by, learner = "learner", - fs_method = "feature selection method", + vimp_method = "feature selection method", data_set = "dataset", metric = "metric", - evaluation_time = "time") + evaluation_time = "time" + ) } # gradient_palette_range if (is.waive(gradient_palette_range)) { - if (length(metrics) == 1) { + if (length(metrics) == 1L) { gradient_palette_range <- .get_metric_default_range( metric = metrics, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Replace a positive infinite value by the max range in the data. - if (gradient_palette_range[2] == Inf) { - gradient_palette_range[2] <- max(x[metric == metrics, value], na.rm = TRUE) + if (gradient_palette_range[2L] == Inf) { + gradient_palette_range[2L] <- max(x[metric == metrics, value], na.rm = TRUE) } # Replace any negative infinite value by the min range in the data. - if (gradient_palette_range[1] == -Inf) { - gradient_palette_range[1] <- min(x[metric == metrics, value], na.rm = TRUE) + if (gradient_palette_range[1L] == -Inf) { + gradient_palette_range[1L] <- min(x[metric == metrics, value], na.rm = TRUE) } gradient_was_provided <- FALSE + } else { # If metric for whatever reason is not a single metric. gradient_palette_range <- c(NA, NA) gradient_was_provided <- FALSE } + } else { # Check for NULL. if (is.null(gradient_palette_range)) { @@ -778,13 +830,14 @@ setMethod( } # Create a legend label - legend_label <- ifelse(length(metrics) == 1 && is.waive(legend_label), metrics, "value") + legend_label <- ifelse(length(metrics) == 1L && is.waive(legend_label), metrics, "value") } # Check remaining input arguments. .check_input_plot_args( y_label = y_label, - legend_label = legend_label) + legend_label = legend_label + ) # Create basic plot p <- ggplot2::ggplot() @@ -794,17 +847,22 @@ setMethod( # Heatmap ------------------------------------------------------------------ # Create summary data. - x_bar <- x[, list( - "median" = stats::median(value, na.rm = TRUE), - "ci_up" = stats::quantile(value, probs = 0.975, na.rm = TRUE, names = FALSE), - "ci_low" = stats::quantile(value, probs = 0.025, na.rm = TRUE, names = FALSE)), - by = c("metric", "data_set", "fs_method", "learner")] + x_bar <- x[ + , + list( + "median" = stats::median(value, na.rm = TRUE), + "ci_up" = stats::quantile(value, probs = 0.975, na.rm = TRUE, names = FALSE), + "ci_low" = stats::quantile(value, probs = 0.025, na.rm = TRUE, names = FALSE) + ), + by = c("metric", "data_set", "vimp_method", "learner") + ] # Determine what direction a metric has. - if (length(metrics) == 1) { + if (length(metrics) == 1L) { invert_scale <- !is_higher_better( metric = metrics, - outcome_type = outcome_type) + outcome_type = outcome_type + ) } else { invert_scale <- FALSE @@ -812,11 +870,12 @@ setMethod( # Determine the type of sequential colorscale. This has no effect if the # user provides a colorscale. - if (length(metrics) == 1 && !gradient_was_provided) { + if (length(metrics) == 1L && !gradient_was_provided) { palette_type <- ifelse( - length(gradient_palette_range) > 2, + length(gradient_palette_range) > 2L, "divergent", - "sequential") + "sequential" + ) } else { palette_type <- "sequential" @@ -828,12 +887,15 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), y = !!sym(y_axis_by), - fill = !!sym("median"))) + fill = !!sym("median") + ) + ) # Colors gradient_colours <- .get_palette( x = gradient_palette, - palette_type = palette_type) + palette_type = palette_type + ) if (invert_scale) gradient_colours <- rev(gradient_colours) @@ -841,7 +903,8 @@ setMethod( p <- p + ggplot2::scale_fill_gradientn( name = legend_label, colors = gradient_colours, - limits = range(gradient_palette_range)) + limits = range(gradient_palette_range) + ) # Obtain default settings. text_settings <- .get_plot_geom_text_settings(ggtheme = ggtheme) @@ -849,7 +912,7 @@ setMethod( # Show performance value as text. if (annotate_performance == "value") { # Show median value. - x_bar[is.finite(median), "performance_text" := .format_plot_number(median)] + x_bar[is.finite(median), "performance_text" := .format_plot_number(median, min_common_base = 0L)] # Add to figure. p <- p + ggplot2::geom_text( @@ -857,21 +920,27 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), y = !!sym(y_axis_by), - label = !!sym("performance_text")), + label = !!sym("performance_text") + ), colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, - size = text_settings$geom_text_size) + size = text_settings$geom_text_size + ) } else if (annotate_performance == "value_ci") { # Show median value and credibility interval - x_bar[is.finite(median), "performance_text" := paste0( - .format_plot_number(median), - "\n(", - .format_plot_number(ci_low), - "\u2013", - .format_plot_number(ci_up), - ")")] + x_bar[ + is.finite(median), + "performance_text" := paste0( + .format_plot_number(median), + "\n(", + .format_plot_number(ci_low), + "\u2013", + .format_plot_number(ci_up), + ")" + ) + ] # Add to figure. p <- p + ggplot2::geom_text( @@ -879,28 +948,35 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), y = !!sym(y_axis_by), - label = !!sym("performance_text")), + label = !!sym("performance_text") + ), colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, - size = text_settings$geom_text_size) + size = text_settings$geom_text_size + ) } } else if (plot_type == "barplot") { # Barplot ------------------------------------------------------------------ # Create data for bar - x_bar <- x[, list( - "median" = stats::median(value, na.rm = TRUE), - "ci_up" = stats::quantile(value, probs = 0.975, na.rm = TRUE, names = FALSE), - "ci_low" = stats::quantile(value, probs = 0.025, na.rm = TRUE, names = FALSE)), - by = c("metric", "data_set", "fs_method", "learner")] + x_bar <- x[ + , + list( + "median" = stats::median(value, na.rm = TRUE), + "ci_up" = stats::quantile(value, probs = 0.975, na.rm = TRUE, names = FALSE), + "ci_low" = stats::quantile(value, probs = 0.025, na.rm = TRUE, names = FALSE) + ), + by = c("metric", "data_set", "vimp_method", "learner") + ] # Generate a guide table guide_list <- .create_plot_guide_table( x = x_bar, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x_bar <- guide_list$data @@ -914,9 +990,11 @@ setMethod( data = x_bar, mapping = ggplot2::aes( x = !!sym(x_axis_by), - y = !!sym("median")), + y = !!sym("median") + ), stat = "identity", - position = "dodge") + position = "dodge" + ) # Add error bars p <- p + ggplot2::geom_errorbar( @@ -924,9 +1002,11 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), + ymax = !!sym("ci_up") + ), position = ggplot2::position_dodge(width = 0.9), - width = 0.20) + width = 0.20 + ) } else { # Extract guide_table for color @@ -938,9 +1018,11 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), y = !!sym("median"), - fill = !!sym("color_breaks")), + fill = !!sym("color_breaks") + ), stat = "identity", - position = ggplot2::position_dodge(width = 0.9)) + position = ggplot2::position_dodge(width = 0.9) + ) # Add error bars p <- p + ggplot2::geom_errorbar( @@ -949,16 +1031,19 @@ setMethod( x = !!sym(x_axis_by), ymin = !!sym("ci_low"), ymax = !!sym("ci_up"), - group = !!sym("color_breaks")), + group = !!sym("color_breaks") + ), position = ggplot2::position_dodge(width = 0.9), - width = 0.20) + width = 0.20 + ) # Set fill colours. p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } # Plot to Cartesian coordinates. @@ -971,7 +1056,8 @@ setMethod( guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- guide_list$data @@ -985,8 +1071,10 @@ setMethod( data = x, mapping = ggplot2::aes( x = !!sym(x_axis_by), - y = !!sym("value")), - outlier.alpha = 0.1) + y = !!sym("value") + ), + outlier.alpha = 0.1 + ) } else { # Extract guide_table for color @@ -998,15 +1086,18 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), y = !!sym("value"), - colour = !!sym("color_breaks")), - outlier.alpha = 0.1) + colour = !!sym("color_breaks") + ), + outlier.alpha = 0.1 + ) # Set fill colours. p <- p + ggplot2::scale_colour_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } # Plot to Cartesian coordinates. @@ -1019,7 +1110,8 @@ setMethod( guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- guide_list$data @@ -1033,10 +1125,13 @@ setMethod( data = x, mapping = ggplot2::aes( x = !!sym(x_axis_by), - y = !!sym("value")), - draw_quantiles = c(0.025, 0.5, 0.975), + y = !!sym("value") + ), + quantiles = c(0.025, 0.5, 0.975), + quantile.linetype = ggtheme$line$linetype, scale = "width", - position = ggplot2::position_dodge(width = 1.0)) + position = ggplot2::position_dodge(width = 1.0) + ) } else { # Extract guide_table for color @@ -1048,17 +1143,21 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), y = !!sym("value"), - fill = !!sym("color_breaks")), - draw_quantiles = c(0.025, 0.5, 0.975), + fill = !!sym("color_breaks") + ), + quantiles = c(0.025, 0.5, 0.975), + quantile.linetype = ggtheme$line$linetype, scale = "width", - position = ggplot2::position_dodge(width = 1.0)) + position = ggplot2::position_dodge(width = 1.0) + ) # Set fill colours. p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } # Plot to Cartesian coordinates. @@ -1069,7 +1168,8 @@ setMethod( facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -1077,12 +1177,14 @@ setMethod( p <- p + ggplot2::facet_grid( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, - labeller = "label_context") + labeller = "label_context" + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, - labeller = "label_context") + labeller = "label_context" + ) } } @@ -1092,7 +1194,8 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Rotate x-axis ticks if (rotate_x_tick_labels) { @@ -1100,7 +1203,9 @@ setMethod( axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } return(p) @@ -1115,13 +1220,15 @@ setMethod( y_axis_by, facet_by, facet_wrap_cols, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Obtain facetting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Determine the number of elements along the x-axis. x_elements <- as.character(unique(x[[x_axis_by]])) @@ -1155,14 +1262,14 @@ setMethod( # Assume each x-axis element takes up about 0.8 cm. Then add some room for # other plot elements. default_width <- x_n_elements * 0.8 + 1.0 - default_width <- max(c(4, default_width)) + default_width <- max(c(4.0, default_width)) # Set default height. - default_height <- 4 + default_height <- 4.0 # Set tick space for the x-axis and y-axis. Assume that the y-axis tick # labels contain 4 digits. - y_tick_space <- 4 * 0.18 + y_tick_space <- 4.0 * 0.18 # For the x-axis we only reserve extra space in case the ticks are rotated, # otherwise we just assume a typical height of 10 points (3.6 mm). @@ -1170,10 +1277,10 @@ setMethod( } # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height + x_tick_space, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height + x_tick_space, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width + y_tick_space, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width + y_tick_space, 19.0)) return(c(height, width)) } diff --git a/R/PlotPermutationVariableImportance.R b/R/PlotPermutationVariableImportance.R index 0aec4922..d2be8eab 100644 --- a/R/PlotPermutationVariableImportance.R +++ b/R/PlotPermutationVariableImportance.R @@ -16,8 +16,6 @@ NULL #' saved to. Output is saved in the `variable_importance` subdirectory. If #' NULL no figures are saved, but are returned instead. #' @param ggtheme (*optional*) `ggplot` theme to use for plotting. -#' @param discrete_palette (*optional*) Palette used to fill the bars in case a -#' non-singular variable was provided to the `color_by` argument. #' @param height (*optional*) Height of the plot. A default value is derived #' from the number of features and the number of facets. #' @param width (*optional*) Width of the plot. A default value is derived from @@ -40,7 +38,7 @@ NULL #' The following splitting variables are available for `split_by`, `color_by` #' and `facet_by`: #' -#' * `fs_method`: feature selection methods. +#' * `vimp_method`: variable importance methods. #' #' * `learner`: learners. #' @@ -53,19 +51,11 @@ NULL #' * `similarity_threshold`: the similarity threshold used to identify groups #' of features to permute simultaneously. #' -#' By default, the data is split by `fs_method`, `learner` and `metric`, +#' By default, the data is split by `vimp_method`, `learner` and `metric`, #' faceted by `data_set` and `evaluation_time`, and coloured by #' `similarity_threshold`. #' -#' Available palettes for `discrete_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. -#' -#' Labelling methods such as `set_fs_method_names` or `set_feature_names` can +#' Labelling methods such as `set_vimp_method_names` or `set_feature_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -113,16 +103,18 @@ setGeneric( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, conf_int_style = c("point_line", "line", "bar_line", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_permutation_variable_importance") } ) @@ -151,24 +143,29 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, conf_int_style = c("point_line", "line", "bar_line", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, args = c( list( "object" = object, - "data_element" = "permutation_vimp"), - list(...))) + "data_element" = "permutation_vimp" + ), + list(...) + ) + ) return(do.call( plot_permutation_variable_importance, @@ -188,6 +185,7 @@ setMethod( "plot_title" = plot_title, "plot_sub_title" = plot_sub_title, "caption" = caption, + "limit_n_features" = limit_n_features, "x_range" = x_range, "x_n_breaks" = x_n_breaks, "x_breaks" = x_breaks, @@ -196,7 +194,9 @@ setMethod( "width" = width, "height" = height, "units" = units, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -224,16 +224,18 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, conf_int_style = c("point_line", "line", "bar_line", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), export_collection = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table value <- ci_low <- ci_up <- NULL @@ -245,7 +247,8 @@ setMethod( # Get input data. x <- export_permutation_vimp( object = object, - aggregate_results = TRUE) + aggregate_results = TRUE + ) # Check that the data are not empty (e.g. NULL). if (is_empty(x)) return(NULL) @@ -260,11 +263,14 @@ setMethod( if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) ..error_reached_unreachable_code( - "plot_model_performance: list of data elements contains unmerged elements.") + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_model_performance: list of data elements contains unmerged elements." + ) + } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -274,7 +280,8 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = FALSE), purpose = "to create permutation variable importance plots", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } @@ -282,8 +289,8 @@ setMethod( ggtheme <- .check_ggtheme(ggtheme) # conf_int_style - if (length(conf_int_style) > 1) { - conf_int_style <- head(conf_int_style, n = 1) + if (length(conf_int_style) > 1L) { + conf_int_style <- head(conf_int_style, n = 1L) } # Set the style of the confidence interval to none, in case no confidence @@ -306,6 +313,7 @@ setMethod( levels = similarity_values, labels = format(x = similarity_values, nsmall = 1L) ) + } else if (all(is.infinite(x@data$similarity_threshold))) { # This happens when data is not based on fixed cuts of a dendrogram. x@data$similarity_threshold <- factor( @@ -317,14 +325,15 @@ setMethod( # Remove unused levels. x@data$similarity_threshold <- droplevels(x@data$similarity_threshold) } else { - stop(paste0( + ..error(paste0( "Combinations of results from different types of clustering algorithms ", - "cannot plotted in one figure.")) + "cannot plotted in one figure." + )) } # Set default splitting variables if none are provided. if (is.null(split_by) && is.null(color_by) && is.null(facet_by)) { - split_by <- c("fs_method", "learner", "metric") + split_by <- c("vimp_method", "learner", "metric") facet_by <- c("data_set") if (object@outcome_type %in% c("survival")) { @@ -336,7 +345,8 @@ setMethod( # Set available splitting variables. available_splitting_variables <- c( - "fs_method", "learner", "data_set", "metric", "similarity_threshold") + "vimp_method", "learner", "data_set", "metric", "similarity_threshold" + ) if (object@outcome_type %in% c("survival")) { available_splitting_variables <- c(available_splitting_variables, "evaluation_time") } @@ -347,7 +357,8 @@ setMethod( split_by = split_by, color_by = color_by, facet_by = facet_by, - available = available_splitting_variables) + available = available_splitting_variables + ) # Update splitting variables split_by <- split_var_list$split_by @@ -358,27 +369,31 @@ setMethod( if (is.waive(legend_label)) { legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) # Update "similarity threshold" in the legend label to be more specific. if (!is.null(color_by)) { if (grepl( pattern = "similarity threshold", x = legend_label$guide_color, - fixed = TRUE)) { + fixed = TRUE + )) { if (all(levels(x@data$similarity_threshold) %in% c("clustered", "individual"))) { legend_label$guide_color <- sub( pattern = "similarity threshold", replacement = "clustering", x = legend_label$guide_color, - fixed = TRUE) + fixed = TRUE + ) } else { legend_label$guide_color <- sub( pattern = "similarity threshold", replacement = "threshold", x = legend_label$guide_color, - fixed = TRUE) + fixed = TRUE + ) } } } @@ -396,8 +411,9 @@ setMethod( function(x, outcome_type) { if (!is_higher_better( - metric = as.character(x$metric[1]), - outcome_type = outcome_type)) { + metric = as.character(x$metric[1L]), + outcome_type = outcome_type + )) { # For metrics where lower scores mark better model performance, a # feature is more important when the variable importance is more # negative. @@ -409,11 +425,13 @@ setMethod( data.table::setnames( x = x, old = c("ci_low", "ci_up"), - new = c("ci_up", "ci_low")) + new = c("ci_up", "ci_low") + ) x[, ":="( "ci_low" = -ci_low, - "ci_up" = -ci_up)] + "ci_up" = -ci_up + )] } } @@ -425,7 +443,8 @@ setMethod( # Recombine dataset. x@data <- data.table::rbindlist( x@data, - use.names = TRUE) + use.names = TRUE + ) if ("metric" %in% facet_by || "metric" %in% color_by) { available_metrics <- "combined" @@ -464,7 +483,8 @@ setMethod( x_range <- data.table::rbindlist(x_range) x_range <- list("combined" = data.table::data.table( "min_value" = min(x_range$min_value, na.rm = TRUE), - "max_value" = max(x_range$max_value, na.rm = TRUE))) + "max_value" = max(x_range$max_value, na.rm = TRUE) + )) } } else if (is.list(x_range)) { @@ -472,13 +492,15 @@ setMethod( .check_parameter_value_is_valid( x = names(x_range), var_name = "x_range", - values = available_metrics) + values = available_metrics + ) .check_argument_length( x = unique(names(x_range)), var_name = "x_range", min = length(available_metrics), - max = length(available_metrics)) + max = length(available_metrics) + ) # Convert to the correct x_range <- lapply( @@ -488,8 +510,10 @@ setMethod( return(data.table::data.table( "min_value" = min(x_range), - "max_value" = max(x_range))) - }) + "max_value" = max(x_range) + )) + } + ) } else { # For user-provided input. @@ -501,9 +525,11 @@ setMethod( function(metric, x_range) { return(data.table::data.table( "min_value" = min(x_range), - "max_value" = max(x_range))) + "max_value" = max(x_range) + )) }, - x_range = x_range) + x_range = x_range + ) # Update names of the list elements names(x_range) <- available_metrics @@ -522,31 +548,36 @@ setMethod( m = x_n_breaks, dmin = x_range$min_value, dmax = x_range$max_value, - only.loose = TRUE) + only.loose = TRUE + ) return(x_breaks) }, - x_n_breaks = x_n_breaks) + x_n_breaks = x_n_breaks + ) } else if (is.list(x_breaks)) { # Check whether all metrics are present in the data provided by the user. .check_parameter_value_is_valid( x = names(x_breaks), var_name = "x_breaks", - values = available_metrics) + values = available_metrics + ) .check_argument_length( x = unique(names(x_breaks)), var_name = "x_breaks", min = length(available_metrics), - max = length(available_metrics)) + max = length(available_metrics) + ) # Check breaks. sapply( x_breaks, function(x_breaks) { .check_input_plot_args(x_breaks = x_breaks) - }) + } + ) } else { .check_input_plot_args(x_breaks = x_breaks) @@ -556,13 +587,14 @@ setMethod( x_range <- lapply( available_metrics, function(metric, x_range, x_breaks) { - x_range[[metric]]$min_value <- head(x_breaks[[metric]], n = 1) - x_range[[metric]]$max_value <- tail(x_breaks[[metric]], n = 1) + x_range[[metric]]$min_value <- head(x_breaks[[metric]], n = 1L) + x_range[[metric]]$max_value <- tail(x_breaks[[metric]], n = 1L) return(x_range[[metric]]) }, x_range = x_range, - x_breaks = x_breaks) + x_breaks = x_breaks + ) # Set names. names(x_range) <- available_metrics @@ -577,7 +609,9 @@ setMethod( facet_wrap_cols = facet_wrap_cols, conf_int_alpha = conf_int_alpha, conf_int_style = conf_int_style, - conf_int_default = c("point_line", "line", "bar_line", "none")) + conf_int_default = c("point_line", "line", "bar_line", "none"), + limit_n_features = limit_n_features + ) # Create plots ------------------------------------------------------------- @@ -609,11 +643,13 @@ setMethod( # Add evaluation time as subtitle component if it is not used # otherwise. - if (!"evaluation_time" %in% c(split_by, color_by, facet_by) && - object@outcome_type %in% c("survival")) { + if ( + !"evaluation_time" %in% c(split_by, color_by, facet_by) && + object@outcome_type %in% c("survival") + ) { additional_subtitle <- c( additional_subtitle, - .add_time_to_plot_subtitle(x_sub$evaluation_time[1]) + .add_time_to_plot_subtitle(x_sub$evaluation_time[1L]) ) } @@ -621,7 +657,8 @@ setMethod( plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = additional_subtitle, - x = x_sub) + x = x_sub + ) } # Generate plot @@ -638,10 +675,12 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, + limit_n_features = limit_n_features, conf_int_alpha = conf_int_alpha, conf_int_style = conf_int_style, x_range = x_range, - x_breaks = x_breaks) + x_breaks = x_breaks + ) # Check empty output if (is.null(p)) next @@ -655,7 +694,8 @@ setMethod( def_plot_dims <- .determine_permutation_importance_plot_dimensions( x = x_sub, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Save to file. do.call( @@ -669,10 +709,13 @@ setMethod( "subtype" = "permutation", "x" = x_sub, "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list and export @@ -685,7 +728,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -712,13 +756,15 @@ setMethod( plot_title, plot_sub_title, caption, + limit_n_features, conf_int_style, conf_int_alpha, x_range, - x_breaks) { + x_breaks +) { # Suppress NOTES due to non-standard evaluation in data.table value <- metric <- similarity_threshold <- order_id <- i.order_id <- NULL - data_set <- learner <- fs_method <- NULL + data_set <- learner <- vimp_method <- NULL # Create local copy x <- data.table::copy(x) @@ -729,7 +775,7 @@ setMethod( if ("metric" %in% facet_by || "metric" %in% color_by) { x_label <- "variable importance" } else { - x_label <- as.character(x$metric[1]) + x_label <- as.character(x$metric[1L]) } } @@ -740,7 +786,7 @@ setMethod( if ("metric" %in% color_by || "metric" %in% facet_by) { available_metric <- "combined" } else { - available_metric <- as.character(x$metric[1]) + available_metric <- as.character(x$metric[1L]) } # Sort features. In the outer loop iterate over metrics. In the inner loop @@ -751,7 +797,7 @@ setMethod( # Break in case all features have an unique order id. if (data.table::uniqueN(x$order_id) == data.table::uniqueN(x$feature)) break - for (current_fs_method in levels(x$fs_method)) { + for (current_vimp_method in levels(x$vimp_method)) { # Break in case all features have an unique order id. if (data.table::uniqueN(x$order_id) == data.table::uniqueN(x$feature)) break @@ -764,15 +810,18 @@ setMethod( if (data.table::uniqueN(x$order_id) == data.table::uniqueN(x$feature)) break for (current_threshold in rev(levels(x$similarity_threshold))) { - for (id_table in split(x[ - data_set == current_data_set & - fs_method == current_fs_method & - learner == current_learner & - metric == current_metric & - similarity_threshold == current_threshold], - by = "order_id")) { + for (id_table in split( + x[ + data_set == current_data_set & + vimp_method == current_vimp_method & + learner == current_learner & + metric == current_metric & + similarity_threshold == current_threshold + ], + by = "order_id" + )) { - if (nrow(id_table) < 2) next + if (nrow(id_table) < 2L) next # Local copy id_table <- data.table::copy(id_table) @@ -792,17 +841,24 @@ setMethod( } } } - + + # Limit the number of features appearing in the plot. + if (is.numeric(limit_n_features)) { + x <- x[order_id <= limit_n_features] + } + # Order features by order_id x$feature <- factor( x = x$feature, - levels = rev(unique(x[, mget(c("feature", "order_id"))])[order(order_id)][["feature"]])) + levels = rev(unique(x[, mget(c("feature", "order_id"))])[order(order_id)][["feature"]]) + ) # Generate a guide table guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- guide_list$data @@ -818,14 +874,17 @@ setMethod( mapping = ggplot2::aes( x = !!sym("feature"), y = !!sym("value"), - fill = !!sym("color_breaks"))) + fill = !!sym("color_breaks") + ) + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, guide = ggplot2::guide_legend(reverse = TRUE), - drop = FALSE) + drop = FALSE + ) } else if (conf_int_style %in% c("bar_line")) { p <- ggplot2::ggplot( @@ -834,21 +893,25 @@ setMethod( x = !!sym("feature"), y = !!sym("value"), fill = !!sym("color_breaks"), - color = !!sym("color_breaks"))) + color = !!sym("color_breaks") + ) + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, guide = ggplot2::guide_legend(reverse = TRUE), - drop = FALSE) + drop = FALSE + ) p <- p + ggplot2::scale_colour_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, guide = ggplot2::guide_legend(reverse = TRUE), - drop = FALSE) + drop = FALSE + ) } else if (conf_int_style %in% c("line", "point_line")) { p <- ggplot2::ggplot( @@ -856,24 +919,32 @@ setMethod( mapping = ggplot2::aes( x = !!sym("feature"), y = !!sym("value"), - color = !!sym("color_breaks"))) + color = !!sym("color_breaks") + ) + ) p <- p + ggplot2::scale_colour_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, guide = ggplot2::guide_legend(reverse = TRUE), - drop = FALSE) + drop = FALSE + ) } else { ..error_reached_unreachable_code( - ".plot_permutation_variable_importance: unknown confidence interval style.") + ".plot_permutation_variable_importance: unknown confidence interval style." + ) } } else { # Basic plot. - p <- ggplot2::ggplot(data = x, mapping = ggplot2::aes( - x = !!sym("feature"), - y = !!sym("value"))) + p <- ggplot2::ggplot( + data = x, + mapping = ggplot2::aes( + x = !!sym("feature"), + y = !!sym("value") + ) + ) } # Add theme. @@ -883,13 +954,16 @@ setMethod( if (conf_int_style %in% c("bar_line")) { p <- p + ggplot2::geom_col( alpha = conf_int_alpha, - position = "dodge") + position = "dodge" + ) p <- p + ggplot2::geom_linerange( mapping = ggplot2::aes( ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), - position = ggplot2::position_dodge(width = 0.9)) + ymax = !!sym("ci_up") + ), + position = ggplot2::position_dodge(width = 0.9) + ) } else if (conf_int_style %in% c("none")) { p <- p + ggplot2::geom_col(position = "dodge") @@ -898,19 +972,24 @@ setMethod( p <- p + ggplot2::geom_linerange( mapping = ggplot2::aes( ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), - position = ggplot2::position_dodge(width = 0.8)) + ymax = !!sym("ci_up") + ), + position = ggplot2::position_dodge(width = 0.8) + ) } else if (conf_int_style %in% c("point_line")) { p <- p + ggplot2::geom_pointrange( mapping = ggplot2::aes( ymin = !!sym("ci_low"), - ymax = !!sym("ci_up")), - position = ggplot2::position_dodge(width = 0.9)) + ymax = !!sym("ci_up") + ), + position = ggplot2::position_dodge(width = 0.9) + ) } else { ..error_reached_unreachable_code( - ".plot_permutation_variable_importance: unknown confidence interval style.") + ".plot_permutation_variable_importance: unknown confidence interval style." + ) } # Set breaks and limits @@ -926,7 +1005,8 @@ setMethod( facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -934,20 +1014,23 @@ setMethod( p <- p + ggplot2::facet_grid( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, - labeller = "label_context") + labeller = "label_context" + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, - labeller = "label_context") + labeller = "label_context" + ) } } # Add a line to indicate 0.0, if 0.0 is included in the range. - if (x_range[1] <= 0.0 && x_range[2] >= 0.0) { + if (x_range[1L] <= 0.0 && x_range[2L] >= 0.0) { p <- p + ggplot2::geom_hline( yintercept = 0.0, - linetype = "dotted") + linetype = "dotted" + ) } # Update labels. Note that the inversion of x_label and y_label is correct, as @@ -957,7 +1040,8 @@ setMethod( y = x_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) return(p) } @@ -967,12 +1051,14 @@ setMethod( .determine_permutation_importance_plot_dimensions <- function( x, facet_by, - facet_wrap_cols) { + facet_wrap_cols +) { # Get plot layout dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Determine the number of features within each facet. n_features <- data.table::uniqueN(x = x$feature) @@ -980,17 +1066,17 @@ setMethod( # Assume each feature takes up about 14 points (~5mm) with 2 point (0.7mm) # spacing. Then add some room for other plot elements. - default_height <- n_features * 0.5 + (n_features - 1) * 0.07 + 1.0 + default_height <- n_features * 0.5 + (n_features - 1L) * 0.07 + 1.0 # Set a default height. Assume that the typical width of a character is about # 5 points (1.8mm). - default_width <- 6 + longest_name * 0.18 + default_width <- 6.0 + longest_name * 0.18 # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } diff --git a/R/PlotSampleClustering.R b/R/PlotSampleClustering.R index a76196ad..2d9624b3 100644 --- a/R/PlotSampleClustering.R +++ b/R/PlotSampleClustering.R @@ -16,21 +16,28 @@ NULL #' plots are saved to. Output is saved in the `feature_similarity` #' subdirectory. If `NULL` no figures are saved, but are returned instead. #' @param gradient_palette (*optional*) Sequential or divergent palette used to -#' colour the similarity or distance between features in a heatmap. +#' colour the similarity or distance between features in a heatmap. `familiar` +#' has a default palette. Other palettes are supported by the `paletteer` +#' package, `grDevices::palette.pals()` (requires R >= 4.0.0), +#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, +#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the +#' palettes of the same name in `grDevices`. You may also specify your own +#' palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param gradient_palette_range (*optional*) Numerical range used to span the #' gradient. This should be a range of two values, e.g. `c(0, 1)`. Lower or #' upper boundary can be unset by using `NA`. If not set, the full #' metric-specific range is used. -#' @param outcome_palette (*optional*) Sequential (`continuous`, `count` -#' outcomes) or qualitative (other outcome types) palette used to show outcome -#' values. This argument is ignored if the outcome is not shown. +#' @param outcome_palette (*optional*) Sequential (`continuous` outcomes) or +#' qualitative (other outcome types) palette used to show outcome values. This +#' argument is ignored if the outcome is not shown. #' @param outcome_palette_range (*optional*) Numerical range used to span the -#' gradient of numeric (`continuous`, `count`) outcome values. This argument -#' is ignored for other outcome types or if the outcome is not shown. +#' gradient of numeric (`continuous`) outcome values. This argument is ignored +#' for other outcome types or if the outcome is not shown. #' @param outcome_legend_label (*optional*) Label to provide to the legend for #' outcome data. If NULL, the legend will not have a name. By default, #' `class`, `value` and `event` are used for `binomial` and `multinomial`, -#' `continuous` and `count`, and `survival` outcome types, respectively. +#' `continuous`, and `survival` outcome types, respectively. #' @param show_feature_dendrogram (*optional*) Show feature dendrogram around #' the main panel. Can be `TRUE`, `FALSE`, `NULL`, or a position, i.e. `top`, #' `bottom`, `left` and `right`. @@ -106,10 +113,10 @@ NULL #' #' @details This function generates area under the ROC curve plots. #' -#' Available splitting variables are: `fs_method`, `learner`, and `data_set`. -#' By default, the data is split by `fs_method` and `learner` and `data_set`, +#' Available splitting variables are: `vimp_method`, `learner`, and `data_set`. +#' By default, the data is split by `vimp_method` and `learner` and `data_set`, #' since the number of samples will typically differ between data sets, even -#' for the same feature selection method and learner. +#' for the same variable importance method and learner. #' #' The `x_axis_by` and `y_axis_by` arguments determine what data are shown #' along which axis. Each argument takes one of `feature` and `sample`, and @@ -120,17 +127,12 @@ NULL #' ordering of features may differ between facets, and tick labels are #' maintained for each panel. #' -#' Available palettes for `gradient_palette` are those listed by -#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` -#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, -#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same -#' name in `grDevices`. If not specified, a default palette based on palettes -#' in Tableau are used. You may also specify your own palette by using colour -#' names listed by `grDevices::colors()` or through hexadecimal RGB strings. -#' -#' Labeling methods such as `set_fs_method_names` or `set_data_set_names` can +#' Labeling methods such as `set_vimp_method_names` or `set_data_set_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. +#' +#' This plot can be created from `dataObject`, or `data.table` objects. +#' For `data.table`, see \code{\link{as_data_object}} for additional arguments. #' #' @return `NULL` or list of plot objects, if `dir_path` is `NULL`. #' @@ -168,10 +170,10 @@ setGeneric( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 3, + x_n_breaks = 3L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_feature_dendrogram = TRUE, @@ -186,7 +188,8 @@ setGeneric( units = waiver(), export_collection = FALSE, verbose = TRUE, - ...) { + ... + ) { standardGeneric("plot_sample_clustering") } ) @@ -228,10 +231,10 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 3, + x_n_breaks = 3L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_feature_dendrogram = TRUE, @@ -246,7 +249,8 @@ setMethod( units = waiver(), export_collection = FALSE, verbose = TRUE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, @@ -258,8 +262,11 @@ setMethod( "feature_cluster_method" = feature_cluster_method, "feature_linkage_method" = feature_linkage_method, "sample_cluster_method" = sample_cluster_method, - "sample_linkage_method" = sample_linkage_method), - list(...))) + "sample_linkage_method" = sample_linkage_method + ), + list(...) + ) + ) return(do.call( plot_sample_clustering, @@ -308,7 +315,9 @@ setMethod( "height" = height, "units" = units, "export_collection" = export_collection, - "verbose" = verbose))) + "verbose" = verbose + ) + )) } ) @@ -349,10 +358,10 @@ setMethod( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 3, + x_n_breaks = 3L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_feature_dendrogram = TRUE, @@ -367,7 +376,8 @@ setMethod( units = waiver(), export_collection = FALSE, verbose = TRUE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table .NATURAL <- NULL @@ -377,7 +387,8 @@ setMethod( # Get feature expression data feature_expression <- export_feature_expressions( object = object, - evaluation_time = evaluation_times) + evaluation_time = evaluation_times + ) # Get feature similarity data. feature_similarity <- export_feature_similarity( @@ -386,7 +397,7 @@ setMethod( feature_linkage_method = feature_linkage_method, export_dendrogram = FALSE, export_ordered_data = FALSE - )[[1]] + )[[1L]] # Get feature similarity data. sample_similarity <- export_sample_similarity( @@ -394,7 +405,7 @@ setMethod( sample_limit = sample_limit, sample_cluster_method = sample_cluster_method, sample_linkage_method = sample_linkage_method - )[[1]] + )[[1L]] # Check that the data are not empty. if (is_empty(feature_expression)) return(NULL) @@ -407,12 +418,14 @@ setMethod( feature_expression, function(x) { return(unique(x@data[, mget(x@grouping_column)])) - }) + } + ) # Combine to table. identifier_table <- data.table::rbindlist( identifier_table, - use.names = TRUE) + use.names = TRUE + ) # Add row identifiers to make it easier to track the list elements for # feature expression. @@ -486,10 +499,13 @@ setMethod( # Assign default label to the if (object@outcome_type %in% c("binomial", "multinomial")) { outcome_legend_label <- "class" - } else if (object@outcome_type %in% c("continuous", "count")) { + } else if (object@outcome_type %in% c("continuous")) { outcome_legend_label <- "value" } else if (object@outcome_type %in% c("survival", "competing_risk")) { outcome_legend_label <- "event" + } else if (object@outcome_type == "unsupervised") { + outcome_legend_label <- "unset" + show_outcome <- FALSE } else { ..error_outcome_type_not_implemented(object@outcome_type) } @@ -498,20 +514,22 @@ setMethod( # check outcome_legend_label .check_input_plot_label( label_var = outcome_legend_label, - var_name = "outcome_legend_label") + var_name = "outcome_legend_label" + ) # x_axis_by and y_axis_by available_axis_variables <- c("feature", "sample") if (is.null(x_axis_by) && is.null(y_axis_by)) { # Set both variables. - x_axis_by <- available_axis_variables[1] - y_axis_by <- available_axis_variables[2] + x_axis_by <- available_axis_variables[1L] + y_axis_by <- available_axis_variables[2L] } else if (is.null(x_axis_by)) { .check_parameter_value_is_valid( x = y_axis_by, var_name = "y_axis_by", - values = available_axis_variables) + values = available_axis_variables + ) x_axis_by <- setdiff(available_axis_variables, y_axis_by) @@ -519,35 +537,42 @@ setMethod( .check_parameter_value_is_valid( x = x_axis_by, var_name = "x_axis_by", - values = available_axis_variables) + values = available_axis_variables + ) y_axis_by <- setdiff(available_axis_variables, x_axis_by) } else { .check_parameter_value_is_valid( x = x_axis_by, var_name = "x_axis_by", - values = available_axis_variables) + values = available_axis_variables + ) .check_parameter_value_is_valid( x = y_axis_by, var_name = "y_axis_by", - values = available_axis_variables) + values = available_axis_variables + ) } .check_value_not_shared( x_axis_by, y_axis_by, - "x_axis_by", "y_axis_by") + "x_axis_by", "y_axis_by" + ) # Check length of x_axis_by and y_axis_by variables. .check_argument_length( x = x_axis_by, var_name = "x_axis_by", - min = 1, max = 1) + min = 1L, + max = 1L + ) .check_argument_length( x = y_axis_by, var_name = "y_axis_by", - min = 1, - max = 1) + min = 1L, + max = 1L + ) # show_feature_dendrogram if (is.logical(show_feature_dendrogram)) { @@ -557,7 +582,7 @@ setMethod( show_feature_dendrogram <- NULL } - } else if (length(show_feature_dendrogram) == 0) { + } else if (length(show_feature_dendrogram) == 0L) { show_feature_dendrogram <- NULL } else { @@ -565,20 +590,23 @@ setMethod( .check_parameter_value_is_valid( x = show_feature_dendrogram, var_name = "show_feature_dendrogram", - values = c("top", "bottom")) + values = c("top", "bottom") + ) } else { .check_parameter_value_is_valid( x = show_feature_dendrogram, var_name = "show_feature_dendrogram", - values = c("left", "right")) + values = c("left", "right") + ) } .check_argument_length( x = show_feature_dendrogram, var_name = "show_feature_dendrogram", - min = 1, - max = 1) + min = 1L, + max = 1L + ) } # Check that the data allows for creating a dendrogram. @@ -596,7 +624,7 @@ setMethod( show_sample_dendrogram <- NULL } - } else if (length(show_sample_dendrogram) == 0) { + } else if (length(show_sample_dendrogram) == 0L) { show_sample_dendrogram <- NULL } else { @@ -604,20 +632,23 @@ setMethod( .check_parameter_value_is_valid( x = show_sample_dendrogram, var_name = "show_sample_dendrogram", - values = c("top", "bottom")) + values = c("top", "bottom") + ) } else { .check_parameter_value_is_valid( x = show_sample_dendrogram, var_name = "show_sample_dendrogram", - values = c("left", "right")) + values = c("left", "right") + ) } .check_argument_length( x = show_sample_dendrogram, var_name = "show_sample_dendrogram", - min = 1, - max = 1) + min = 1L, + max = 1L + ) } # Check that the data allows for creating a dendrogram. @@ -631,18 +662,20 @@ setMethod( if (!is.null(show_sample_dendrogram) || !is.null(show_feature_dendrogram)) { .check_plot_grid_unit( x = dendrogram_height, - var_name = "dendrogram_height") + var_name = "dendrogram_height" + ) } # Check if show_outcome is specified correctly. if (is.logical(show_outcome)) { if (show_outcome) { show_outcome <- ifelse(x_axis_by == "sample", "top", "left") + } else { show_outcome <- NULL } - } else if (length(show_outcome) == 0) { + } else if (length(show_outcome) == 0L) { show_outcome <- NULL } else { @@ -650,34 +683,38 @@ setMethod( .check_parameter_value_is_valid( x = show_outcome, var_name = "show_outcome", - values = c("top", "bottom")) + values = c("top", "bottom") + ) } else { .check_parameter_value_is_valid( x = show_outcome, var_name = "show_outcome", - values = c("left", "right")) + values = c("left", "right") + ) } .check_argument_length( x = show_outcome, var_name = "show_outcome", - min = 1, - max = 1) + min = 1L, + max = 1L + ) } # Check if the outcome_height argument is correct. if (!is.null(show_outcome)) { .check_plot_grid_unit( x = outcome_height, - var_name = "outcome_height") + var_name = "outcome_height" + ) } # Add default splitting variables if (is.null(split_by) & is.null(facet_by)) { - # Split by feature selection method and learner - split_by <- c("fs_method", "learner", "data_set") + # Split by variable importance method, learner and data set + split_by <- c("vimp_method", "learner", "data_set") - # Facet by dataset + # Do not use facets. facet_by <- NULL } @@ -686,7 +723,8 @@ setMethod( x = identifier_table, split_by = split_by, facet_by = facet_by, - available = c("data_set", "fs_method", "learner")) + available = c("data_set", "vimp_method", "learner") + ) # Update splitting variables split_by <- split_var_list$split_by @@ -701,7 +739,8 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Create plots ------------------------------------------------- @@ -713,7 +752,8 @@ setMethod( x_split <- split( identifier_table, by = split_by, - drop = FALSE) + drop = FALSE + ) } else { x_split <- list("null.name" = identifier_table) @@ -738,12 +778,14 @@ setMethod( feature_similarity_split <- methods::new( "familiarDataElementFeatureSimilarity", feature_similarity, - data = feature_similarity@data[x_sub, on = .NATURAL, nomatch = NULL]) + data = feature_similarity@data[x_sub, on = .NATURAL, nomatch = NULL] + ) # Add similarity metric. additional_subtitle <- c( additional_subtitle, - list("metric (features)" = feature_similarity_split@similarity_metric)) + list("metric (features)" = feature_similarity_split@similarity_metric) + ) } # Select data for sample similarity @@ -752,12 +794,14 @@ setMethod( sample_similarity_split <- methods::new( "familiarDataElementSampleSimilarity", sample_similarity, - data = sample_similarity@data[x_sub, on = .NATURAL, nomatch = NULL]) + data = sample_similarity@data[x_sub, on = .NATURAL, nomatch = NULL] + ) # Add similarity metric. additional_subtitle <- c( additional_subtitle, - list("metric (samples)" = sample_similarity_split@similarity_metric)) + list("metric (samples)" = sample_similarity_split@similarity_metric) + ) } if (is.waive(plot_title)) plot_title <- "Sample clustering" @@ -766,7 +810,8 @@ setMethod( plot_sub_title <- .create_plot_subtitle( split_by = split_by, additional = additional_subtitle, - x = x_sub) + x = x_sub + ) } # Generate plot @@ -806,7 +851,8 @@ setMethod( show_normalised_data = show_normalised_data, show_outcome = show_outcome, dendrogram_height = dendrogram_height, - outcome_height = outcome_height) + outcome_height = outcome_height + ) # Check empty output if (is.null(p)) next @@ -835,7 +881,8 @@ setMethod( samples = samples, show_feature_dendrogram = show_feature_dendrogram, show_sample_dendrogram = show_sample_dendrogram, - rotate_x_tick_labels = rotate_x_tick_labels) + rotate_x_tick_labels = rotate_x_tick_labels + ) # Save to file. do.call( @@ -848,10 +895,14 @@ setMethod( "type" = "sample_clustering", "x" = x_sub, "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) + } else { # Store as list for export. plot_list <- c(plot_list, list(p)) @@ -863,7 +914,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -905,7 +957,8 @@ setMethod( show_normalised_data, show_outcome, dendrogram_height, - outcome_height) { + outcome_height +) { # Suppress NOTES due to non-standard evaluation in data.table .NATURAL <- NULL @@ -933,7 +986,8 @@ setMethod( # dataset. normalisation_method <- sapply( data@feature_info, - function(feature) (feature@normalisation_parameters@method)) + function(feature) (.optional_from_slot(feature@normalisation_parameters, "method", alternative = "standardisation_winsor")) + ) return(unname(normalisation_method)) } @@ -950,18 +1004,21 @@ setMethod( # Find the default value. gradient_palette_range <- .get_default_normalisation_range_for_plotting( - norm_method = normalisation_method) + norm_method = normalisation_method + ) } else if (show_normalised_data == "set_normalisation") { # By default show range -3 to 3 standard deviations gradient_palette_range <- .get_default_normalisation_range_for_plotting( - norm_method = "standardisation_winsor") + norm_method = "standardisation_winsor" + ) } else { ..error_reached_unreachable_code(paste0( ".plot_sample_clustering_plot: encountered unknown value for ", "show_normalised_data: ", - show_normalised_data)) + show_normalised_data + )) } } else if (is.null(gradient_palette_range)) { @@ -973,19 +1030,21 @@ setMethod( data <- lapply( data, .normalise_expression_data, - show_normalised_data = show_normalised_data) + show_normalised_data = show_normalised_data + ) # Ensure that a gradient palette range is set. This is required because the # legend is shared between all facets and . - if (any(!is.finite(gradient_palette_range))) { + if (!all(is.finite(gradient_palette_range))) { # Iterate over expression data to find minimum and maximum feature_ranges <- lapply( data, function(data) { if (is_empty(data)) { return(data.table::data.table( - "min_value" = numeric(0), - "max_value" = numeric(0))) + "min_value" = numeric(0L), + "max_value" = numeric(0L) + )) } # Find feature value ranges in the current expression data. @@ -998,20 +1057,23 @@ setMethod( feature_data <- x[[feature@name]] feature_data <- feature_data[is.finite(feature_data)] - if (length(feature_data) == 0) { + if (length(feature_data) == 0L) { return(data.table::data.table( - "min_value" = numeric(0), - "max_value" = numeric(0))) + "min_value" = numeric(0L), + "max_value" = numeric(0L) + )) } else { return(data.table::data.table( "min_value" = as.double(min(feature_data, na.rm = FALSE)), - "max_value" = as.double(max(feature_data, na.rm = FALSE)))) + "max_value" = as.double(max(feature_data, na.rm = FALSE)) + )) } } else { return(data.table::data.table( - "min_value" = numeric(0), - "max_value" = numeric(0))) + "min_value" = numeric(0L), + "max_value" = numeric(0L) + )) } }, x = data@data @@ -1020,7 +1082,8 @@ setMethod( # Combine ranges for all features. feature_ranges <- data.table::rbindlist( feature_ranges, - use.names = TRUE) + use.names = TRUE + ) return(feature_ranges) } @@ -1029,34 +1092,29 @@ setMethod( # Combine ranges feature_ranges <- data.table::rbindlist( feature_ranges, - use.names = TRUE) + use.names = TRUE + ) if (is_empty(feature_ranges)) { # Set a default if all features are categorical. gradient_palette_range <- c(-1.0, 0.0, 1.0) + } else { # Find a nice range for missing values of the palette range. gradient_palette_range <- .format_plot_number_nice_range( input_range = gradient_palette_range, x = c( min(feature_ranges$min_value), - max(feature_ranges$max_value))) + max(feature_ranges$max_value) + ) + ) } } # outcome_palette_range and outcome_plot_data -------------------------------- - # Set outcome_palette_range for continuous and count outcome types. - if (is.waive(outcome_palette_range) && - outcome_type %in% c("continuous", "count") && - !is.null(show_outcome)) { - if (outcome_type == "continuous") { - outcome_palette_range <- c(NA, NA) - } else if (outcome_type == "count") { - outcome_palette_range <- c(0.0, NA) - } - - } else if (is.waive(outcome_palette_range)) { + # Set outcome_palette_range for continuous outcome types. + if (is.waive(outcome_palette_range)) { outcome_palette_range <- c(NA, NA) } @@ -1076,8 +1134,7 @@ setMethod( evaluation_times = evaluation_times ) } else { - outcome_plot_data <- .process_expression_generic_outcome( - x = data@data) + outcome_plot_data <- .process_expression_generic_outcome(x = data@data) } return(outcome_plot_data) @@ -1089,27 +1146,32 @@ setMethod( } # Update the outcome palette range based on data present. - if (any(!is.finite(outcome_palette_range)) && - outcome_type %in% c("continuous", "count") && - !is.null(show_outcome)) { + if ( + !all(is.finite(outcome_palette_range)) && + outcome_type %in% c("continuous") && + !is.null(show_outcome) + ) { # Iterate over outcome_plot_data to find minimum and maximum values. outcome_ranges <- lapply( outcome_plot_data, function(x) { if (is_empty(x)) { return(data.table::data.table( - "min_value" = numeric(0), - "max_value" = numeric(0))) + "min_value" = numeric(0L), + "max_value" = numeric(0L) + )) - } else if (all(!is.finite(x$value))) { + } else if (!any(is.finite(x$value))) { return(data.table::data.table( - "min_value" = numeric(0), - "max_value" = numeric(0))) + "min_value" = numeric(0L), + "max_value" = numeric(0L) + )) } else { return(data.table::data.table( "min_value" = as.double(min(x$value, na.rm = TRUE)), - "max_value" = as.double(max(x$value, na.rm = TRUE)))) + "max_value" = as.double(max(x$value, na.rm = TRUE)) + )) } } ) @@ -1117,7 +1179,8 @@ setMethod( # Combine outcome ranges outcome_ranges <- data.table::rbindlist( outcome_ranges, - use.names = TRUE) + use.names = TRUE + ) if (is_empty(outcome_ranges)) { # Set a default if all features are categorical. @@ -1128,7 +1191,9 @@ setMethod( input_range = outcome_palette_range, x = c( min(outcome_ranges$min_value), - max(outcome_ranges$max_value))) + max(outcome_ranges$max_value) + ) + ) } } @@ -1142,19 +1207,21 @@ setMethod( plot_layout_table <- .get_plot_layout_table( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Define the split in data required for faceting. - data_split <- split( + layout_split <- split( plot_layout_table, by = c("col_id", "row_id"), - sorted = TRUE) + sorted = TRUE + ) # Create plots to join figure_list <- list() extracted_element_list <- list() - for (current_split in data_split) { + for (current_split in layout_split) { # Get current split on the identifier table. if (is.null(facet_by)) { x_split <- x @@ -1167,15 +1234,18 @@ setMethod( outcome_plot_data_split <- outcome_plot_data[x_split$list_id] # Check data for a single facet is present. - if (length(expression_data_split) > 1 || - length(outcome_plot_data_split) > 1) { + if ( + length(expression_data_split) > 1L || + length(outcome_plot_data_split) > 1L + ) { ..error_reached_unreachable_code( - ".plot_sample_clustering_plot: cannot process data from multiple facets simultaneously.") + ".plot_sample_clustering_plot: cannot process data from multiple facets simultaneously." + ) } # Extract data elements from list. - expression_data_split <- expression_data_split[[1]] - outcome_plot_data_split <- outcome_plot_data_split[[1]] + expression_data_split <- expression_data_split[[1L]] + outcome_plot_data_split <- outcome_plot_data_split[[1L]] # Split feature similarity. if (is.null(facet_by) || is_empty(feature_similarity)) { @@ -1185,7 +1255,8 @@ setMethod( feature_similarity_split <- methods::new( "familiarDataElementFeatureSimilarity", feature_similarity, - data = feature_similarity@data[current_split, on = .NATURAL, nomatch = NULL]) + data = feature_similarity@data[current_split, on = .NATURAL, nomatch = NULL] + ) } # Split sample_similarity. @@ -1196,7 +1267,8 @@ setMethod( sample_similarity_split <- methods::new( "familiarDataElementSampleSimilarity", sample_similarity, - data = sample_similarity@data[current_split, on = .NATURAL, nomatch = NULL]) + data = sample_similarity@data[current_split, on = .NATURAL, nomatch = NULL] + ) } # Add cluster objects to feature and sample similarity data. @@ -1208,7 +1280,8 @@ setMethod( x = expression_data_split, feature_similarity = feature_similarity_split, sample_similarity = sample_similarity_split, - gradient_palette_range = gradient_palette_range) + gradient_palette_range = gradient_palette_range + ) # Create expression heatmap p_heatmap <- .create_expression_heatmap( @@ -1228,27 +1301,27 @@ setMethod( caption = caption, rotate_x_tick_labels = rotate_x_tick_labels, show_feature_dendrogram = show_feature_dendrogram, - show_sample_dendrogram = show_sample_dendrogram) - - # Extract plot elements from the heatmap. - extracted_elements <- .extract_plot_grobs(p = p_heatmap) - - # Remove extracted elements from the heatmap. - p_heatmap <- .remove_plot_grobs(p = p_heatmap) - - # Rename plot elements. + show_sample_dendrogram = show_sample_dendrogram + ) + + # Convert to gtable and append "main" to grob names. g_heatmap <- .rename_plot_grobs( g = .convert_to_grob(p_heatmap), - extension = "main") + extension = "main" + ) + if (!gtable::is.gtable(g_heatmap)) next # Add sample dendogram if (!is.null(sample_similarity_split)) { - if (!is.null(show_sample_dendrogram) && - inherits(sample_similarity_split@dendrogram, "hclust")) { + if ( + !is.null(show_sample_dendrogram) && + inherits(sample_similarity_split@dendrogram, "hclust") + ) { # Obtain dendogram plotting data as line segments. dendro_data <- .convert_dendrogram_to_table( h = sample_similarity_split@dendrogram, - similarity_metric = sample_similarity_split@similarity_metric) + similarity_metric = sample_similarity_split@similarity_metric + ) # Find the right axes settings. if (show_sample_dendrogram %in% c("left", "right")) { @@ -1270,37 +1343,70 @@ setMethod( dist_n_breaks = dist_n_breaks, dist_breaks = dist_breaks, plot_height = dendrogram_height, - rotate_x_tick_labels = rotate_x_tick_labels) - - # Determine the axis element - axis_element <- ifelse(show_sample_dendrogram %in% c("top", "bottom"), "axis-l", "axis-b") + rotate_x_tick_labels = rotate_x_tick_labels + ) - # Extract dendrogram gtable, which consists of the panel and the height - # axis. - g_sample_dendro <- .gtable_extract( + dendro_extension <- paste0("dendro-", show_sample_dendrogram) + panel_element_name <- paste0("panel-", dendro_extension) + axis_element_name <- ifelse(show_sample_dendrogram %in% c("top", "bottom"), "axis-l", "axis-b") + axis_element_name <- paste0(axis_element_name, "-", dendro_extension) + + # Convert to gtable + g_dendro <- .rename_plot_grobs( g = .convert_to_grob(p_dendro), - element = c("panel", axis_element), - partial_match = TRUE) - - # Insert the dendrogram at the position correct position around the - # heatmap. + extension = dendro_extension + ) + + where_panel <- switch( + show_sample_dendrogram, + "top" = c("above", "panel-main"), + "bottom" = c("below", "panel-main"), + "left" = c("left", "panel-main"), + "right" = c("right", "panel-main") + ) + + # Insert panel-main next to panel-dendro. + g_heatmap <- .gtable_insert( + g = g_heatmap, + g_new = .gtable_extract_grob(g_dendro, element = panel_element_name), + where = where_panel, + grob_name = panel_element_name, + spacer = .get_plot_panel_spacing( + ggtheme = ggtheme, + axis = ifelse(show_sample_dendrogram %in% c("top", "bottom"), "y", "x") + ) + ) + + where_axis_element <- switch( + show_sample_dendrogram, + "top" = c("intersect", "above", "axis-l-main", "left", panel_element_name), + "bottom" = c("intersect", "below", "axis-l-main", "left", panel_element_name), + "left" = c("intersect", "below", panel_element_name, "left", "axis-b-main"), + "right" = c("intersect", "below", panel_element_name, "right", "axis-b-main") + ) + + # Insert the axis element at the intersect of dendro-panel and the + # corresponding axis element of the main plot. g_heatmap <- .gtable_insert( g = g_heatmap, - g_new = g_sample_dendro, - where = show_sample_dendrogram, - ref_element = "panel-main", - partial_match = TRUE) + g_new = .gtable_extract_grob(g_dendro, element = axis_element_name), + where = where_axis_element, + grob_name = axis_element_name + ) } } # Add feature dendrogram if (!is.null(feature_similarity_split)) { - if (!is.null(show_feature_dendrogram) && - inherits(feature_similarity_split@dendrogram, "hclust")) { + if ( + !is.null(show_feature_dendrogram) && + inherits(feature_similarity_split@dendrogram, "hclust") + ) { # Obtain dendrogram plotting data as line segments. dendro_data <- .convert_dendrogram_to_table( h = feature_similarity_split@dendrogram, - similarity_metric = feature_similarity_split@similarity_metric) + similarity_metric = feature_similarity_split@similarity_metric + ) # Find the right axes settings. if (show_feature_dendrogram %in% c("left", "right")) { @@ -1322,26 +1428,56 @@ setMethod( dist_n_breaks = dist_n_breaks, dist_breaks = dist_breaks, plot_height = dendrogram_height, - rotate_x_tick_labels = rotate_x_tick_labels) - - # Determine the axis element - axis_element <- ifelse(show_feature_dendrogram %in% c("top", "bottom"), "axis-l", "axis-b") + rotate_x_tick_labels = rotate_x_tick_labels + ) - # Extract dendodram gtable, which consists of the panel and the height - # axis. - g_feature_dendro <- .gtable_extract( + dendro_extension <- paste0("dendro-", show_feature_dendrogram) + panel_element_name <- paste0("panel-", dendro_extension) + axis_element_name <- ifelse(show_feature_dendrogram %in% c("top", "bottom"), "axis-l", "axis-b") + axis_element_name <- paste0(axis_element_name, "-", dendro_extension) + + # Convert to gtable + g_dendro <- .rename_plot_grobs( g = .convert_to_grob(p_dendro), - element = c("panel", axis_element), - partial_match = TRUE) - - # Insert the dendrogram at the position correct position around the - # heatmap. + extension = dendro_extension + ) + + where_panel <- switch( + show_feature_dendrogram, + "top" = c("above", "panel-main"), + "bottom" = c("below", "panel-main"), + "left" = c("left", "panel-main"), + "right" = c("right", "panel-main") + ) + + # Insert panel-main next to panel-dendro. g_heatmap <- .gtable_insert( g = g_heatmap, - g_new = g_feature_dendro, - where = show_feature_dendrogram, - ref_element = "panel-main", - partial_match = TRUE) + g_new = .gtable_extract_grob(g_dendro, element = panel_element_name), + where = where_panel, + grob_name = panel_element_name, + spacer = .get_plot_panel_spacing( + ggtheme = ggtheme, + axis = ifelse(show_feature_dendrogram %in% c("top", "bottom"), "y", "x") + ) + ) + + where_axis_element <- switch( + show_feature_dendrogram, + "top" = c("intersect", "above", "axis-l-main", "left", panel_element_name), + "bottom" = c("intersect", "below", "axis-l-main", "left", panel_element_name), + "left" = c("intersect", "below", panel_element_name, "left", "axis-b-main"), + "right" = c("intersect", "below", panel_element_name, "right", "axis-b-main") + ) + + # Insert the axis element at the intersect of dendro-panel and the + # corresponding axis element of the main plot. + g_heatmap <- .gtable_insert( + g = g_heatmap, + g_new = .gtable_extract_grob(g_dendro, element = axis_element_name), + where = where_axis_element, + grob_name = axis_element_name + ) } } @@ -1357,75 +1493,76 @@ setMethod( outcome_legend_label = outcome_legend_label, plot_height = outcome_height, sample_similarity = sample_similarity_split, - rotate_x_tick_labels = rotate_x_tick_labels) - - # Convert to grob - g_outcome <- .convert_to_grob(p_outcome) - - # Extract guide from grob - g_outcome_guide <- .gtable_extract( - g = g_outcome, - element = "guide", - partial_match = TRUE) - - if (outcome_type %in% c("survival", "competing_risk")) { - # Determine the axis element - axis_element <- ifelse(show_outcome %in% c("top", "bottom"), "axis-l", "axis-b") - - # Define extracted outcome elements. - extracted_outcome_elements <- c("panel", axis_element) - - } else { - extracted_outcome_elements <- c("panel") - } - - # Extract the main plot elements from the outcome columns/rows - g_outcome <- .gtable_extract( - g = g_outcome, - element = extracted_outcome_elements, - partial_match = TRUE) + rotate_x_tick_labels = rotate_x_tick_labels + ) - # Insert the outcome at the position correct position around the heatmap. + # Convert to gtable + g_outcome <- .rename_plot_grobs( + g = .convert_to_grob(p_outcome), + extension = "outcome" + ) + axis_element_name <- ifelse(show_outcome %in% c("top", "bottom"), "axis-l-outcome", "axis-b-outcome") + + where_panel <- switch( + show_outcome, + "top" = c("above", "panel-main"), + "bottom" = c("below", "panel-main"), + "left" = c("left", "panel-main"), + "right" = c("right", "panel-main") + ) + + # Insert panel-main next to panel-outcome. g_heatmap <- .gtable_insert( g = g_heatmap, - g_new = g_outcome, - where = show_outcome, - ref_element = "panel-main", - partial_match = TRUE) + g_new = .gtable_extract_grob(g_outcome, element = "panel-outcome"), + where = where_panel, + grob_name = "panel-outcome" + ) - } else { - g_outcome_guide <- NULL + where_axis_element <- switch( + show_outcome, + "top" = c("intersect", "above", "axis-l-main", "left", "panel-outcome"), + "bottom" = c("intersect", "below", "axis-l-main", "left", "panel-outcome"), + "left" = c("intersect", "below", "panel-outcome", "left", "axis-b-main"), + "right" = c("intersect", "below", "panel-outcome", "right", "axis-b-main") + ) + + # Insert the axis element at the intersect of panel-outcome and the + # corresponding axis element of the main plot. + g_heatmap <- .gtable_insert( + g = g_heatmap, + g_new = .gtable_extract_grob(g_outcome, element = axis_element_name), + where = where_axis_element, + grob_name = axis_element_name + ) + + # Combine guides, + g_heatmap <- .combine_plot_elements( + g_main = g_heatmap, + g_new = g_outcome, + element_name = .all_gtable_guide_names(), + spacer = .get_plot_legend_spacing(ggtheme = ggtheme, axis = "y") + ) } - # Combine main guide with the outcome guide - extracted_elements$guide <- .combine_guide_grobs( - g = list(extracted_elements$guide, g_outcome_guide), - ggtheme = ggtheme, - no_empty = FALSE) - - # Add combined grob to list - figure_list <- c(figure_list, list(g_heatmap)) - - # Add extract elements to the grob_element_list - extracted_element_list <- c(extracted_element_list, list(extracted_elements)) + # Attach to figure list. + figure_list[[paste0(current_split$row_id, ".", current_split$col_id)]] <- as_familiar_plot( + g = g_heatmap, + layout = current_split + ) } - - # Update the layout table. - plot_layout_table <- .update_plot_layout_table( + + # Compose the final figure. Magic. + g <- .compose_figure( + figure_list = figure_list, plot_layout_table = plot_layout_table, - grobs = figure_list, x_text_shared = FALSE, x_label_shared = x_label_shared, y_text_shared = FALSE, y_label_shared = y_label_shared, - facet_wrap_cols = facet_wrap_cols) - - # Combine features. - g <- .arrange_plot_grobs( - grobs = figure_list, - plot_layout_table = plot_layout_table, - element_grobs = extracted_element_list, - ggtheme = ggtheme) + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme + ) return(g) } @@ -1449,13 +1586,15 @@ setMethod( caption, rotate_x_tick_labels, show_feature_dendrogram, - show_sample_dendrogram) { + show_sample_dendrogram +) { # Determine whether a sequential or divergent palette should be used by # default. palette_type <- ifelse( - length(gradient_palette_range) > 2, + length(gradient_palette_range) > 2L, "divergent", - "sequential") + "sequential" + ) # Create basic plot p <- ggplot2::ggplot( @@ -1463,7 +1602,9 @@ setMethod( mapping = ggplot2::aes( x = !!sym(x_axis_by), y = !!sym(y_axis_by), - fill = !!sym("value"))) + fill = !!sym("value") + ) + ) p <- p + ggtheme if (!is_empty(x)) { @@ -1477,14 +1618,16 @@ setMethod( gradient_colours <- .get_palette( x = gradient_palette, palette_type = palette_type, - diverge_to_white = TRUE) + diverge_to_white = TRUE + ) # Add gradient palette. If the legend is not shown, legend_label equals NULL. p <- p + ggplot2::scale_fill_gradientn( name = legend_label, colors = gradient_colours, limits = range(gradient_palette_range), - oob = scales::squish) + oob = scales::squish + ) # Create show_dendrogram that combines show_feature_dendrogram and # show_sample_dendrogram. @@ -1505,8 +1648,8 @@ setMethod( # Specify both axes. Note that only the heatmap is shown, without additional # space between the plot area and the axes. - p <- p + ggplot2::scale_x_discrete(position = x_axis_position, expand = c(0, 0)) - p <- p + ggplot2::scale_y_discrete(position = y_axis_position, expand = c(0, 0)) + p <- p + ggplot2::scale_x_discrete(position = x_axis_position, expand = c(0.0, 0.0)) + p <- p + ggplot2::scale_y_discrete(position = y_axis_position, expand = c(0.0, 0.0)) # Set labels. p <- p + ggplot2::labs( @@ -1514,14 +1657,16 @@ setMethod( y = y_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) # Determine how plots are faceted. The actual facets are created in the # calling function, not here. facet_by_list <- .parse_plot_facet_by( x = x@data, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -1530,13 +1675,15 @@ setMethod( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, labeller = "label_context", - drop = TRUE) + drop = TRUE + ) } } @@ -1546,7 +1693,9 @@ setMethod( axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } return(p) @@ -1562,24 +1711,25 @@ setMethod( dist_n_breaks, dist_breaks, plot_height, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Check if there is any data to plot. if (is_empty(x)) return(NULL) # Define the range along the x-axis. - x_range <- range(x$x_1) - x_range <- c(x_range[1] - 0.5, x_range[2] + 0.5) + x_range <- range(x$x_1, na.rm = TRUE) + x_range <- c(x_range[1L] - 0.5, x_range[2L] + 0.5) # y_range if (is.null(dist_range)) { - dist_range <- range(c(x$y_1, x$y_2)) + dist_range <- range(c(x$y_1, x$y_2), na.rm = TRUE) } # y_breaks if (is.null(dist_breaks)) { if (diff(dist_range) == 0.0) { - dist_range[1] <- dist_range[1] - 0.1 - dist_range[2] <- dist_range[2] + 0.1 + dist_range[1L] <- dist_range[1L] - 0.1 + dist_range[2L] <- dist_range[2L] + 0.1 } .check_input_plot_args( @@ -1590,18 +1740,21 @@ setMethod( # Create breaks and update y_range dist_breaks <- labeling::extended( m = dist_n_breaks, - dmin = dist_range[1], - dmax = dist_range[2], - only.loose = TRUE) + dmin = dist_range[1L], + dmax = dist_range[2L], + only.loose = TRUE + ) dist_range <- c( - head(dist_breaks, n = 1), - tail(dist_breaks, n = 1)) + head(dist_breaks, n = 1L), + tail(dist_breaks, n = 1L) + ) } .check_input_plot_args( y_range = dist_range, - y_breaks = dist_breaks) + y_breaks = dist_breaks + ) # Create basic plot p <- ggplot2::ggplot( @@ -1610,7 +1763,9 @@ setMethod( x = !!sym("x_1"), y = !!sym("y_1"), xend = !!sym("x_2"), - yend = !!sym("y_2"))) + yend = !!sym("y_2") + ) + ) p <- p + ggtheme # Plot line segments. @@ -1619,40 +1774,49 @@ setMethod( if (position == "right") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) p <- p + ggplot2::scale_y_continuous( limits = dist_range, - breaks = dist_breaks) + breaks = dist_breaks + ) p <- p + ggplot2::coord_flip() } else if (position == "bottom") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) p <- p + ggplot2::scale_y_reverse( limits = rev(dist_range), - breaks = rev(dist_breaks)) + breaks = rev(dist_breaks) + ) } else if (position == "left") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) p <- p + ggplot2::scale_y_reverse( limits = rev(dist_range), - breaks = rev(dist_breaks)) + breaks = rev(dist_breaks) + ) p <- p + ggplot2::coord_flip() } else if (position == "top") { p <- p + ggplot2::scale_x_continuous( limits = x_range, - expand = c(0, 0)) + expand = c(0.0, 0.0) + ) p <- p + ggplot2::scale_y_continuous( limits = dist_range, - breaks = dist_breaks) + breaks = dist_breaks + ) } else { ..error_reached_unreachable_code(paste0( - ".create_expression_dendrogram_plot: unknown position encountered: ", position)) + ".create_expression_dendrogram_plot: unknown position encountered: ", position + )) } # Remove some theme elements and reduce margins. The histogram height is left. @@ -1661,21 +1825,24 @@ setMethod( panel.background = ggplot2::element_blank(), panel.border = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank()) + axis.title.y = ggplot2::element_blank() + ) if (position %in% c("top", "bottom")) { # Remove x-axis p <- p + ggplot2::theme( axis.line.x = ggplot2::element_blank(), axis.ticks.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank()) + axis.text.x = ggplot2::element_blank() + ) } else if (position %in% c("left", "right")) { # Remove y-axis (rotated x-axis in plot) p <- p + ggplot2::theme( axis.line.y = ggplot2::element_blank(), axis.ticks.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank()) + axis.text.y = ggplot2::element_blank() + ) # Rotate x-labels if (rotate_x_tick_labels) { @@ -1683,7 +1850,9 @@ setMethod( axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } } @@ -1691,11 +1860,13 @@ setMethod( if (position %in% c("top", "bottom")) { p$custom_grob <- list("heights" = list( "name" = "panel", - "height" = plot_height)) + "height" = plot_height + )) } else if (position %in% c("left", "right")) { p$custom_grob <- list("widths" = list( "name" = "panel", - "width" = plot_height)) + "width" = plot_height + )) } class(p) <- c("familiar_ggplot", class(p)) @@ -1715,11 +1886,12 @@ setMethod( outcome_legend_label, plot_height, sample_similarity, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Set type of palette that is to be used for default palettes. if (outcome_type %in% c("binomial", "multinomial")) { palette_type <- "qualitative" - } else if (outcome_type %in% c("continuous", "count")) { + } else if (outcome_type %in% c("continuous")) { palette_type <- "sequential" } else if (outcome_type %in% c("survival", "competing_risk")) { palette_type <- "qualitative" @@ -1742,46 +1914,63 @@ setMethod( } # Correctly order the samples - x$sample <- factor(x$sample, + x$sample <- factor( + x$sample, levels = sample_order$name[order(sample_order$label_order)] ) + if (position %in% c("left", "right")) { + p <- ggplot2::ggplot( + data = x, + mapping = ggplot2::aes( + x = !!sym("evaluation_point"), + y = !!sym("sample"), + fill = !!sym("value") + ) + ) + + # Limit margins along the axis with samples so it will fit one-to-one with + # the main heatmap. + p <- p + ggplot2::scale_y_discrete(expand = c(0.0, 0.0)) + + } else { + p <- ggplot2::ggplot( + data = x, + mapping = ggplot2::aes( + x = !!sym("sample"), + y = !!sym("evaluation_point"), + fill = !!sym("value") + ) + ) + + # Limit margins along the axis with samples so it will fit one-to-one with + # the main heatmap. + p <- p + ggplot2::scale_x_discrete(expand = c(0.0, 0.0)) + } # Create basic plot - p <- ggplot2::ggplot( - data = x, - mapping = ggplot2::aes( - x = !!sym("sample"), - y = !!sym("evaluation_point"), - fill = !!sym("value"))) - + # Add plot theme p <- p + ggtheme # Plot heatmap p <- p + ggplot2::geom_raster() - # Limit margins along the axis with samples so it will fit one-to-one with the - # main heatmap. - p <- p + ggplot2::scale_x_discrete(expand = c(0, 0)) - - if (position %in% c("left", "right")) { - p <- p + ggplot2::coord_flip() - } - # Specify the colours. - if (outcome_type %in% c("continuous", "count")) { + if (outcome_type %in% c("continuous")) { # Colors outcome_colours <- .get_palette( x = outcome_palette, palette_type = palette_type, - use_alternative = TRUE) + use_alternative = TRUE + ) # Set the gradient p <- p + ggplot2::scale_fill_gradientn( name = outcome_legend_label, colors = outcome_colours, limits = range(outcome_palette_range), - oob = scales::squish) + oob = scales::squish + ) } else { # Colors @@ -1789,14 +1978,16 @@ setMethod( x = outcome_palette, n = nlevels(x$value), palette_type = palette_type, - use_alternative = TRUE) + use_alternative = TRUE + ) # Set the qualitative scale p <- p + ggplot2::scale_fill_manual( name = outcome_legend_label, values = outcome_colours[seq_along(levels(x$value))], breaks = levels(x$value), - drop = FALSE) + drop = FALSE + ) } # Remove some theme elements and reduce margins. The histogram height is left. @@ -1805,7 +1996,8 @@ setMethod( panel.background = ggplot2::element_blank(), panel.border = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank()) + axis.title.y = ggplot2::element_blank() + ) if (outcome_type %in% c("survival", "competing_risk")) { # Survival and competing risk outcomes leave the height axis intact @@ -1815,14 +2007,16 @@ setMethod( p <- p + ggplot2::theme( axis.line.x = ggplot2::element_blank(), axis.ticks.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank()) + axis.text.x = ggplot2::element_blank() + ) } else if (position %in% c("left", "right")) { # Remove y-axis (rotated x-axis in plot) p <- p + ggplot2::theme( axis.line.y = ggplot2::element_blank(), axis.ticks.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank()) + axis.text.y = ggplot2::element_blank() + ) # Rotate x-labels if (rotate_x_tick_labels) { @@ -1830,7 +2024,9 @@ setMethod( axis.text.x = ggplot2::element_text( vjust = 0.25, hjust = 1.0, - angle = 90.0)) + angle = 90.0 + ) + ) } } } else { @@ -1841,7 +2037,8 @@ setMethod( axis.text.x = ggplot2::element_blank(), axis.line.y = ggplot2::element_blank(), axis.ticks.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank()) + axis.text.y = ggplot2::element_blank() + ) } # Adapt plot_height so that it scales with the number of evaluation points. @@ -1853,11 +2050,13 @@ setMethod( if (position %in% c("top", "bottom")) { p$custom_grob <- list("heights" = list( "name" = "panel", - "height" = plot_height)) + "height" = plot_height + )) } else if (position %in% c("left", "right")) { p$custom_grob <- list("widths" = list( "name" = "panel", - "width" = plot_height)) + "width" = plot_height + )) } class(p) <- c("familiar_ggplot", class(p)) @@ -1877,12 +2076,14 @@ setMethod( samples, show_feature_dendrogram, show_sample_dendrogram, - rotate_x_tick_labels) { + rotate_x_tick_labels +) { # Obtain facetting dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Determine the number of elements along the x-axis. if (x_axis_by == "feature") { @@ -1914,17 +2115,19 @@ setMethod( # Reserve space for the dendrograms (1.5 cm) dendro_height <- ifelse( any(c("top", "bottom") %in% c(show_feature_dendrogram, show_sample_dendrogram)), - 1.5, 0.0) + 1.5, 0.0 + ) dendro_width <- ifelse( any(c("left", "right") %in% c(show_feature_dendrogram, show_sample_dendrogram)), - 1.5, 0.0) + 1.5, 0.0 + ) # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * (default_height + x_tick_space + dendro_height), 27.7)) + height <- min(c(2.0 + plot_dims[1L] * (default_height + x_tick_space + dendro_height), 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm). We leave some # room for the legend on the right. - width <- min(c(5 + plot_dims[2] * (default_width + y_tick_space + dendro_width), 19)) + width <- min(c(5.0 + plot_dims[2L] * (default_width + y_tick_space + dendro_width), 19.0)) return(c(height, width)) } @@ -1950,21 +2153,27 @@ setMethod( data = x@data, feature_info_list = x@feature_info, features = names(x@feature_info), - invert = FALSE) + invert = FALSE + ) # Normalise features x@data <- normalise_features( data = x@data, feature_info_list = x@feature_info, features = names(x@feature_info), - invert = FALSE) + invert = FALSE + ) } else if (show_normalised_data == "set_normalisation") { # Normalise features within the current dataset. for (curr_feat in names(x@feature_info)) { - x@data[, (curr_feat) := .normalise(get(curr_feat), - normalisation_method = "standardisation_winsor" - )] + x@data[ + , + (curr_feat) := .normalise( + get(curr_feat), + normalisation_method = "standardisation_winsor" + ) + ] } } @@ -1977,7 +2186,8 @@ setMethod( x, feature_similarity, sample_similarity, - gradient_palette_range) { + gradient_palette_range +) { # Suppress NOTES due to non-standard evaluation in data.table feature <- sample <- NULL @@ -1993,19 +2203,20 @@ setMethod( } else { return(NULL) } - }) + } + ) # Identify categorical features categorical_features <- unique(unlist(categorical_features)) # Convert to numerical and rescale so that the categorical values lie within # the range of the remaining numerical data. - if (length(categorical_features) > 0) { + if (length(categorical_features) > 0L) { # Determine the output value range - output_value_range <- numeric(2) - output_value_range[1] <- head(gradient_palette_range, n = 1) + + output_value_range <- numeric(2L) + output_value_range[1L] <- head(gradient_palette_range, n = 1L) + 0.05 * diff(range(gradient_palette_range)) - output_value_range[2] <- head(gradient_palette_range, n = 1) + + output_value_range[2L] <- head(gradient_palette_range, n = 1L) + 0.95 * diff(range(gradient_palette_range)) # Make a local copy of x to prevent warnings raised by data.table. @@ -2016,11 +2227,12 @@ setMethod( numeric_data <- as.numeric(x@data[[feature]]) # Determine the range of the input value range. - input_value_range <- c(1, length(x@feature_info[[feature]]@levels)) + input_value_range <- c(1.0, length(x@feature_info[[feature]]@levels)) # Convert numeric data to the output range. - numeric_data <- (numeric_data - input_value_range[1]) / (diff(input_value_range)) * - diff(output_value_range) + output_value_range[1] + numeric_data <- (numeric_data - input_value_range[1L]) / + diff(input_value_range) * diff(output_value_range) + + output_value_range[1L] # Update column x@data[[feature]] <- numeric_data @@ -2035,13 +2247,15 @@ setMethod( variable.name = "feature", value.name = "value", variable.factor = TRUE, - value.factor = FALSE) + value.factor = FALSE + ) # Change sample_name to sample data.table::setnames( x = data, old = "sample_name", - new = "sample") + new = "sample" + ) # Determine feature order. if (is.null(feature_similarity)) { @@ -2095,7 +2309,8 @@ setMethod( data.table::setnames( x = x, old = c("sample_name", "outcome"), - new = c("sample", "value")) + new = c("sample", "value") + ) # Set evaluation point (which is on the y-axis) x$evaluation_point <- factor("1", levels = "1") @@ -2115,7 +2330,8 @@ setMethod( .check_number_in_valid_range, var_name = "evaluation_times", range = c(0.0, Inf), - closed = c(FALSE, TRUE)) + closed = c(FALSE, TRUE) + ) # Keep only one copy for each sample. x <- data.table::copy(x[, c("sample_name", "outcome_time", "outcome_event")]) @@ -2133,11 +2349,11 @@ setMethod( y[!is.finite(outcome_time) | is.na(outcome_event), "value" := NA_character_] # All samples that have an event before or at the evaluation time. - y[outcome_time <= eval_time & outcome_event == 1, "value" := "yes"] + y[outcome_time <= eval_time & outcome_event == 1L, "value" := "yes"] # All samples that were censored (lost to follow-up) at the evaluation # time. - y[outcome_time <= eval_time & outcome_event == 0, "value" := "cens."] + y[outcome_time <= eval_time & outcome_event == 0L, "value" := "cens."] # Set as factor y$value <- factor(y$value, levels = c("no", "yes", "cens.")) @@ -2147,7 +2363,8 @@ setMethod( return(y) }, - x = x) + x = x + ) # Combine plot data plot_data <- data.table::rbindlist(plot_data) @@ -2155,13 +2372,15 @@ setMethod( # Set evaluation point as a factor plot_data$evaluation_point <- factor( x = plot_data$evaluation_point, - levels = evaluation_times) + levels = evaluation_times + ) # Change subject_id to sample data.table::setnames( x = plot_data, old = "sample_name", - new = "sample") + new = "sample" + ) return(plot_data) } diff --git a/R/PlotShapDependence.R b/R/PlotShapDependence.R new file mode 100644 index 00000000..b5ea774c --- /dev/null +++ b/R/PlotShapDependence.R @@ -0,0 +1,829 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# plot_shap_dependence (generic) ----------------------------------------------- + +#' @title Create SHAP dependence plot. +#' +#' @description This method creates a SHAP dependence plot that shows the +#' dependence of the SHAP value of a feature against its value. +#' +#' @param dir_path (*optional*) Path to the directory where created SHAP +#' dependence plots are saved to. Output is saved in the `explanation` +#' subdirectory. If `NULL` no figures are saved, but are returned instead. +#' @param discrete_palette (*optional*) Divergent or sequential palette used to +#' colour the elements of dependence plots for interactions with another +#' **categorical** feature. `familiar` has a default palette. Other palettes +#' are supported by the `paletteer` package, `grDevices::palette.pals()` +#' (requires R >= 4.0.0), `grDevices::hcl.pals()` (requires R >= 3.6.0) and +#' `rainbow`, `heat.colors`, `terrain.colors`, `topo.colors` and `cm.colors`, +#' which correspond to the palettes of the same name in `grDevices`. You may +#' also specify your own palette by providing a vector of colour names listed +#' by `grDevices::colors()` or through hexadecimal RGB strings. +#' +#' If no `interaction_feature` is set, or is a numerical feature, the gradient +#' palette is not used. +#' @param gradient_palette (*optional*) Divergent or sequential palette used to +#' colour the elements of dependence plots for interactions with another +#' **numeric** feature. `familiar` has a default palette. Other palettes are +#' supported by the `paletteer` package, `grDevices::palette.pals()` (requires +#' R >= 4.0.0), `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, +#' `heat.colors`, `terrain.colors`, `topo.colors` and `cm.colors`, which +#' correspond to the palettes of the same name in `grDevices`. You may also +#' specify your own palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. +#' +#' If no `interaction_feature` is set, or is a categorical feature, the +#' gradient palette is not used. +#' +#' @param shap_feature (*optional*) Feature(s) whose SHAP values are used for +#' creating the SHAP dependence plot. +#' @param interaction_feature (*optional*) Feature(s) whose values are used to +#' colour points of the `shap_feature`. +#' @inheritParams as_familiar_collection +#' @inheritParams plot_univariate_importance +#' @inheritParams .check_input_plot_args +#' @inheritParams .check_plot_splitting_variables +#' @inheritDotParams extract_performance -object +#' @inheritDotParams as_familiar_collection -object +#' @inheritDotParams ggplot2::ggsave -height -width -units -path -filename -plot +#' +#' @details This function creates SHAP dependence plots, which show how the +#' marginal contributions of a feature to the predicted value depend on its +#' value. +#' +#' Available splitting variables are: `vimp_method`, `learner`, `data_set`, +#' `evaluation_time` (survival outcome only) and `positive_class` (categorical +#' outcomes). The default is to facet by `evaluation_time` or +#' `positive_class`, and split by `vimp_method`, `learner` and `data_set`. +#' `color_by` is not used. +#' +#' Labelling methods such as `set_vimp_method_names` or `set_learner_names` +#' can be applied to the `familiarCollection` object to update labels, and +#' order the output in the figure. +#' +#' @return `NULL` or list of plot objects, if `dir_path` is `NULL`. +#' +#' @exportMethod plot_shap_dependence +#' @md +#' @rdname plot_shap_dependence-methods +setGeneric( + "plot_shap_dependence", + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + shap_feature = NULL, + interaction_feature = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + standardGeneric("plot_shap_dependence") + } +) + + + +# plot_shap_dependence (general) ----------------------------------------------- + +#' @rdname plot_shap_dependence-methods +setMethod( + "plot_shap_dependence", + signature(object = "ANY"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + shap_feature = NULL, + interaction_feature = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Attempt conversion to familiarCollection object. + object <- do.call( + as_familiar_collection, + args = c( + list( + "object" = object, + "data_element" = "shap" + ), + list(...) + ) + ) + + return(do.call( + plot_shap_dependence, + args = list( + "object" = object, + "draw" = draw, + "dir_path" = dir_path, + "split_by" = split_by, + "facet_by" = facet_by, + "facet_wrap_cols" = facet_wrap_cols, + "ggtheme" = ggtheme, + "discrete_palette" = discrete_palette, + "gradient_palette" = gradient_palette, + "x_label" = x_label, + "y_label" = y_label, + "legend_label" = legend_label, + "plot_title" = plot_title, + "plot_sub_title" = plot_sub_title, + "caption" = caption, + "x_range" = x_range, + "x_n_breaks" = x_n_breaks, + "x_breaks" = x_breaks, + "y_range" = y_range, + "y_n_breaks" = y_n_breaks, + "y_breaks" = y_breaks, + "shap_feature" = shap_feature, + "interaction_feature" = interaction_feature, + "width" = width, + "height" = height, + "units" = units, + "export_collection" = export_collection + ) + )) + } +) + + + +# plot_shap_dependence (collection) -------------------------------------------- + +#' @rdname plot_shap_dependence-methods +setMethod( + "plot_shap_dependence", + signature(object = "familiarCollection"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + shap_feature = NULL, + interaction_feature = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Prevent NOTES. + .NATURAL <- NULL + + # Make sure the collection object is updated. + object <- update_object(object = object) + + # Check input arguments ---------------------------------------------------- + + # ggtheme + ggtheme <- .check_ggtheme(ggtheme) + + # Load the data. + x <- export_shap(object = object) + x <- x$shap_summary + if (is_empty(x)) return(NULL) + + # Obtain single data element from list. + if (is.list(x)) { + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_shap_dependence: list of data elements contains unmerged elements." + ) + } + x <- x[[1L]] + } + + # Check that the data are not evaluated at the model level. + if (x@detail_level == "model") { + ..warning_no_comparison_between_models() + return(NULL) + } + + # Check that the data are not empty. + if (is_empty(x)) return(NULL) + + # Ensure that we work with a copy of the data. + x@data <- data.table::copy(x@data) + + # Check package requirements for plotting. + if (!require_package( + x = ..required_plotting_packages(extended = FALSE), + purpose = "to create a SHAP dependence plot", + message_type = "warning" + )) { + return(NULL) + } + + # Add evaluation time or positive class as a splitting variable. + additional_variable <- NULL + if (object@outcome_type %in% c("survival")) { + additional_variable <- "evaluation_time" + data.table::setnames(x@data, old = "shap_outcome", new = "evaluation_time") + + } else if (object@outcome_type %in% c("multinomial")) { + additional_variable <- "positive_class" + data.table::setnames(x@data, old = "shap_outcome", new = "positive_class") + } + + # Add default splitting variables. + if ( + is.null(split_by) && + is.null(facet_by) + ) { + # Split by vimp_method, learner. + split_by <- c("vimp_method", "learner", "data_set", "feature_name") + facet_by <- additional_variable + } + all_variables <- c("vimp_method", "learner", "data_set", additional_variable, "feature_name") + + # Check splitting variables and generate sanitised output + split_var_list <- .check_plot_splitting_variables( + x = x@data, + split_by = split_by, + facet_by = facet_by, + available = all_variables + ) + + # Update splitting variables + split_by <- split_var_list$split_by + facet_by <- split_var_list$facet_by + + # y_label + if (is.waive(y_label)) { + y_label <- "SHAP value" + } + + .check_input_plot_args( + facet_wrap_cols = facet_wrap_cols, + y_label = y_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption + ) + + # Determine which features to use. + selected_shap_features <- levels(x@data$feature_name) + if (!is.null(shap_feature)) { + feature_in_data <- shap_feature %in% selected_shap_features + if (!all(feature_in_data)) { + ..warning(paste0( + "Not all features in shap_feature could be found in the data. Missing: ", + paste_s(shap_feature[!feature_in_data]) + )) + } + selected_shap_features <- intersect(selected_shap_features, shap_feature) + } + if (length(selected_shap_features) == 0L) return(NULL) + + # Determine which interaction features exist. + selected_interaction_features <- NULL + if (!is.null(interaction_feature)) { + feature_in_data <- interaction_feature %in% levels(x@data$feature_name) + if (!all(feature_in_data)) { + ..warning(paste0( + "Not all features in interaction_feature could be found in the data. Missing: ", + paste_s(interaction_feature[!feature_in_data]) + )) + } + selected_interaction_features <- intersect(interaction_feature, levels(x@data$feature_name)) + if (length(selected_interaction_features) == 0L) interaction_features <- NULL + } + + # Create plots ------------------------------------------------------------- + + # Determine if subtitle should be generated. + autogenerate_plot_subtitle <- is.waive(plot_sub_title) + + # Split data. + if (!is.null(split_by)) { + x_split <- split( + x@data, + by = split_by, + drop = FALSE + ) + + } else { + x_split <- list("null.name" = x@data) + } + + # Select plot data based on split. + plot_data <- list() + plot_data_index <- 1L + + for (ii in seq_along(x_split)) { + main_data <- x_split[[ii]] + if (is_empty(main_data)) next + + # Skip if current feature is not in selected_shap_features. + current_shap_feature <- main_data$feature_name[1L] + if (!current_shap_feature %in% selected_shap_features) next + + interaction_data <- NULL + if (length(selected_interaction_features) > 0L) { + for (current_interaction_feature in selected_interaction_features) { + interaction_selection_data <- unique(main_data[, mget(split_by)]) + interaction_selection_data[, "feature_name" := current_interaction_feature] + interaction_data <- x@data[interaction_selection_data, on = .NATURAL] + + plot_data[[plot_data_index]] <- list( + "main_data" = main_data, + "interaction_data" = interaction_data, + "feature" = as.character(current_shap_feature), + "interaction_feature" = as.character(current_interaction_feature) + ) + plot_data_index <- plot_data_index + 1L + } + + } else { + plot_data[[plot_data_index]] <- list( + "main_data" = main_data, + "interaction_data" = NULL, + "feature" = as.character(current_shap_feature), + "interaction_feature" = NULL + ) + plot_data_index <- plot_data_index + 1L + } + } + + # Store plots to list in case dir_path is absent. + if (is.null(dir_path)) plot_list <- list() + + # Iterate over data splits. + for (current_data in plot_data) { + if (is.waive(plot_title)) plot_title <- "SHAP dependence" + + # Declare subtitle components. + additional_subtitle <- NULL + + # Add evaluation time as subtitle component if it is not used + # otherwise. + if ( + !"evaluation_time" %in% c(split_by, facet_by) && + object@outcome_type %in% c("survival") + ) { + additional_subtitle <- c( + additional_subtitle, + .add_time_to_plot_subtitle(current_data$main_data$evaluation_time[1L]) + ) + } + + # Add feature as subtitle component if it is not used otherwise. + if (!"feature_name" %in% c(split_by)) { + additional_subtitle <- c( + additional_subtitle, + list("feature" = current_data$feature) + ) + } + + # Add interaction feature as subtitle component. + if (!is.null(current_data$interaction_feature)) { + additional_subtitle <- c( + additional_subtitle, + list("interaction" = current_data$interaction_feature) + ) + } + + if (autogenerate_plot_subtitle) { + plot_sub_title <- .create_plot_subtitle( + split_by = split_by, + additional = additional_subtitle, + x = current_data$main_data + ) + } + + # Generate plot + p <- .plot_shap_dependence_plot( + x = current_data$main_data, + x_feature = current_data$feature, + z = current_data$interaction_data, + z_feature = current_data$interaction_feature, + split_by = split_by, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme, + discrete_palette = discrete_palette, + gradient_palette = gradient_palette, + x_label = x_label, + y_label = y_label, + legend_label = legend_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption, + x_range = x_range, + x_n_breaks = x_n_breaks, + x_breaks = x_breaks, + y_range = y_range, + y_n_breaks = y_n_breaks, + y_breaks = y_breaks + ) + + # Check empty output + if (is.null(p)) next + + # Draw figure. + if (draw) .draw_plot(plot_or_grob = p) + + # Save and export + if (!is.null(dir_path)) { + # Obtain decent default values for the plot. + def_plot_dims <- .determine_shap_dependence_plot_dimensions( + x = current_data$main_data, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Set subtype + subtype <- "shap_dependence" + if (!is.null(current_data$interaction_feature)){ + subtype <- paste0(subtype, "int_", current_data$interaction_feature) + } + + # Save to file. + do.call( + .save_plot_to_file, + args = c( + list( + "plot_or_grob" = p, + "object" = object, + "dir_path" = dir_path, + "type" = "explanation", + "subtype" = subtype, + "x" = current_data$main_data, + "split_by" = split_by, + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) + + } else { + # Store as list for export. + plot_list <- c(plot_list, list(p)) + } + } + + # Generate output + return(.get_plot_results( + dir_path = dir_path, + plot_list = plot_list, + export_collection = export_collection, + object = object + )) + } +) + + + +.plot_shap_dependence_plot <- function( + x, + x_feature, + z, + z_feature, + facet_by, + split_by, + facet_wrap_cols, + ggtheme, + discrete_palette, + gradient_palette, + x_label, + y_label, + legend_label, + plot_title, + plot_sub_title, + caption, + x_range, + x_n_breaks, + x_breaks, + y_range, + y_n_breaks, + y_breaks +) { + # Suppress NOTES due to non-standard evaluation in data.table + shap_value <- vimp <- feature_value <- NULL + + # Check that the interaction feature is not the same as the main feature. + if (!is.null(z_feature)) { + if (z_feature == x_feature) z <- NULL + } + + # Make local copies to prevent updating by reference. + x <- data.table::copy(x) + if (!is_empty(z)) z <- data.table::copy(z) + + # x_label + if (is.waive(x_label)) { + x_label <- paste0(x_feature, " value") + } + + # Check if the main feature is numeric. + x_numeric <- all(is.na(x$feature_label)) + z_numeric <- TRUE + if (!is_empty(z)) z_numeric <- all(is.na(z$feature_label)) + + if (x_numeric) { + # Check x_range. + if (is.null(x_range)) { + x_range <- range(x$feature_value, na.rm = TRUE) + + if (diff(x_range) == 0.0) { + x_range <- c(x_range[1L] - 0.01, x_range[2L] + 0.01) + } + + } else { + .check_input_plot_args(x_range = x_range) + } + + # x_breaks + if (is.null(x_breaks)) { + .check_input_plot_args( + x_range = x_range, + x_n_breaks = x_n_breaks + ) + + # Create breaks and update x_range + x_breaks <- labeling::extended( + m = x_n_breaks, + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) + + x_range <- c( + head(x_breaks, n = 1L), + tail(x_breaks, n = 1L) + ) + + } else { + .check_input_plot_args(x_breaks = x_breaks) + } + } + + # Check y_range. + if (is.null(y_range)) { + y_range <- range(x$shap_value, na.rm = TRUE) + + if (diff(y_range) == 0.0) { + y_range <- c(y_range[1L] - 0.01, y_range[2L] + 0.01) + } + + } else { + .check_input_plot_args(y_range = y_range) + } + + # y_breaks + if (is.null(y_breaks)) { + .check_input_plot_args( + y_range = y_range, + y_n_breaks = y_n_breaks + ) + + # Create breaks and update x_range + y_breaks <- labeling::extended( + m = y_n_breaks, + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) + + y_range <- c( + head(y_breaks, n = 1L), + tail(y_breaks, n = 1L) + ) + + } else { + .check_input_plot_args(y_breaks = y_breaks) + } + + # Create a legend label. + if (is.waive(legend_label) && !is_empty(z)) { + legend_label <- z_feature + } + + # Check remaining input arguments. + .check_input_plot_args( + x_label = x_label, + legend_label = legend_label + ) + + # Set numeric or categorical feature values. + if (x_numeric) { + x[, "x_value" := feature_value] + } else { + feature_labels <- unique(x[, mget(c("feature_value", "feature_label"))])[order(feature_value)] + x[, "x_value" := factor( + feature_value, + levels = feature_labels$feature_value, + labels = feature_labels$feature_label + )] + } + + # Set numeric or categorical feature values for the interaction feature. + if (!is_empty(z)) { + if (z_numeric) { + z[, "z_value" := feature_value] + } else { + feature_labels <- unique(z[, mget(c("feature_value", "feature_label"))])[order(feature_value)] + z[, "z_value" := factor( + feature_value, + levels = feature_labels$feature_value, + labels = feature_labels$feature_label + )] + } + + split_by <- setdiff(split_by, "feature_name") + x <- merge( + x = x, + y = z[, mget(c(split_by, facet_by, "sample_id", "z_value"))], + by = c(split_by, facet_by, "sample_id") + ) + } + + mapping <- ggplot2::aes( + x = !!sym("x_value"), + y = !!sym("shap_value") + ) + if (!is_empty(z)) { + mapping <- ggplot2::aes( + x = !!sym("x_value"), + y = !!sym("shap_value"), + colour = !!sym("z_value") + ) + } + + # Create basic plot + p <- ggplot2::ggplot( + data = x, + mapping = mapping + ) + p <- p + ggtheme + + # Set breaks and range. + if (x_numeric) p <- p + ggplot2::scale_x_continuous(breaks = x_breaks, limits = x_range) + p <- p + ggplot2::scale_y_continuous(breaks = y_breaks, limits = y_range) + + # Set main plot type. + if (x_numeric) { + p <- p + ggplot2::geom_point() + } else { + # Jitter only possible along x-axis for categorical features. + p <- p + ggplot2::geom_jitter(height = 0.0) + } + + + # Set colours for interactions. + if (!is_empty(z) && z_numeric) { + # Gradient palette for numeric interaction features. + gradient_colours <- .get_palette( + x = gradient_palette, + palette_type = "divergent" + ) + + p <- p + ggplot2::scale_colour_gradientn( + name = legend_label, + colors = gradient_colours + ) + + } else if (!is_empty(z) && !z_numeric) { + # Discrete palette for categorical interaction features. + discrete_colours <- .get_palette( + x = discrete_palette, + palette_type = "qualitative", + n = nlevels(x$z_value) + ) + + p <- p + ggplot2::scale_colour_manual( + name = legend_label, + values = discrete_colours, + breaks = levels(x$z_value) + ) + } + + # Determine how things are faceted. + facet_by_list <- .parse_plot_facet_by( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + if (!is.null(facet_by)) { + if (is.null(facet_wrap_cols)) { + # Use a grid + p <- p + ggplot2::facet_grid( + rows = facet_by_list$facet_rows, + cols = facet_by_list$facet_cols, + labeller = "label_context" + ) + + } else { + p <- p + ggplot2::facet_wrap( + facets = facet_by_list$facet_by, + labeller = "label_context" + ) + } + } + + # Update labels. + p <- p + ggplot2::labs( + x = x_label, + y = y_label, + title = plot_title, + subtitle = plot_sub_title, + caption = caption + ) + + return(p) +} + + + +.determine_shap_dependence_plot_dimensions <- function( + x, + x_axis_by, + y_axis_by, + facet_by, + facet_wrap_cols +) { + + # Obtain facetting dimensions + plot_dims <- .get_plot_layout_dims( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Set default height and width for each subplot (in cm). + default_width <- 6.0 + default_height <- 4.0 + + # Set overall plot height, but limit to small-margin A4 (27.7 cm) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) + + # Set overall plot width, but limit to small-margin A4 (19 cm) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) + + return(c(height, width)) +} diff --git a/R/PlotShapForce.R b/R/PlotShapForce.R new file mode 100644 index 00000000..c3166093 --- /dev/null +++ b/R/PlotShapForce.R @@ -0,0 +1,955 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# plot_shap_force (generic) ---------------------------------------------------- + +#' @title Create SHAP force plot +#' +#' @description This method creates plots that show stacked SHAP force values +#' obtained from the data stored in a familiarCollection object. +#' +#' @param dir_path (*optional*) Path to the directory where created SHAP force +#' plots are saved to. Output is saved in the `explanation` subdirectory. If +#' `NULL` no figures are saved, but are returned instead. +#' @param discrete_palette (*optional*) Discrete palette used to colour the +#' elements of force plots. `familiar` has a default palette. Other palettes +#' are supported by the `paletteer` package, `grDevices::palette.pals()` +#' (requires R >= 4.0.0), `grDevices::hcl.pals()` (requires R >= 3.6.0). You +#' may also specify your own palette by providing a vector of colour names +#' listed by `grDevices::colors()` or through hexadecimal RGB strings. +#' @param highlight_feature (*optional*) Name of one or more features that +#' should be highlighted in the force plot. +#' @param sample_order (*optional*) Ordering of samples, one of: +#' +#' * `prediction`: samples are ordered by increasing predicted value. Sample +#' order between facets may differ. +#' +#' * `original`: samples retain the original ordering. Sample order between +#' facets is consistent. +#' +#' @inheritParams as_familiar_collection +#' @inheritParams plot_univariate_importance +#' @inheritParams .check_input_plot_args +#' @inheritParams .check_plot_splitting_variables +#' @inheritDotParams extract_performance -object +#' @inheritDotParams as_familiar_collection -object +#' @inheritDotParams ggplot2::ggsave -height -width -units -path -filename -plot +#' +#' @details This function plots model performance based on empirical bootstraps, +#' using various plot representations. +#' +#' Available splitting variables are: `vimp_method`, `learner`, `data_set`, +#' `evaluation_time` (survival outcome only) and `positive_class` (categorical +#' outcomes). The default for is to facet by `evaluation_time` or +#' `positive_class`, and split by `vimp_method`, `learner` and `data_set`. +#' `color_by` is not used. +#' +#' Labelling methods such as `set_vimp_method_names` or `set_learner_names` +#' can be applied to the `familiarCollection` object to update labels, and +#' order the output in the figure. +#' +#' @return `NULL` or list of plot objects, if `dir_path` is `NULL`. +#' +#' @exportMethod plot_shap_force +#' @md +#' @rdname plot_shap_force-methods +setGeneric( + "plot_shap_force", + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + x_label = waiver(), + x_label_shared = "column", + y_label = waiver(), + y_label_shared = "row", + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + highlight_feature = NULL, + sample_order = "prediction", + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + standardGeneric("plot_shap_force") + } +) + + + +# plot_shap_force (general) ------------------------------------------------ + +#' @rdname plot_shap_force-methods +setMethod( + "plot_shap_force", + signature(object = "ANY"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + x_label = waiver(), + x_label_shared = "column", + y_label = waiver(), + y_label_shared = "row", + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + highlight_feature = NULL, + sample_order = "prediction", + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Attempt conversion to familiarCollection object. + object <- do.call( + as_familiar_collection, + args = c( + list( + "object" = object, + "data_element" = "shap" + ), + list(...) + ) + ) + + return(do.call( + plot_shap_force, + args = list( + "object" = object, + "draw" = draw, + "dir_path" = dir_path, + "split_by" = split_by, + "x_axis_by" = x_axis_by, + "y_axis_by" = y_axis_by, + "facet_by" = facet_by, + "facet_wrap_cols" = facet_wrap_cols, + "ggtheme" = ggtheme, + "discrete_palette" = discrete_palette, + "x_label" = x_label, + "x_label_shared" = x_label_shared, + "y_label" = y_label, + "y_label_shared" = y_label_shared, + "legend_label" = legend_label, + "plot_title" = plot_title, + "plot_sub_title" = plot_sub_title, + "caption" = caption, + "y_range" = y_range, + "y_n_breaks" = y_n_breaks, + "y_breaks" = y_breaks, + "highlight_feature" = highlight_feature, + "sample_order" = sample_order, + "width" = width, + "height" = height, + "units" = units, + "export_collection" = export_collection + ) + )) + } +) + + + +# plot_shap_force (collection) ----------------------------------------------- + +#' @rdname plot_shap_force-methods +setMethod( + "plot_shap_force", + signature(object = "familiarCollection"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + x_label = waiver(), + x_label_shared = "column", + y_label = waiver(), + y_label_shared = "row", + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + highlight_feature = NULL, + sample_order = "prediction", + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Make sure the collection object is updated. + object <- update_object(object = object) + + # Check input arguments ---------------------------------------------------- + + # ggtheme + ggtheme <- .check_ggtheme(ggtheme) + + # Load the data. + x <- export_shap(object = object) + + x <- x$shap_force + if (is_empty(x)) return(NULL) + + # Obtain single data element from list. + if (is.list(x)) { + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_shap_force: list of data elements contains unmerged elements." + ) + } + x <- x[[1L]] + } + + # Check that the data are not evaluated at the model level. + if (x@detail_level == "model") { + ..warning_no_comparison_between_models() + return(NULL) + } + + # Check that the data are not empty. + if (is_empty(x)) return(NULL) + + # Ensure that we work with a copy of the data. + x@data <- data.table::copy(x@data) + + # Check package requirements for plotting. + if (!require_package( + x = ..required_plotting_packages(extended = FALSE), + purpose = "to create a SHAP waterfall plot", + message_type = "warning" + )) { + return(NULL) + } + + # Add evaluation time or class as a splitting variable. + additional_variable <- NULL + if (object@outcome_type %in% c("survival")) { + additional_variable <- "evaluation_time" + data.table::setnames(x@data, old = "shap_outcome", new = "evaluation_time") + + } else if (object@outcome_type %in% c("multinomial")) { + additional_variable <- "positive_class" + data.table::setnames(x@data, old = "shap_outcome", new = "positive_class") + } + + # Add default splitting variables. + if ( + is.null(split_by) && + is.null(facet_by) + ) { + # Split by vimp_method, learner. + split_by <- c("vimp_method", "learner", "data_set") + facet_by <- additional_variable + } + + all_variables <- c("vimp_method", "learner", "data_set", additional_variable) + + # Check splitting variables and generate sanitised output + split_var_list <- .check_plot_splitting_variables( + x = x@data, + split_by = split_by, + facet_by = facet_by, + available = all_variables + ) + + # Update splitting variables + split_by <- split_var_list$split_by + facet_by <- split_var_list$facet_by + + # x_label + if (is.waive(x_label)) { + x_label <- "sample" + } + + # y_label + if (is.waive(y_label)) { + y_label <- "predicted value" + } + + # x_label_shared + if (!is.waive(x_label_shared)) { + .check_input_plot_args(x_label_shared = x_label_shared) + } else { + x_label_shared <- "column" + } + + # y_label_shared + if (!is.waive(y_label_shared)) { + .check_input_plot_args(y_label_shared = y_label_shared) + } else { + y_label_shared <- "row" + } + + .check_input_plot_args( + facet_wrap_cols = facet_wrap_cols, + x_label = x_label, + y_label = y_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption + ) + + # Check that highlight_feature appears as a feature. + if (!is.null(highlight_feature)) { + features_in_data <- highlight_feature %in% levels(x@data$feature_name) + + if (!all(features_in_data)) { + ..warning( + paste0( + "Not all features to highlight for SHAP force plots were found in the dataset. Missing: ", + paste_s(highlight_feature[!features_in_data]) + ) + ) + } + } + + # sample_order + .check_parameter_value_is_valid( + x = sample_order, + var_name = "sample_order", + values = c("prediction", "original") + ) + + # Create plots ------------------------------------------------------------- + + # Determine if subtitle should be generated. + autogenerate_plot_subtitle <- is.waive(plot_sub_title) + + # Split data. + if (!is.null(split_by)) { + x_split <- split( + x@data, + by = split_by, + drop = FALSE + ) + + } else { + x_split <- list("null.name" = x@data) + } + + # Store plots to list in case dir_path is absent. + if (is.null(dir_path)) plot_list <- list() + + # Iterate over data splits. + for (ii in names(x_split)) { + # Skip empty datasets. + if (is_empty(x_split[[ii]])) next + + if (is.waive(plot_title)) plot_title <- "SHAP force" + + # Declare subtitle components. + additional_subtitle <- NULL + + # Add evaluation time as subtitle component if it is not used + # otherwise. + if ( + !"evaluation_time" %in% c(split_by, facet_by) && + object@outcome_type %in% c("survival") + ) { + additional_subtitle <- c( + additional_subtitle, + .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1L]) + ) + } + + if (autogenerate_plot_subtitle) { + plot_sub_title <- .create_plot_subtitle( + split_by = split_by, + additional = additional_subtitle, + x = x_split[[ii]] + ) + } + + p <- .plot_shap_force_plot( + x = x_split[[ii]], + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme, + discrete_palette = discrete_palette, + x_label = x_label, + x_label_shared = x_label_shared, + y_label = y_label, + y_label_shared = y_label_shared, + legend_label = legend_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption, + y_range = y_range, + y_n_breaks = y_n_breaks, + y_breaks = y_breaks, + highlight_feature = highlight_feature, + sample_order = sample_order + ) + + # Check empty output + if (is.null(p)) next + + # Draw figure. + if (draw) .draw_plot(plot_or_grob = p) + + # Save and export + if (!is.null(dir_path)) { + # Obtain decent default values for the plot. + def_plot_dims <- .determine_shap_force_plot_dimensions( + x = x_split[[ii]], + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Save to file. + do.call( + .save_plot_to_file, + args = c( + list( + "plot_or_grob" = p, + "object" = object, + "dir_path" = dir_path, + "type" = "explanation", + "subtype" = "shap_force", + "x" = x_split[[ii]], + "split_by" = split_by, + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) + + } else { + # Store as list for export. + plot_list <- c(plot_list, list(p)) + } + } + + # Generate output + return(.get_plot_results( + dir_path = dir_path, + plot_list = plot_list, + export_collection = export_collection, + object = object + )) + } +) + + + +.plot_shap_force_plot <- function( + x, + facet_by, + facet_wrap_cols, + ggtheme, + discrete_palette, + x_label, + x_label_shared, + y_label, + y_label_shared, + legend_label, + plot_title, + plot_sub_title, + caption, + y_range, + y_n_breaks, + y_breaks, + highlight_feature, + sample_order +) { + # Suppress NOTES due to non-standard evaluation in data.table + shap_value <- prediction <- NULL + + # Split by facet. This generates a list of data splits with faceting + # information that allows for positioning. + plot_layout_table <- .get_plot_layout_table( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Set the y-range, as this should be fixed across facets. + if (is.null(y_range)) { + # Find the correct y-range + y_range_data <- x[ + , + list( + "y_min" = prediction - sum(pmax(shap_value, 0.0)), + "y_max" = prediction - sum(pmin(shap_value, 0.0)) + ), + by = c("sample_id", facet_by) + ] + y_range <- c(min(y_range_data$y_min, na.rm = TRUE), max(y_range_data$y_max, na.rm = TRUE)) + if (y_range[1L] == y_range[2L]) y_range <- y_range + c(-0.1, 0.1) + } + + .check_input_plot_args(y_range = y_range) + + # x_breaks + if (is.null(y_breaks)) { + .check_input_plot_args( + y_range = y_range, + y_n_breaks = y_n_breaks + ) + + # Create breaks and update x_range + y_breaks <- labeling::extended( + m = y_n_breaks, + dmin = y_range[1L], + dmax = y_range[2L], + only.loose = TRUE + ) + + y_range <- c( + head(y_breaks, n = 1L), + tail(y_breaks, n = 1L) + ) + + } else { + .check_input_plot_args(y_breaks = y_breaks) + } + + # Split data into facets. This is done by row. + data_facet_list <- .split_data_by_plot_facet( + x = x, + plot_layout_table = plot_layout_table + ) + + # Used for ordering of composite figures. + layout_split <- split( + plot_layout_table, + by = c("col_id", "row_id"), + sorted = TRUE + ) + + # Placeholders for plots. + figure_list <- list() + extracted_element_list <- list() + + # Iterate over facets + for (ii in names(layout_split)) { + # Create calibration plot. + p_shap_force <- .create_shap_force_plot( + x = data_facet_list[[ii]], + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme, + discrete_palette = discrete_palette, + x_label = x_label, + y_label = y_label, + legend_label = legend_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption, + y_range = y_range, + y_breaks = y_breaks, + highlight_feature = highlight_feature, + sample_order = sample_order + ) + + # Rename plot elements. + g_shap_force <- .rename_plot_grobs( + g = .convert_to_grob(p_shap_force), + extension = "main" + ) + if (!gtable::is.gtable(g_shap_force)) next + + # Attach to figure list. + figure_list[[paste0(layout_split[[ii]]$row_id, ".", layout_split[[ii]]$col_id)]] <- as_familiar_plot( + g = g_shap_force, + layout = layout_split[[ii]] + ) + } + + # Compose the final figure. Magic. + g <- .compose_figure( + figure_list = figure_list, + plot_layout_table = plot_layout_table, + x_text_shared = x_label_shared, + x_label_shared = x_label_shared, + y_text_shared = y_label_shared, + y_label_shared = y_label_shared, + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme + ) + + return(g) +} + + + +.create_shap_force_plot <- function( + x, + facet_by, + facet_wrap_cols, + ggtheme, + discrete_palette, + x_label, + y_label, + legend_label, + plot_title, + plot_sub_title, + caption, + y_range, + y_breaks, + highlight_feature, + sample_order +) { + # Suppress NOTES due to non-standard evaluation in data.table + shap_value <- vimp <- feature_value <- feature_name <- NULL + feature_label <- prediction <- y <- label_text <- NULL + + # The force plot has two axes: a sample axis, and a prediction axis. By + # default, samples are sorted according to the prediction value within the + # facet. For each sample, the marginal feature value contributions to the + # prediction are sorted by the absolute value of the contribution. + + # Set sample order in each facet. + if (sample_order == "prediction") { + + # Order samples by increasing predicted value. + prediction_table <- unique(x[, mget(c("prediction", "sample_id"))]) + prediction_table[, "sample_order" := order(order(prediction, decreasing = FALSE))] + + x <- merge( + x = x, + y = prediction_table[, "prediction" := NULL], + by = "sample_id" + ) + + } else if (sample_order == "original") { + sample_table <- unique(x[, mget(c("sample_id"))]) + sample_table[, "sample_order" := .I] + + x <- merge( + x = x, + y = sample_table, + by = "sample_id" + ) + + } else { + ..error_reached_unreachable_code(paste0("encountered invalid value for sample_order: ", sample_order)) + } + + # Update start and end positions for force elements. + x[ + , + (c("shap_start", "shap_end")) := ..set_shap_force_positions(shap_value, prediction), + by = c(facet_by, "sample_id") + ] + + + # Create a legend label. + legend_label <- .create_plot_legend_title( + user_label = legend_label, + color_by = "shap_value" + ) + + # Check remaining input arguments. + .check_input_plot_args( + legend_label = legend_label + ) + + # Add gradient palette. + discrete_palette <- .get_palette( + x = discrete_palette, + palette_type = "qualitative", + n = 2L + ) + x[, "shap_positive" := shap_value >= 0.0] + x[, "shap_highlight" := feature_name %in% highlight_feature] + + # Set up basic force plot. + p <- ggplot2::ggplot(data = x) + p <- p + ggtheme + p <- p + geom_fam_force_shap( + data = x, + mapping = ggplot2::aes( + x = !!sym("sample_order"), + xmin = !!sym("sample_order") - 0.4, + xmax = !!sym("sample_order") + 0.4, + y = !!sym("prediction"), + ymin = !!sym("shap_start"), + ymax = !!sym("shap_end"), + fill = !!sym("shap_positive"), + colour = !!sym("shap_positive"), + alpha = !!sym("shap_highlight") + ) + ) + + # Set alpha values. + p <- p + ggplot2::scale_alpha_manual( + values = c("TRUE" = 1.0, "FALSE" = 0.4), + guide = "none" + ) + + # Set colour and fill. + p <- p + ggplot2::scale_fill_manual( + values = c("FALSE" = discrete_palette[1L], "TRUE" = discrete_palette[2L]), + guide = "none", + aesthetics = c("colour", "fill") + ) + + # Determine how things are faceted. + facet_by_list <- .parse_plot_facet_by( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + if (!is.null(facet_by)) { + if (is.null(facet_wrap_cols)) { + # Use a grid + p <- p + ggplot2::facet_grid( + rows = facet_by_list$facet_rows, + cols = facet_by_list$facet_cols, + labeller = "label_context" + ) + + } else { + p <- p + ggplot2::facet_wrap( + facets = facet_by_list$facet_by, + labeller = "label_context" + ) + } + } + + # Update labels. + p <- p + ggplot2::labs( + x = x_label, + y = y_label, + title = plot_title, + subtitle = plot_sub_title, + caption = caption + ) + + # Set breaks and limits on the x and y-axis + # p <- p + ggplot2::scale_x_continuous(breaks = x_breaks) + p <- p + ggplot2::scale_y_continuous(breaks = y_breaks, limits = y_range) + + return(p) +} + + + +..set_shap_force_positions <- function(x, predictions) { + # Prevent notes. + feature_value <- density <- y_offset <- NULL + + # Initialise. + x_start <- x_end <- numeric(length(x)) + + # Set feature order based on the absolute shap value. + feature_order <- order(abs(x), decreasing = TRUE) + + # Initialise positions. + previous_end_pos <- previous_end_neg <- utils::head(predictions, n = 1L) + + # We fill start and end positions starting with the most + # important feature first. + for (ii in feature_order) { + if (x[ii] >= 0.0){ + x_start[ii] <- previous_end_pos + previous_end_pos <- x_end[ii] <- previous_end_pos - x[ii] + + } else { + x_start[ii] <- previous_end_neg + previous_end_neg <- x_end[ii] <- previous_end_neg - x[ii] + } + } + + return(list( + "shap_start" = x_start, + "shap_end" = x_end + )) +} + +# +# +# ..set_shap_waterfall_feature_name_value <- function( +# feature_name, +# feature_value, +# feature_label +# ) { +# actual_label <- feature_label +# actual_label[is.na(feature_label)] <- signif(feature_value[is.na(feature_label)], 3L) +# +# return(paste0(feature_name, ": ", actual_label)) +# } + + + +.determine_shap_force_plot_dimensions <- function( + x, + x_axis_by, + y_axis_by, + facet_by, + facet_wrap_cols +) { + + # Obtain facetting dimensions + plot_dims <- .get_plot_layout_dims( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Set default height and width for each subplot (in cm). + default_width <- 6.0 + default_height <- 4.0 + + # Set overall plot height, but limit to small-margin A4 (27.7 cm) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) + + # Set overall plot width, but limit to small-margin A4 (19 cm) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) + + return(c(height, width)) +} + +# GeomSHAPForce ---------------------------------------------------------------- + +# Placeholder to prevent NOTES if ggplot2 is not installed. +GeomSHAPForce <- NULL +if (rlang::is_installed("ggplot2")) { + GeomSHAPForce <- ggplot2::ggproto( + "GeomPolygon", + ggplot2::Geom, + required_aes = c("x", "xmin", "xmax", "y", "ymin", "ymax"), + default_aes = ggplot2::aes( + colour = NA, + fill = "grey35", + linewidth = 0.5, + linetype = 1, + alpha = NA + ), + draw_key = ggplot2::draw_key_polygon, + draw_panel = function( + data, + panel_params, + coord, + lineend = "butt", + linejoin = "round", + linemitre = 10 + ) { + # Compute coordinates based on data. + coords <- coord$transform(data, panel_params) + + # Instantiate parameters to feed to grid::polygonGrob. These vectors are + # sufficiently large to hold all polygons with taper. + x <- y <- numeric(nrow(coords) * 6L) + id <- integer(nrow(coords) * 6L) + + # Iterate over features. + idx_offset <- 0L + for (ii in seq_len(nrow(coords))) { + # x is over the samples; y is over the predictions. + x_min <- coords$xmin[ii] + x_max <- coords$xmax[ii] + y_min <- coords$ymin[ii] + y_max <- coords$ymax[ii] + + idx <- idx_offset + (1L:6L) + + if (y_max <= y_min) { + y_max_flank <- y_max - 0.01 + y_min_flank <- y_min - 0.01 + + } else { + y_max_flank <- y_max + 0.01 + y_min_flank <- y_min + 0.01 + } + + x_mid <- (x_min + x_max) / 2.0 + + x[idx] <- c(x_min, x_mid, x_max, x_max, x_mid, x_min) + y[idx] <- c(y_max_flank, y_max, y_max_flank, y_min_flank, y_min, y_min_flank) + + # Set grouping. + id[idx] <- ii + + # Update offset. + idx_offset <- idx_offset + length(idx) + } + + # Select elements which are correctly set. + valid_idx <- id > 0L + + return(grid::polygonGrob( + x[valid_idx], + y[valid_idx], + id = id[valid_idx], + default.units = "native", + gp = grid::gpar( + col = coords$colour, + fill = ggplot2::fill_alpha(coords$fill, coords$alpha), + lwd = coords$linewidth * ggplot2::.pt, + lty = coords$linetype, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) + )) + } + ) +} + + + +geom_fam_force_shap <- function( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + ... +) { + ggplot2::layer( + geom = GeomSHAPForce, + mapping = mapping, + data = data, + stat = stat, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) +} diff --git a/R/PlotShapSummary.R b/R/PlotShapSummary.R new file mode 100644 index 00000000..54af2c1d --- /dev/null +++ b/R/PlotShapSummary.R @@ -0,0 +1,964 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# plot_shap_summary (generic) -------------------------------------------------- + +#' @title Plot SHAP summary. +#' +#' @description This method creates plots that show a summary of SHAP values +#' obtained from the data stored in a familiarCollection object. +#' +#' @param dir_path (*optional*) Path to the directory where created SHAP summary +#' plots are saved to. Output is saved in the `explanation` subdirectory. If +#' `NULL` no figures are saved, but are returned instead. +#' @param plot_type (*optional*) Type of plot to draw. This is one of +#' `swarmplot` (draws a beeswarm plot), `barplot` (draws a barplot), +#' `boxplot` (draws a boxplot) and `violinplot` (draws a violin plot). +#' Defaults to `boxplot` if a single SHAP value is available for each feature, +#' and `swarmplot` otherwise. +#' +#' The choice for `plot_type` affects several other arguments. +#' @param discrete_palette (*optional*) Palette for colouring plot elements +#' indicated by the `color_by` argument (if any). Only used if `plot_type` is +#' not `swarmplot`. `familiar` has a default palette. Other palettes are +#' supported by the `paletteer` package, `grDevices::palette.pals()` (requires +#' R >= 4.0.0), `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, +#' `heat.colors`, `terrain.colors`, `topo.colors` and `cm.colors`, which +#' correspond to the palettes of the same name in `grDevices`. You may also +#' specify your own palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. +#' @param gradient_palette (*optional*) Sequential or divergent palette used to +#' colour the points the raster in the default `swarmplot` plots. This +#' argument is not used for other `plot_type` value. `familiar` has a default +#' palette. Other palettes are supported by the `paletteer` package, +#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` +#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, +#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same +#' name in `grDevices`. You may also specify your own palette by providing a +#' vector of colour names listed by `grDevices::colors()` or through +#' hexadecimal RGB strings. +#' @param value_representation (*optional*) Indicates how SHAP values are +#' represented, with the following options: +#' +#' * `raw` (default for `swarmplot`, `boxplot`, and `violinplot` plot +#' types): uses SHAP values as they are. +#' +#' * `abs`: uses absolute value of SHAP values. +#' +#' * `abs_mean` (default for `barplot` plot type): uses mean absolute value of +#' SHAP values. Only used by `barplot`. +#' +#' * `abs_max`: uses maximum absolute value of SHAP values. Only used by +#' `barplot`. +#' +#' * `abs_min`: uses minimum absolute value of SHAP values. Only used by +#' `barplot`. +#' +#' If `abs_mean`, `abs_max` or `abs_min` are chosen, `plot_type` automatically +#' switches to `barplot`. +#' +#' @inheritParams as_familiar_collection +#' @inheritParams plot_univariate_importance +#' @inheritParams .check_input_plot_args +#' @inheritParams .check_plot_splitting_variables +#' @inheritDotParams extract_performance -object +#' @inheritDotParams as_familiar_collection -object +#' @inheritDotParams ggplot2::ggsave -height -width -units -path -filename -plot +#' +#' @details This function creates SHAP summary plots, which provide an overview +#' of marginal contributions of feature values to the predicted values. +#' +#' Available splitting variables are: `vimp_method`, `learner`, `data_set`, +#' `evaluation_time` (survival outcome only) and `positive_class` (categorical +#' outcomes). The default for `value_representation = "raw"` is to facet by +#' `evaluation_time` or `positive_class`, and split by `vimp_method` and +#' `learner`. `color_by` is not used. The default for other +#' `value_representation` is to `color_by` `evaluation_time` or +#' `positive_class`, and split by `vimp_method`, `learner` and `data_set`. +#' +#' Labelling methods such as `set_vimp_method_names` or `set_learner_names` +#' can be applied to the `familiarCollection` object to update labels, and +#' order the output in the figure. +#' +#' @return `NULL` or list of plot objects, if `dir_path` is `NULL`. +#' +#' @exportMethod plot_shap_summary +#' @md +#' @rdname plot_shap_summary-methods +setGeneric( + "plot_shap_summary", + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + color_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + plot_type = NULL, + value_representation = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + standardGeneric("plot_shap_summary") + } +) + + + +# plot_shap_summary (general) -------------------------------------------------- + +#' @rdname plot_shap_summary-methods +setMethod( + "plot_shap_summary", + signature(object = "ANY"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + color_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + plot_type = NULL, + value_representation = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Attempt conversion to familiarCollection object. + object <- do.call( + as_familiar_collection, + args = c( + list( + "object" = object, + "data_element" = "shap" + ), + list(...) + ) + ) + + return(do.call( + plot_shap_summary, + args = list( + "object" = object, + "draw" = draw, + "dir_path" = dir_path, + "split_by" = split_by, + "x_axis_by" = x_axis_by, + "y_axis_by" = y_axis_by, + "color_by" = color_by, + "facet_by" = facet_by, + "facet_wrap_cols" = facet_wrap_cols, + "ggtheme" = ggtheme, + "plot_type" = plot_type, + "value_representation" = value_representation, + "discrete_palette" = discrete_palette, + "gradient_palette" = gradient_palette, + "x_label" = x_label, + "y_label" = y_label, + "legend_label" = legend_label, + "plot_title" = plot_title, + "plot_sub_title" = plot_sub_title, + "caption" = caption, + "limit_n_features" = limit_n_features, + "x_range" = x_range, + "x_n_breaks" = x_n_breaks, + "x_breaks" = x_breaks, + "width" = width, + "height" = height, + "units" = units, + "export_collection" = export_collection + ) + )) + } +) + + + +# plot_shap_summary (collection) ----------------------------------------------- + +#' @rdname plot_shap_summary-methods +setMethod( + "plot_shap_summary", + signature(object = "familiarCollection"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + color_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + plot_type = NULL, + value_representation = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Make sure the collection object is updated. + object <- update_object(object = object) + + # Check input arguments ---------------------------------------------------- + + # ggtheme + ggtheme <- .check_ggtheme(ggtheme) + + # Load the data. + x <- export_shap(object = object) + x <- x$shap_summary + if (is_empty(x)) return(NULL) + + # Obtain single data element from list. + if (is.list(x)) { + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_shap_summary: list of data elements contains unmerged elements." + ) + } + x <- x[[1L]] + } + + # Check that the data are not evaluated at the model level. + if (x@detail_level == "model") { + ..warning_no_comparison_between_models() + return(NULL) + } + + # Check that the data are not empty. + if (is_empty(x)) return(NULL) + + # Ensure that we work with a copy of the data. + x@data <- data.table::copy(x@data) + + # Check package requirements for plotting. + if (!require_package( + x = ..required_plotting_packages(extended = FALSE), + purpose = "to create a SHAP summary plot", + message_type = "warning" + )) { + return(NULL) + } + + # Check whether one or multiple SHAP-values are available for each feature. + value_data <- x@data[, list("n" = .N), by = setdiff(x@grouping_column, c("sample_id", "feature_value", "feature_label"))] + is_single_sample <- all(value_data$n == 1L) + + # Set initial estimates for plot-type. If only a single SHAP value is + # present, use barplot. Otherwise, if unset, use swarmplot. + if (is_single_sample) { + plot_type <- "barplot" + if (is.waive(x_label) && is.null(value_representation)) { + x_label <- "SHAP" + } + } else if (is.null(plot_type)) { + plot_type <- "swarmplot" + } + + # Check value representation. If unset, the default for barplots is + # abs_mean; and raw otherwise. Furthermore, ensure that color_by + # is reserved for feature values when using "raw". + if (is.null(value_representation)) { + if (plot_type == "barplot") { + value_representation <- "abs_mean" + + } else { + value_representation <- "raw" + color_by <- NULL + } + } + .check_parameter_value_is_valid( + x = value_representation, + var_name = "value_representation", + values = c("raw", "abs", "abs_mean", "abs_max", "abs_min") + ) + + # For abs_mean, abs_max and abs_min, force plot_type to be "bar_plot" + if (value_representation %in% c("abs_mean", "abs_max", "abs_min")) { + plot_type <- "barplot" + } + + # Check plot_type. + .check_parameter_value_is_valid( + x = plot_type, + var_name = "plot_type", + values = c("swarmplot", "barplot", "boxplot", "violinplot") + ) + + # Add evaluation time as a splitting variable. + additional_variable <- NULL + if (object@outcome_type %in% c("survival")) { + additional_variable <- "evaluation_time" + data.table::setnames(x@data, old = "shap_outcome", new = "evaluation_time") + + } else if (object@outcome_type %in% c("multinomial")) { + additional_variable <- "positive_class" + data.table::setnames(x@data, old = "shap_outcome", new = "positive_class") + } + + # Add default splitting variables. + all_variables <- c("vimp_method", "learner", "data_set", additional_variable) + if ( + is.null(split_by) && + is.null(color_by) && + is.null(facet_by) + ) { + # Split by vimp_method and learner. + split_by <- c("vimp_method", "learner", "data_set") + + # Set facetting and color_by variables. + if (plot_type == "bar_plot") { + color_by <- additional_variable + + } else if (value_representation == "raw" && plot_type == "swarmplot") { + color_by <- NULL + facet_by <- additional_variable + + } else { + color_by <- additional_variable + } + } + + # Check splitting variables and generate sanitised output + split_var_list <- .check_plot_splitting_variables( + x = x@data, + split_by = split_by, + color_by = color_by, + facet_by = facet_by, + available = all_variables + ) + + # Update splitting variables + split_by <- split_var_list$split_by + color_by <- split_var_list$color_by + facet_by <- split_var_list$facet_by + + # x_label + if (is.waive(x_label)) { + x_label <- switch( + value_representation, + raw = "SHAP", + abs = "|SHAP|", + abs_mean = "mean(|SHAP|)", + abs_max = "max(|SHAP|)", + abs_min = "min(|SHAP|)" + ) + } + + # y_label + if (is.waive(y_label)) { + y_label <- "feature" + } + + .check_input_plot_args( + facet_wrap_cols = facet_wrap_cols, + x_label = x_label, + y_label = y_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption, + limit_n_features = limit_n_features + ) + + # Create plots ------------------------------------------------------------- + + # Determine if subtitle should be generated. + autogenerate_plot_subtitle <- is.waive(plot_sub_title) + + # Split data. + if (!is.null(split_by)) { + x_split <- split( + x@data, + by = split_by, + drop = FALSE + ) + + } else { + x_split <- list("null.name" = x@data) + } + + # Store plots to list in case dir_path is absent. + if (is.null(dir_path)) plot_list <- list() + + # Iterate over data splits. + for (ii in names(x_split)) { + # Skip empty datasets. + if (is_empty(x_split[[ii]])) next + + if (is.waive(plot_title)) plot_title <- "SHAP summary" + + # Declare subtitle components. + additional_subtitle <- NULL + + # Add evaluation time as subtitle component if it is not used + # otherwise. + if ( + !"evaluation_time" %in% c(split_by, color_by, facet_by) && + object@outcome_type %in% c("survival") + ) { + additional_subtitle <- c( + additional_subtitle, + .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1L]) + ) + } + + if (autogenerate_plot_subtitle) { + plot_sub_title <- .create_plot_subtitle( + split_by = split_by, + additional = additional_subtitle, + x = x_split[[ii]] + ) + } + + # Generate plot + p <- .plot_shap_summary_plot( + x = x_split[[ii]], + color_by = color_by, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols, + plot_type = plot_type, + value_representation = value_representation, + ggtheme = ggtheme, + discrete_palette = discrete_palette, + gradient_palette = gradient_palette, + x_label = x_label, + y_label = y_label, + legend_label = legend_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption, + limit_n_features = limit_n_features, + x_range = x_range, + x_n_breaks = x_n_breaks, + x_breaks = x_breaks, + outcome_type = object@outcome_type + ) + + # Check empty output + if (is.null(p)) next + + # Draw figure. + if (draw) .draw_plot(plot_or_grob = p) + + # Save and export + if (!is.null(dir_path)) { + # Obtain decent default values for the plot. + def_plot_dims <- .determine_shap_summary_plot_dimensions( + x = x_split[[ii]], + plot_type = plot_type, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Save to file. + do.call( + .save_plot_to_file, + args = c( + list( + "plot_or_grob" = p, + "object" = object, + "dir_path" = dir_path, + "type" = "explanation", + "subtype" = paste0("shap", "_", plot_type, "_", value_representation), + "x" = x_split[[ii]], + "split_by" = split_by, + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) + + } else { + # Store as list for export. + plot_list <- c(plot_list, list(p)) + } + } + + # Generate output + return(.get_plot_results( + dir_path = dir_path, + plot_list = plot_list, + export_collection = export_collection, + object = object + )) + } +) + + + +.plot_shap_summary_plot <- function( + x, + color_by, + facet_by, + facet_wrap_cols, + plot_type, + value_representation, + ggtheme, + discrete_palette, + gradient_palette, + x_label, + y_label, + legend_label, + plot_title, + plot_sub_title, + caption, + limit_n_features, + x_range, + x_n_breaks, + x_breaks, + outcome_type +) { + # Suppress NOTES due to non-standard evaluation in data.table + shap_value <- vimp <- feature_value <- feature_name <- NULL + + value_group_columns <- c("vimp_method", "learner", "feature_name") + if ("evaluation_time" %in% colnames(x)) value_group_columns <- c(value_group_columns, "evaluation_time") + if ("positive_class" %in% colnames(x)) value_group_columns <- c(value_group_columns, "positive_class") + + # Apply representation. + if (value_representation == "abs") { + x[, "shap_value" := abs(shap_value)] + + } else if (value_representation == "abs_mean") { + x <- x[, list("shap_value" = mean(abs(shap_value))), by = value_group_columns] + + } else if (value_representation == "abs_max") { + x <- x[, list("shap_value" = max(abs(shap_value))), by = value_group_columns] + + } else if (value_representation == "abs_min") { + x <- x[, list("shap_value" = min(abs(shap_value))), by = value_group_columns] + } + + # Map feature values to (-1, 1) range for raw representation. + if (value_representation == "raw") { + x[ + , + "feature_value" := 2.0 * (feature_value - min(feature_value)) / (max(feature_value) - min(feature_value))- 1.0, + by = "feature_name" + ] + } + + # Sort features by importance (mean absolute SHAP). + feature_importance <- x[, list("vimp" = mean(abs(shap_value))), by = value_group_columns] + feature_importance <- feature_importance[, list("vimp" = max(vimp)), by = "feature_name"][order(vimp)] + + # Determine the features that need to be plotted. + if (is.numeric(limit_n_features)) { + # Explicitly select features based on threshold value instead of simply + # selecting the best features: features may have the same value because they + # belong to the same cluster. + threshold_value <- min(tail(unique(sort(feature_importance$vimp)), n = limit_n_features)) + selected_features <- feature_importance[vimp >= threshold_value]$feature_name + + # Make slice. + x <- x[feature_name %in% selected_features, ] + feature_importance <- feature_importance[feature_name %in% selected_features, ][order(vimp)] + } + + x$feature_name <- factor( + x = x$feature_name, + levels = feature_importance$feature_name + ) + + # Check x-range. + if (is.null(x_range)) { + if (value_representation == "raw") { + x_range <- c(min(x$shap_value, na.rm = TRUE), max(x$shap_value, na.rm = TRUE)) + + } else { + x_range <- c(0.0, max(x$shap_value, na.rm = TRUE)) + } + + } else { + .check_input_plot_args(x_range = x_range) + } + + # Check that the range is not closed. + if (all(x_range == 0.0)) { + x_range[2L] <- 0.1 + } + + # x_breaks + if (is.null(x_breaks)) { + .check_input_plot_args( + x_range = x_range, + x_n_breaks = x_n_breaks + ) + + # Create breaks and update x_range + x_breaks <- labeling::extended( + m = x_n_breaks, + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) + + x_range <- c( + head(x_breaks, n = 1L), + tail(x_breaks, n = 1L) + ) + + } else { + .check_input_plot_args(x_breaks = x_breaks) + } + + # Create a legend label. + legend_label <- .create_plot_legend_title( + user_label = legend_label, + color_by = if(value_representation == "raw") "feature_value" else color_by + ) + + # Check remaining input arguments. + .check_input_plot_args( + legend_label = legend_label + ) + + # Generate a guide table + guide_list <- .create_plot_guide_table( + x = x, + color_by = color_by, + discrete_palette = discrete_palette + ) + + # Extract data + x <- guide_list$data + + # Extract guide_table for color. + g_color <- guide_list$guide_color + + # Create basic plot + p <- ggplot2::ggplot( + data = x, + mapping = ggplot2::aes( + x = !!sym("shap_value"), + y = !!sym("feature_name") + )) + p <- p + ggtheme + + # Set breaks and range. + p <- p + ggplot2::scale_x_continuous(breaks = x_breaks) + p <- p + ggplot2::coord_cartesian(xlim = x_range) + + if (plot_type == "swarmplot") { + # Swarm plot --------------------------------------------------------------- + + # Determine the density of points for each feature as function of the + # shap-value. + grouping_variables <- c("feature_name", facet_by) + if (!is.null(color_by)) { + grouping_variables <- c(grouping_variables, "color_breaks") + } + + x[ + , + "y_offset" := ..set_shap_swarmplot_jitter(shap_value, feature_value, value_representation = value_representation), + by = c("feature_name", facet_by, color_by) + ] + + if (value_representation == "raw") { + p <- p + ggplot2::geom_point( + mapping = ggplot2::aes(color = !!sym("feature_value")), + position = ggplot2::position_nudge(y = x$y_offset) + ) + + # Colors + gradient_colours <- .get_palette( + x = gradient_palette, + palette_type = "divergent" + ) + + # Add gradient palette. + p <- p + ggplot2::scale_colour_gradientn( + name = legend_label, + colors = gradient_colours, + limits = c(-1.0, 1.0) + ) + + } else if (is.null(color_by)) { + p <- p + ggplot2::geom_point(position = ggplot2::position_nudge(y = x$y_offset)) + + } else { + p <- p + ggplot2::geom_jitter( + mapping = ggplot2::aes(color = !!sym("color_breaks")), + position = ggplot2::position_nudge(y = x$y_offset) + ) + + # Set fill colours. + p <- p + ggplot2::scale_color_manual( + name = legend_label$guide_color, + values = g_color$color_values, + breaks = g_color$color_breaks, + drop = FALSE + ) + } + + } else if (plot_type == "barplot") { + # Barplot ------------------------------------------------------------------ + + if (is.null(color_by)) { + p <- p + ggplot2::geom_bar( + stat = "identity", + position = ggplot2::position_dodge(width = 0.9), + ) + + } else { + # Add barplot. + p <- p + ggplot2::geom_bar( + mapping = ggplot2::aes( + fill = !!sym("color_breaks") + ), + stat = "identity", + position = ggplot2::position_dodge(width = 0.9) + ) + + # Set fill colours. + p <- p + ggplot2::scale_fill_manual( + name = legend_label$guide_color, + values = g_color$color_values, + breaks = g_color$color_breaks, + drop = FALSE + ) + } + + } else if (plot_type == "boxplot") { + # Boxplot ------------------------------------------------------------------ + + if (is.null(color_by)) { + p <- p + ggplot2::geom_boxplot() + + } else { + p <- p + ggplot2::geom_boxplot( + mapping = ggplot2::aes( + colour = !!sym("color_breaks") + ) + ) + + # Set fill colours. + p <- p + ggplot2::scale_colour_manual( + name = legend_label$guide_color, + values = g_color$color_values, + breaks = g_color$color_breaks, + drop = FALSE + ) + } + + } else if (plot_type == "violinplot") { + # Violinplot --------------------------------------------------------------- + + if (is.null(color_by)) { + # Create boxplot. + p <- p + ggplot2::geom_violin( + quantiles = c(0.025, 0.5, 0.975), + quantile.linetype = ggtheme$line$linetype, + scale = "width", + position = ggplot2::position_dodge(width = 1.0) + ) + + } else { + # Create boxplot. + p <- p + ggplot2::geom_violin( + mapping = ggplot2::aes( + fill = !!sym("color_breaks") + ), + quantiles = c(0.025, 0.5, 0.975), + quantile.linetype = ggtheme$line$linetype, + scale = "width", + position = ggplot2::position_dodge(width = 1.0) + ) + + # Set fill colours. + p <- p + ggplot2::scale_fill_manual( + name = legend_label$guide_color, + values = g_color$color_values, + breaks = g_color$color_breaks, + drop = FALSE + ) + } + } + + # Determine how things are faceted. + facet_by_list <- .parse_plot_facet_by( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + if (!is.null(facet_by)) { + if (is.null(facet_wrap_cols)) { + # Use a grid + p <- p + ggplot2::facet_grid( + rows = facet_by_list$facet_rows, + cols = facet_by_list$facet_cols, + labeller = "label_context" + ) + + } else { + p <- p + ggplot2::facet_wrap( + facets = facet_by_list$facet_by, + labeller = "label_context" + ) + } + } + + # Update labels. + p <- p + ggplot2::labs( + x = x_label, + y = y_label, + title = plot_title, + subtitle = plot_sub_title, + caption = caption + ) + + return(p) +} + + + +..set_shap_swarmplot_jitter <- function(x, value, value_representation = "raw") { + # Prevent notes. + feature_value <- density <- y_offset <- NULL + + # Get density. In edge cases, this will fail (e.g. too few samples to + # establish a bandwidth for the filter.) + density_object <- tryCatch( + stats::density(x = x), + error = identity + ) + + if (inherits(density_object, "density")) { + # Find density at every point and normalise. + data <- data.table::data.table( + "original_order" = seq_along(x), + "shap_value" = x, + "feature_value" = value, + "density" = stats::approx( + x = density_object$x, + y = density_object$y, + xout = x + )$y + ) + data[, "density" := density / max(density)] + + } else if (length(x) == 1L) { + data <- data.table::data.table( + "original_order" = seq_along(x), + "shap_value" = x, + "feature_value" = value, + "density" = 0.0 + ) + + } else { + data <- data.table::data.table( + "original_order" = seq_along(x), + "shap_value" = x, + "feature_value" = value, + "density" = 1.0 + ) + } + + if (value_representation == "raw") { + offset <- stats::rnorm(n = length(x), mean = 0.0, sd = 0.1) + offset[offset < -0.3] <- -0.3 + offset[offset > 0.3] <- 0.3 + data[, "y_offset" := (feature_value + offset) * density] + data[, "y_offset" := 0.25 * y_offset / max(abs(y_offset))] + + } else { + offset <- stats::runif(n = length(x), min = -1.0, max = 1.0) + data[, "y_offset" := offset * density] + data[, "y_offset" := 0.25 * y_offset / max(abs(y_offset))] + } + + # Replace NaN-values. + data[is.na(y_offset), "y_offset" := 0.0] + + return(data$y_offset) +} + + + +.determine_shap_summary_plot_dimensions <- function( + x, + plot_type, + x_axis_by, + y_axis_by, + facet_by, + facet_wrap_cols +) { + + # Obtain facetting dimensions + plot_dims <- .get_plot_layout_dims( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Set default height and width for each subplot (in cm). + default_width <- 6.0 + default_height <- 4.0 + + # Set overall plot height, but limit to small-margin A4 (27.7 cm) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) + + # Set overall plot width, but limit to small-margin A4 (19 cm) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) + + return(c(height, width)) +} diff --git a/R/PlotShapWaterfall.R b/R/PlotShapWaterfall.R new file mode 100644 index 00000000..7b326faf --- /dev/null +++ b/R/PlotShapWaterfall.R @@ -0,0 +1,898 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# plot_shap_waterfall (generic) ------------------------------------------------ + +#' @title Create SHAP waterfall plot +#' +#' @description This method creates plots that show a waterfall of SHAP values +#' obtained from the data stored in a familiarCollection object. +#' +#' @param dir_path (*optional*) Path to the directory where created +#' plots are saved to. Output is saved in the `explanation` subdirectory. If +#' `NULL` no figures are saved, but are returned instead. +#' @param gradient_palette (*optional*) Divergent palette used to +#' colour the elements of waterfall plots. `familiar` has a default +#' palette. Other palettes are supported by the `paletteer` package, +#' `grDevices::palette.pals()` (requires R >= 4.0.0), `grDevices::hcl.pals()` +#' (requires R >= 3.6.0) and `rainbow`, `heat.colors`, `terrain.colors`, +#' `topo.colors` and `cm.colors`, which correspond to the palettes of the same +#' name in `grDevices`. You may also specify your own palette by providing a +#' vector of colour names listed by `grDevices::colors()` or through +#' hexadecimal RGB strings. +#' @inheritParams as_familiar_collection +#' @inheritParams plot_univariate_importance +#' @inheritParams .check_input_plot_args +#' @inheritParams .check_plot_splitting_variables +#' @inheritDotParams extract_performance -object +#' @inheritDotParams as_familiar_collection -object +#' @inheritDotParams ggplot2::ggsave -height -width -units -path -filename -plot +#' +#' @details This function creates SHAP waterfall plots, which show the +#' individual marginal contributions of feature values to the predicted value. +#' +#' Available splitting variables are: `vimp_method`, `learner`, `data_set`, +#' `evaluation_time` (survival outcome only) and `positive_class` (categorical +#' outcomes), `sample_id`. The default for is to facet by `evaluation_time` or +#' `positive_class`, and split by `vimp_method`, +#' `learner`, `data_set`, and `sample_id`. `color_by` is not used. +#' +#' Labelling methods such as `set_vimp_method_names` or `set_learner_names` +#' can be applied to the `familiarCollection` object to update labels, and +#' order the output in the figure. +#' +#' @return `NULL` or list of plot objects, if `dir_path` is `NULL`. +#' +#' @exportMethod plot_shap_waterfall +#' @md +#' @rdname plot_shap_waterfall-methods +setGeneric( + "plot_shap_waterfall", + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + standardGeneric("plot_shap_waterfall") + } +) + + + +# plot_shap_waterfall (general) ------------------------------------------------ + +#' @rdname plot_shap_waterfall-methods +setMethod( + "plot_shap_waterfall", + signature(object = "ANY"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Attempt conversion to familiarCollection object. + object <- do.call( + as_familiar_collection, + args = c( + list( + "object" = object, + "data_element" = "shap" + ), + list(...) + ) + ) + + return(do.call( + plot_shap_waterfall, + args = list( + "object" = object, + "draw" = draw, + "dir_path" = dir_path, + "split_by" = split_by, + "x_axis_by" = x_axis_by, + "y_axis_by" = y_axis_by, + "facet_by" = facet_by, + "facet_wrap_cols" = facet_wrap_cols, + "ggtheme" = ggtheme, + "gradient_palette" = gradient_palette, + "x_label" = x_label, + "y_label" = y_label, + "legend_label" = legend_label, + "plot_title" = plot_title, + "plot_sub_title" = plot_sub_title, + "caption" = caption, + "limit_n_features" = limit_n_features, + "x_range" = x_range, + "x_n_breaks" = x_n_breaks, + "x_breaks" = x_breaks, + "width" = width, + "height" = height, + "units" = units, + "export_collection" = export_collection + ) + )) + } +) + + + +# plot_shap_waterfall (collection) ----------------------------------------------- + +#' @rdname plot_shap_waterfall-methods +setMethod( + "plot_shap_waterfall", + signature(object = "familiarCollection"), + function( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... + ) { + # Make sure the collection object is updated. + object <- update_object(object = object) + + # Check input arguments ---------------------------------------------------- + + # ggtheme + ggtheme <- .check_ggtheme(ggtheme) + + # Load the data. + x <- export_shap(object = object) + + x <- x$shap_force + if (is_empty(x)) return(NULL) + + # Obtain single data element from list. + if (is.list(x)) { + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_shap_waterfall: list of data elements contains unmerged elements." + ) + } + x <- x[[1L]] + } + + # Check that the data are not evaluated at the model level. + if (x@detail_level == "model") { + ..warning_no_comparison_between_models() + return(NULL) + } + + # Check that the data are not empty. + if (is_empty(x)) return(NULL) + + # Ensure that we work with a copy of the data. + x@data <- data.table::copy(x@data) + + # Check package requirements for plotting. + if (!require_package( + x = ..required_plotting_packages(extended = FALSE), + purpose = "to create a SHAP waterfall plot", + message_type = "warning" + )) { + return(NULL) + } + + # Add evaluation time or class as a splitting variable. + additional_variable <- NULL + if (object@outcome_type %in% c("survival")) { + additional_variable <- "evaluation_time" + data.table::setnames(x@data, old = "shap_outcome", new = "evaluation_time") + + } else if (object@outcome_type %in% c("multinomial")) { + additional_variable <- "positive_class" + data.table::setnames(x@data, old = "shap_outcome", new = "positive_class") + } + + # Add default splitting variables. + if ( + is.null(split_by) && + is.null(facet_by) + ) { + # Split by vimp_method, learner and sample id. + split_by <- c("vimp_method", "learner", "data_set", "sample_id") + facet_by <- additional_variable + } + + all_variables <- c("vimp_method", "learner", "data_set", "sample_id", additional_variable) + + # Check splitting variables and generate sanitised output + split_var_list <- .check_plot_splitting_variables( + x = x@data, + split_by = split_by, + facet_by = facet_by, + available = all_variables + ) + + # Update splitting variables + split_by <- split_var_list$split_by + facet_by <- split_var_list$facet_by + + # x_label + if (is.waive(x_label)) { + x_label <- "predicted value" + } + + # y_label + if (is.waive(y_label)) { + y_label <- "feature" + } + + .check_input_plot_args( + facet_wrap_cols = facet_wrap_cols, + x_label = x_label, + y_label = y_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption, + limit_n_features = limit_n_features + ) + + # Create plots ------------------------------------------------------------- + + # Determine if subtitle should be generated. + autogenerate_plot_subtitle <- is.waive(plot_sub_title) + + # Split data. + if (!is.null(split_by)) { + x_split <- split( + x@data, + by = split_by, + drop = FALSE + ) + + } else { + x_split <- list("null.name" = x@data) + } + + # Store plots to list in case dir_path is absent. + if (is.null(dir_path)) plot_list <- list() + + # Iterate over data splits. + for (ii in names(x_split)) { + # Skip empty datasets. + if (is_empty(x_split[[ii]])) next + + if (is.waive(plot_title)) plot_title <- "SHAP waterfall" + + # Declare subtitle components. + additional_subtitle <- NULL + + # Add evaluation time as subtitle component if it is not used + # otherwise. + if ( + !"evaluation_time" %in% c(split_by, facet_by) && + object@outcome_type %in% c("survival") + ) { + additional_subtitle <- c( + additional_subtitle, + .add_time_to_plot_subtitle(x_split[[ii]]$evaluation_time[1L]) + ) + } + + if (autogenerate_plot_subtitle) { + plot_sub_title <- .create_plot_subtitle( + split_by = split_by, + additional = additional_subtitle, + x = x_split[[ii]] + ) + } + + # Generate plot + p <- .plot_shap_waterfall_plot( + x = x_split[[ii]], + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols, + ggtheme = ggtheme, + gradient_palette = gradient_palette, + x_label = x_label, + y_label = y_label, + legend_label = legend_label, + plot_title = plot_title, + plot_sub_title = plot_sub_title, + caption = caption, + limit_n_features = limit_n_features, + x_range = x_range, + x_n_breaks = x_n_breaks, + x_breaks = x_breaks + ) + + # Check empty output + if (is.null(p)) next + + # Draw figure. + if (draw) .draw_plot(plot_or_grob = p) + + # Save and export + if (!is.null(dir_path)) { + # Obtain decent default values for the plot. + def_plot_dims <- .determine_shap_waterfall_plot_dimensions( + x = x_split[[ii]], + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Save to file. + do.call( + .save_plot_to_file, + args = c( + list( + "plot_or_grob" = p, + "object" = object, + "dir_path" = dir_path, + "type" = "explanation", + "subtype" = "shap_waterfall", + "x" = x_split[[ii]], + "split_by" = split_by, + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) + + } else { + # Store as list for export. + plot_list <- c(plot_list, list(p)) + } + } + + # Generate output + return(.get_plot_results( + dir_path = dir_path, + plot_list = plot_list, + export_collection = export_collection, + object = object + )) + } +) + + + +.plot_shap_waterfall_plot <- function( + x, + facet_by, + facet_wrap_cols, + ggtheme, + gradient_palette, + x_label, + y_label, + legend_label, + plot_title, + plot_sub_title, + caption, + limit_n_features, + x_range, + x_n_breaks, + x_breaks +) { + # Suppress NOTES due to non-standard evaluation in data.table + shap_value <- vimp <- feature_value <- feature_name <- NULL + feature_label <- prediction <- y <- label_text <- phi_0 <- NULL + + # Sort features by importance (mean absolute SHAP). + feature_importance <- x[, list("vimp" = mean(abs(shap_value))), by = c(facet_by, "feature_name")] + feature_importance <- feature_importance[, list("vimp" = max(vimp)), by = "feature_name"][order(vimp)] + + # Determine the features that need to be plotted. + if (is.numeric(limit_n_features)) { + + # Explicitly select features based on threshold value instead of simply + # selecting the best features: features may have the same value because they + # belong to the same cluster. + threshold_value <- min(tail(unique(sort(feature_importance$vimp)), n = limit_n_features)) + selected_features <- feature_importance[vimp >= threshold_value]$feature_name + + # Determine contribution of features that were not selected (if any) + not_selected_features <- setdiff(feature_importance$feature_name, selected_features) + + if (!is_empty(not_selected_features)) { + # Use a template to prevent having to manually fill out columns that are + # not updated. + x_template <- data.table::copy(x[feature_name == not_selected_features[1L]]) + x_template[, "feature_name" := "other"] + x_template[, "feature_value" := NA_real_] + x_template[, "feature_label" := NA_character_] + x_template[, "shap_value" := NULL] + + other_shap_value <- x[ + feature_name %in% not_selected_features, + list( + "feature_name" = "other", + "shap_value" = sum(shap_value) + ), + by = facet_by + ] + + x_template <- merge( + x = x_template, + y = other_shap_value, + by = c("feature_name", facet_by) + ) + + x <- x[feature_name %in% selected_features, ] + x <- data.table::rbindlist(list(x, x_template), use.names = TRUE) + + feature_importance <- feature_importance[vimp >= threshold_value][order(vimp)] + + x$feature_name <- factor( + x = x$feature_name, + levels = c("other", as.character(feature_importance$feature_name)) + ) + + } else { + # All features were selected: use default procedure. + x$feature_name <- factor( + x = x$feature_name, + levels = feature_importance$feature_name + ) + } + + } else { + # Default procedure without selection. + x$feature_name <- factor( + x = x$feature_name, + levels = feature_importance$feature_name + ) + } + + # Add y (for positioning). + x[, "y" := as.numeric(feature_name)] + + y_label_table <- unique(x[, mget(c("feature_name", "feature_value", "feature_label", "y"))]) + y_label_table[, "feature_name_value" := ..set_shap_waterfall_feature_name_value(feature_name, feature_value, feature_label)] + y_label_table <- y_label_table[order(y)] + + # Common base for formatting prediction and shap values. + common_base <- ..format_get_common_base(c(x$shap_value, x$prediction)) + n_small <- max(c(-(common_base - 2L), 0.0)) + + # Update start and end positions for force elements. + if (!is.null(facet_by)) { + x[, (c("x_start", "x_end")) := ..set_shap_waterfall_positions(shap_value, prediction, feature_name), by = facet_by] + + } else { + x[, (c("x_start", "x_end")) := ..set_shap_waterfall_positions(shap_value, prediction, feature_name)] + } + + # Derive information for the average prediction and extract the instance + # prediction. + if (!is.null(facet_by)) { + f_average_data <- x[, list("prediction" = max(phi_0)), by = facet_by] + } else { + f_average_data <- x[, list("prediction" = max(phi_0))] + } + + f_instance_data <- unique(x[, mget(c("prediction", facet_by))]) + + # Check x-range. + if (!is.null(x_range)) { + .check_input_plot_args(x_range = x_range) + + # x_breaks + if (is.null(x_breaks)) { + .check_input_plot_args( + x_range = x_range, + x_n_breaks = x_n_breaks + ) + + # Create breaks and update x_range + x_breaks <- labeling::extended( + m = x_n_breaks, + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) + + x_range <- c( + head(x_breaks, n = 1L), + tail(x_breaks, n = 1L) + ) + + } else { + .check_input_plot_args(x_breaks = x_breaks) + } + } + + # Create a legend label. + legend_label <- .create_plot_legend_title( + user_label = legend_label, + color_by = "shap_value" + ) + + # Check remaining input arguments. + .check_input_plot_args( + legend_label = legend_label + ) + + # Add gradient palette. + gradient_colours <- .get_palette( + x = gradient_palette, + palette_type = "divergent" + ) + + # Set up shap value labels + x[, "label_align" := data.table::fifelse(shap_value >= 0.0, yes = "left", no = "right")] + x[, "label_colour" := data.table::fifelse(shap_value >= 0.0, yes = tail(gradient_colours, n = 1L), no = head(gradient_colours, n = 1L))] + x[, "label_text" := format(round(shap_value, digits = n_small), nsmall = n_small)] + x[, "label_text" := paste0(" ", label_text, " ")] + + # Set up basic waterfall plot. + p <- ggplot2::ggplot(data = x) + p <- p + ggtheme + p <- p + geom_waterfall_shap( + data = x, + mapping = ggplot2::aes( + x = !!sym("x_start"), + xend = !!sym("x_end"), + y = !!sym("y"), + ymin = !!sym("y") - 0.4, + ymax = !!sym("y") + 0.4, + fill = !!sym("shap_value") + ) + ) + + # Set labels for y-axis. + p <- p + ggplot2::scale_y_continuous( + breaks = y_label_table$y, + labels = y_label_table$feature_name_value + ) + + # Add spacing for text values. + p <- p + ggplot2::scale_x_continuous( + expand = ggplot2::expansion(mult = 0.2) + ) + + p <- p + ggplot2::scale_fill_gradientn( + name = legend_label, + colors = gradient_colours, + limits = c(-max(abs(x$shap_value)), max(abs(x$shap_value))) + ) + + # Add instance and group average prediction. + p <- p + ggplot2::geom_vline( + data = f_average_data, + mapping = ggplot2::aes(xintercept = !!sym("prediction")), + color = "grey80", + linetype = 2L + ) + p <- p + ggplot2::geom_vline( + data = f_instance_data, + mapping = ggplot2::aes(xintercept = !!sym("prediction")), + color = "grey80", + linetype = 2L + ) + + # Use geom-segment to connect segments. + p <- p + ggplot2::geom_segment( + data = x, + mapping = ggplot2::aes( + x = !!sym("x_start"), + xend = !!sym("x_start"), + y = !!sym("y") - 0.5, + yend = !!sym("y") + 0.45, + ), + color = "grey60" + ) + p <- p + ggplot2::geom_segment( + data = x, + mapping = ggplot2::aes( + x = !!sym("x_end"), + xend = !!sym("x_end"), + y = !!sym("y") - 0.45, + yend = !!sym("y") + 0.5, + ), + color = "grey60" + ) + + text_settings <- .get_plot_geom_text_settings(ggtheme = ggtheme) + + # Add shap label. + for (x_text in split(x, by = "label_colour", drop = TRUE)) { + p <- p + ggplot2::geom_text( + data = x_text, + mapping = ggplot2::aes( + x = !!sym("x_end"), + y = !!sym("y"), + label = !!sym("label_text"), + hjust = !!sym("label_align") + ), + colour = head(x_text$label_colour, n = 1L), + family = text_settings$family, + fontface = text_settings$face, + size = text_settings$geom_text_size, + show.legend = FALSE + ) + } + + # Determine how things are faceted. + facet_by_list <- .parse_plot_facet_by( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + if (!is.null(facet_by)) { + if (is.null(facet_wrap_cols)) { + # Use a grid + p <- p + ggplot2::facet_grid( + rows = facet_by_list$facet_rows, + cols = facet_by_list$facet_cols, + scales = ifelse(is.null(x_range), "free_x", "fixed"), + labeller = "label_context" + ) + + } else { + p <- p + ggplot2::facet_wrap( + facets = facet_by_list$facet_by, + scales = ifelse(is.null(x_range), "free_x", "fixed"), + labeller = "label_context" + ) + } + } + + # Update labels. + p <- p + ggplot2::labs( + x = x_label, + y = y_label, + title = plot_title, + subtitle = plot_sub_title, + caption = caption + ) + + # Prevent clipping of confidence intervals. + if (!is.null(x_range)) p <- p + ggplot2::coord_cartesian(xlim = x_range) + + return(p) +} + + + +..set_shap_waterfall_positions <- function(x, predictions, feature_name) { + # Prevent notes. + feature_value <- density <- y_offset <- NULL + + # Initialise. + x_start <- x_end <- y <- y_seg_start <- y_seg_end <- numeric(length(x)) + + # Set feature order. + feature_order <- order(feature_name, decreasing = TRUE) + + # We fill start and end positions in reverse order, beginning with the most + # important feature. + previous_start <- utils::head(predictions, n = 1L) + for (ii in feature_order) { + x_end[ii] <- previous_start + x_start[ii] <- previous_start - x[ii] + previous_start <- x_start[ii] + } + + return(list( + "x_start" = x_start, + "x_end" = x_end + )) +} + + + +..set_shap_waterfall_feature_name_value <- function( + feature_name, + feature_value, + feature_label +) { + actual_label <- feature_label + actual_label[is.na(feature_label)] <- signif(feature_value[is.na(feature_label)], 3L) + actual_label[!is.na(actual_label)] <- paste0(": ", actual_label[!is.na(actual_label)]) + actual_label[is.na(actual_label)] <- "" + + return(paste0(feature_name, actual_label)) +} + + + +.determine_shap_waterfall_plot_dimensions <- function( + x, + x_axis_by, + y_axis_by, + facet_by, + facet_wrap_cols +) { + + # Obtain facetting dimensions + plot_dims <- .get_plot_layout_dims( + x = x, + facet_by = facet_by, + facet_wrap_cols = facet_wrap_cols + ) + + # Set default height and width for each subplot (in cm). + default_width <- 6.0 + default_height <- 4.0 + + # Set overall plot height, but limit to small-margin A4 (27.7 cm) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) + + # Set overall plot width, but limit to small-margin A4 (19 cm) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) + + return(c(height, width)) +} + + +# GeomSHAPWaterfall ------------------------------------------------------------ +# Placeholder to prevent NOTES if ggplot2 is not installed. +GeomSHAPWaterfall <- NULL +if (rlang::is_installed("ggplot2")) { + GeomSHAPWaterfall <- ggplot2::ggproto( + "GeomPolygon", + ggplot2::Geom, + required_aes = c("x", "xend", "y", "ymin", "ymax"), + default_aes = ggplot2::aes( + colour = NA, + fill = "grey35", + linewidth = 0.5, + linetype = 1, + alpha = NA + ), + draw_key = ggplot2::draw_key_polygon, + draw_panel = function( + data, + panel_params, + coord, + lineend = "butt", linejoin = "round", linemitre = 10 + ) { + # Compute coordinates based on data. + coords <- coord$transform(data, panel_params) + + # Instantiate parameters to feed to grid::polygonGrob. These vectors are + # sufficiently large to hold all polygons with taper. + x <- y <- numeric(nrow(coords) * 5L) + id <- integer(nrow(coords) * 5L) + + # Iterate over features. + idx_offset <- 0L + for (ii in seq_len(nrow(coords))) { + # Set up coordinates. + x_start = coords$x[ii] + x_end = coords$xend[ii] + y_down <- coords$ymin[ii] + y_up <- coords$ymax[ii] + + if (abs(x_start - x_end) > 0.05) { + # Add taper if there is sufficient room on the plot. + x_mid <- ifelse(x_start < x_end, x_end - 0.05, x_end + 0.05) + y_mid <- (y_up + y_down) * 0.5 + + # Define coordinates for polygon. + idx <- idx_offset + (1L:5L) + x[idx] <- c(x_start, x_start, x_mid, x_end, x_mid) + y[idx] <- c(y_down, y_up, y_up, y_mid, y_down) + + } else { + # Avoid taper if there is not sufficient room. + idx <- idx_offset + (1L:4L) + x[idx] <- c(x_start, x_start, x_end, x_end) + y[idx] <- c(y_down, y_up, y_up, y_down) + } + + # Set grouping. + id[idx] <- ii + + # Update offset. + idx_offset <- idx_offset + length(idx) + } + + # Select elements which are correctly set. + valid_idx <- id > 0L + + return(grid::polygonGrob( + x[valid_idx], + y[valid_idx], + id = id[valid_idx], + default.units = "native", + gp = grid::gpar( + col = coords$colour, + fill = ggplot2::fill_alpha(coords$fill, coords$alpha), + lwd = coords$linewidth * ggplot2::.pt, + lty = coords$linetype, + lineend = lineend, + linejoin = linejoin, + linemitre = linemitre + ) + )) + } + ) +} + + + +geom_waterfall_shap <- function( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE, + ... +) { + ggplot2::layer( + geom = GeomSHAPWaterfall, + mapping = mapping, + data = data, + stat = stat, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) +} diff --git a/R/PlotUnivariateImportance.R b/R/PlotUnivariateImportance.R index f72b95d9..aa05a777 100644 --- a/R/PlotUnivariateImportance.R +++ b/R/PlotUnivariateImportance.R @@ -17,16 +17,29 @@ NULL #' @param p_adjustment_method (*optional*) Indicates type of p-value that is #' shown. One of `holm`, `hochberg`, `hommel`, `bonferroni`, `BH`, `BY`, #' `fdr`, `none`, `p_value` or `q_value` for adjusted p-values, uncorrected -#' p-values and q-values. q-values may not be available. +#' p-values #' @param show_cluster (*optional*) Show which features were clustered together. #' @param ggtheme (*optional*) `ggplot` theme to use for plotting. -#' @param discrete_palette (*optional*) Palette used to fill the bars in case a -#' non-singular variable was provided to the `color_by` argument. +#' @param discrete_palette (*optional*) Palette for colouring the plot elements +#' according to the groupings indicated by the `color_by` argument (if any). +#' `familiar` has a default palette. Other palettes are supported by +#' `paletteer`, `grDevices::palette.pals()` (requires R >= 4.0.0), +#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, +#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the +#' palettes of the same name in `grDevices`. You may also specify your own +#' palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param gradient_palette (*optional*) Palette to use for filling the bars in #' case the `color_by` argument is not set. The bars are then coloured #' according to their importance. By default, no gradient is used, and the #' bars are not filled according to importance. Use `NULL` to fill the bars -#' using the default palette in `familiar`. +#' using the default palette in `familiar`. Other palettes are supported by +#' the `paletteer` package, `grDevices::palette.pals()` (requires R >= 4.0.0), +#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, +#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the +#' palettes of the same name in `grDevices`. You may also specify your own +#' palette by providing a vector of colour names listed by +#' `grDevices::colors()` or through hexadecimal RGB strings. #' @param significance_level_shown Position(s) to draw vertical lines indicating #' a significance level, e.g. 0.05. Can be NULL to not draw anything. #' @param height (*optional*) Height of the plot. A default value is derived @@ -49,7 +62,7 @@ NULL #' #' @details This function generates a horizontal barplot with the length of the #' bars corresponding to the 10-logarithm of the (multiple-testing corrected) -#' p-value or q-value. +#' p-value. #' #' Features are assessed univariately using one-sample location t-tests after #' fitting a suitable regression model. The fitted model coefficient and the @@ -58,28 +71,20 @@ NULL #' The following splitting variables are available for `split_by`, `color_by` #' and `facet_by`: #' -#' * `fs_method`: feature selection methods +#' * `vimp_method`: variable importance methods #' #' * `learner`: learners #' #' * `data_set`: data sets #' -#' Unlike for plots of feature ranking in feature selection and after -#' modelling (as assessed by model-specific routines), clusters of features -#' are now found during creation of underlying `familiarData` objects, instead -#' of through consensus clustering. Hence, clustering results may differ due -#' to differences in the underlying datasets. +#' Unlike for plots of feature ranking in initial variable importance +#' computation and after modelling (as assessed by model-specific routines), +#' clusters of features are now found during creation of underlying +#' `familiarData` objects, instead of through consensus clustering. Hence, +#' clustering results may differ due to differences in the underlying +#' datasets. #' -#' Available palettes for `discrete_palette` and `gradient_palette` are those -#' listed by `grDevices::palette.pals()` (requires R >= 4.0.0), -#' `grDevices::hcl.pals()` (requires R >= 3.6.0) and `rainbow`, `heat.colors`, -#' `terrain.colors`, `topo.colors` and `cm.colors`, which correspond to the -#' palettes of the same name in `grDevices`. If not specified, a default -#' palette based on palettes in Tableau are used. You may also specify your -#' own palette by using colour names listed by `grDevices::colors()` or -#' through hexadecimal RGB strings. -#' -#' Labelling methods such as `set_fs_method_names` or `set_feature_names` can +#' Labelling methods such as `set_vimp_method_names` or `set_feature_names` can #' be applied to the `familiarCollection` object to update labels, and order #' the output in the figure. #' @@ -113,8 +118,9 @@ setGeneric( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, significance_level_shown = 0.05, width = waiver(), @@ -122,7 +128,8 @@ setGeneric( units = waiver(), verbose = TRUE, export_collection = FALSE, - ...) { + ... + ) { standardGeneric("plot_univariate_importance") } ) @@ -158,8 +165,9 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, significance_level_shown = 0.05, width = waiver(), @@ -167,7 +175,8 @@ setMethod( units = waiver(), verbose = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Attempt conversion to familiarCollection object. object <- do.call( as_familiar_collection, @@ -179,8 +188,11 @@ setMethod( "feature_linkage_method" = feature_linkage_method, "feature_cluster_cut_method" = feature_cluster_cut_method, "feature_similarity_threshold" = feature_similarity_threshold, - "verbose" = verbose), - list(...))) + "verbose" = verbose + ), + list(...) + ) + ) return(do.call( plot_univariate_importance, @@ -207,6 +219,7 @@ setMethod( "plot_title" = plot_title, "plot_sub_title" = plot_sub_title, "caption" = caption, + "limit_n_features" = limit_n_features, "x_range" = x_range, "x_n_breaks" = x_n_breaks, "x_breaks" = x_breaks, @@ -215,7 +228,9 @@ setMethod( "height" = height, "units" = units, "verbose" = verbose, - "export_collection" = export_collection))) + "export_collection" = export_collection + ) + )) } ) @@ -248,8 +263,9 @@ setMethod( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, significance_level_shown = 0.05, width = waiver(), @@ -257,7 +273,8 @@ setMethod( units = waiver(), verbose = TRUE, export_collection = FALSE, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table value <- .NATURAL <- NULL @@ -269,7 +286,8 @@ setMethod( # Get input data. x <- export_univariate_analysis_data( object = object, - p_adjustment_method = p_adjustment_method) + p_adjustment_method = p_adjustment_method + ) # Use only the univariate data. x <- x$univariate @@ -287,11 +305,14 @@ setMethod( if (is.list(x)) { if (is_empty(x)) return(NULL) - if (length(x) > 1) ..error_reached_unreachable_code( - "plot_univariate_importance: list of data elements contains unmerged elements.") + if (length(x) > 1L) { + ..error_reached_unreachable_code( + "plot_univariate_importance: list of data elements contains unmerged elements." + ) + } # Get x directly. - x <- x[[1]] + x <- x[[1L]] } # Check that the data are not empty. @@ -301,7 +322,8 @@ setMethod( .check_parameter_value_is_valid( x = show_cluster, var_name = "show_cluster", - values = c(FALSE, TRUE)) + values = c(FALSE, TRUE) + ) if (show_cluster) { # Get feature similarity data. @@ -314,7 +336,7 @@ setMethod( export_dendrogram = FALSE, export_ordered_data = FALSE, export_clustering = TRUE - )[[1]] + )[[1L]] } else { feature_similarity <- NULL @@ -329,7 +351,8 @@ setMethod( column_data <- .plot_univariate_check_p_adjustment_method( method = p_adjustment_method, x = x@data, - verbose = verbose) + verbose = verbose + ) if (is.null(column_data)) return(NULL) @@ -337,17 +360,19 @@ setMethod( if (!require_package( x = ..required_plotting_packages(extended = FALSE), purpose = "to plot univariate variable importance", - message_type = "warning")) { + message_type = "warning" + )) { return(NULL) } data.table::setnames( x = x@data, old = column_data$value_column, - new = "value") + new = "value" + ) # Update p-values below the machine precision (i.e. p=0.0). - x@data[value <= 0.0, "value" := 2 * .Machine$double.eps] + x@data[value <= 0.0, "value" := 2.0 * .Machine$double.eps] # Convert p-value column to logarithmic scale x@data[, "log_value" := -log10(value)] @@ -363,34 +388,41 @@ setMethod( significance_level_shown, .check_number_in_valid_range, var_name = "significance_level_shown", - range = c(0, 1), - closed = c(FALSE, TRUE)) + range = c(0.0, 1.0), + closed = c(FALSE, TRUE) + ) } # x_range if (is.null(x_range) && is.null(significance_level_shown)) { - x_range <- c(0, max(x@data$log_value, na.rm = TRUE)) + x_range <- c(0.0, max(x@data$log_value, na.rm = TRUE)) } else if (is.null(x_range) && !is.null(significance_level_shown)) { - x_range <- c(0, max(c( - max(x@data$log_value, na.rm = TRUE), - max(-log10(significance_level_shown))))) + x_range <- c( + 0.0, + max(c( + max(x@data$log_value, na.rm = TRUE), + max(-log10(significance_level_shown)) + )) + ) } # x_breaks if (is.null(x_breaks)) { .check_input_plot_args( x_range = x_range, - x_n_breaks = x_n_breaks) + x_n_breaks = x_n_breaks + ) # Create breaks and update x_range x_breaks <- labeling::extended( m = x_n_breaks, - dmin = x_range[1], - dmax = x_range[2], - only.loose = TRUE) + dmin = x_range[1L], + dmax = x_range[2L], + only.loose = TRUE + ) - x_range <- c(0, tail(x_breaks, n = 1)) + x_range <- c(0.0, tail(x_breaks, n = 1L)) } # x_label Set default name for x-axis label @@ -407,7 +439,7 @@ setMethod( # Set default splitting variables if none are provided. if (is.null(split_by) && is.null(color_by) && is.null(facet_by)) { - split_by <- c("fs_method", "learner") + split_by <- c("vimp_method", "learner") color_by <- c("data_set") } @@ -417,7 +449,8 @@ setMethod( split_by = split_by, color_by = color_by, facet_by = facet_by, - available = c("fs_method", "learner", "data_set")) + available = c("vimp_method", "learner", "data_set") + ) # Update splitting variables split_by <- split_var_list$split_by @@ -427,7 +460,8 @@ setMethod( # Parse legend label legend_label <- .create_plot_legend_title( user_label = legend_label, - color_by = color_by) + color_by = color_by + ) # Check general input arguments .check_input_plot_args( @@ -439,7 +473,9 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols, + limit_n_features = limit_n_features + ) # Create plots ------------------------------------------------------------- @@ -471,7 +507,8 @@ setMethod( x_temporary <- data.table::copy(x_sub) x_temporary[, ":="( "cluster_id" = .I, - "cluster_size" = 1L)] + "cluster_size" = 1L + )] } # Replace x_sub @@ -483,7 +520,8 @@ setMethod( if (autogenerate_plot_subtitle) { plot_sub_title <- .create_plot_subtitle( split_by = split_by, - x = x_sub) + x = x_sub + ) } # Generate plot @@ -502,13 +540,15 @@ setMethod( plot_title = plot_title, plot_sub_title = plot_sub_title, caption = caption, + limit_n_features = limit_n_features, x_range = x_range, x_breaks = x_breaks, - significance_level_shown = significance_level_shown) + significance_level_shown = significance_level_shown + ) # Check empty output if (is.null(p)) next - + # Draw plot if (draw) .draw_plot(plot_or_grob = p) @@ -518,7 +558,8 @@ setMethod( def_plot_dims <- .determine_univariate_importance_plot_dimensions( x = x_sub, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Save to file. do.call( @@ -532,10 +573,13 @@ setMethod( "subtype" = "univariate", "x" = x_sub, "split_by" = split_by, - "height" = ifelse(is.waive(height), def_plot_dims[1], height), - "width" = ifelse(is.waive(width), def_plot_dims[2], width), - "units" = ifelse(is.waive(units), "cm", units)), - list(...))) + "height" = ifelse(is.waive(height), def_plot_dims[1L], height), + "width" = ifelse(is.waive(width), def_plot_dims[2L], width), + "units" = ifelse(is.waive(units), "cm", units) + ), + list(...) + ) + ) } else { # Store as list and export @@ -548,7 +592,8 @@ setMethod( dir_path = dir_path, plot_list = plot_list, export_collection = export_collection, - object = object)) + object = object + )) } ) @@ -579,11 +624,13 @@ setMethod( plot_title, plot_sub_title, caption, + limit_n_features, x_range, x_breaks, - significance_level_shown) { + significance_level_shown +) { # Suppress NOTES due to non-standard evaluation in data.table - log_value <- NULL + log_value <- feature <- NULL # Create local copy x <- data.table::copy(x) @@ -597,17 +644,34 @@ setMethod( guide_list <- .create_plot_guide_table( x = x, color_by = color_by, - discrete_palette = discrete_palette) + discrete_palette = discrete_palette + ) # Extract data x <- guide_list$data - + + # Determine the features that need to be plotted. + if (is.numeric(limit_n_features)) { + # Find the features with the highest log-p-values, and select these. + x_agg <- x[, list("log_value" = max(log_value)), by = c("feature")] + + # Explicitly select features based on threshold value instead of simply + # selecting the best features: features may have the same value because they + # belong to the same cluster. + threshold_value <- min(tail(unique(sort(x_agg$log_value)), n = limit_n_features)) + selected_features <- x_agg[log_value >= threshold_value]$feature + + # Make slice. + x <- x[feature %in% selected_features, ] + } + # Check if cluster information should be shown. if (show_cluster) { x <- .add_plot_cluster_name( x = x, color_by = color_by, - facet_by = facet_by) + facet_by = facet_by + ) } # Create basic plot @@ -615,7 +679,9 @@ setMethod( data = x, mapping = ggplot2::aes( x = !!sym("feature"), - y = !!sym("log_value"))) + y = !!sym("log_value") + ) + ) p <- p + ggtheme # Add fill colors @@ -626,25 +692,30 @@ setMethod( p <- p + ggplot2::geom_bar( stat = "identity", mapping = ggplot2::aes(fill = !!sym("color_breaks")), - position = "dodge") + position = "dodge" + ) p <- p + ggplot2::scale_fill_manual( name = legend_label$guide_color, values = g_color$color_values, breaks = g_color$color_breaks, - drop = FALSE) + drop = FALSE + ) } else if (!is.waive(gradient_palette)) { # Coloring by log of the p-value p <- p + ggplot2::geom_bar( stat = "identity", mapping = ggplot2::aes(fill = !!sym("log_value")), - show.legend = FALSE) + show.legend = FALSE + ) p <- p + ggplot2::scale_fill_gradientn( colors = .get_palette( x = gradient_palette, - palette_type = "sequential"), - limits = x_range) + palette_type = "sequential" + ), + limits = x_range + ) } else { # No colouring of the bars. @@ -659,7 +730,8 @@ setMethod( facet_by_list <- .parse_plot_facet_by( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) if (!is.null(facet_by)) { if (is.null(facet_wrap_cols)) { @@ -667,12 +739,14 @@ setMethod( p <- p + ggplot2::facet_grid( rows = facet_by_list$facet_rows, cols = facet_by_list$facet_cols, - labeller = "label_context") + labeller = "label_context" + ) } else { p <- p + ggplot2::facet_wrap( facets = facet_by_list$facet_by, - labeller = "label_context") + labeller = "label_context" + ) } } @@ -686,12 +760,14 @@ setMethod( ggplot2::aes( label = !!sym("cluster_name"), y = 0.0, - angle = 270.0), + angle = 270.0 + ), colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, size = text_settings$geom_text_size, - vjust = -0.50) + vjust = -0.50 + ) } else { p <- p + ggplot2::geom_text( @@ -699,13 +775,15 @@ setMethod( label = !!sym("cluster_name"), y = 0.0, group = !!sym("color_breaks"), - angle = 270.0), + angle = 270.0 + ), colour = text_settings$colour, family = text_settings$family, fontface = text_settings$face, size = text_settings$geom_text_size, vjust = -0.50, - position = ggplot2::position_dodge(width = 0.9)) + position = ggplot2::position_dodge(width = 0.9) + ) } } @@ -714,7 +792,8 @@ setMethod( for (curr_signif_level in significance_level_shown) { p <- p + ggplot2::geom_hline( yintercept = -log10(curr_signif_level), - linetype = "dotted") + linetype = "dotted" + ) } } @@ -725,7 +804,8 @@ setMethod( y = x_label, title = plot_title, subtitle = plot_sub_title, - caption = caption) + caption = caption + ) return(p) } @@ -735,13 +815,15 @@ setMethod( .determine_univariate_importance_plot_dimensions <- function( x, facet_by, - facet_wrap_cols) { + facet_wrap_cols +) { # Get plot layout dimensions plot_dims <- .get_plot_layout_dims( x = x, facet_by = facet_by, - facet_wrap_cols = facet_wrap_cols) + facet_wrap_cols = facet_wrap_cols + ) # Determine the number of features within each facet. n_features <- data.table::uniqueN(x = x$feature) @@ -749,17 +831,17 @@ setMethod( # Assume each feature takes up about 14 points (~5mm) with 2 point (0.7mm) # spacing. Then add some room for other plot elements. - default_height <- n_features * 0.5 + (n_features - 1) * 0.07 + 1.0 + default_height <- n_features * 0.5 + (n_features - 1L) * 0.07 + 1.0 # Set a default height. Assume that the typical width of a character is about # 5 points (1.8mm). - default_width <- 6 + longest_name * 0.18 + default_width <- 6.0 + longest_name * 0.18 # Set overall plot height, but limit to small-margin A4 (27.7 cm) - height <- min(c(2 + plot_dims[1] * default_height, 27.7)) + height <- min(c(2.0 + plot_dims[1L] * default_height, 27.7)) # Set overall plot width, but limit to small-margin A4 (19 cm) - width <- min(c(2 + plot_dims[2] * default_width, 19)) + width <- min(c(2.0 + plot_dims[2L] * default_width, 19.0)) return(c(height, width)) } @@ -769,11 +851,13 @@ setMethod( .plot_univariate_check_p_adjustment_method <- function( x, method, - verbose = TRUE) { + verbose = TRUE +) { .check_parameter_value_is_valid( x = method, var_name = "p_adjustment_method", - values = c(stats::p.adjust.methods, "p_value", "q_value")) + values = c(stats::p.adjust.methods, "p_value", "q_value") + ) value_column <- switch( method, @@ -785,8 +869,8 @@ setMethod( "BY" = "adjusted_p_value", "fdr" = "adjusted_p_value", "none" = "p_value", - "p_value" = "p_value", - "q_value" = "q_value") + "p_value" = "p_value" + ) label_name <- switch( method, @@ -798,21 +882,22 @@ setMethod( "BY" = "Benjamini-Yekutieli corrected p-value", "fdr" = "FDR-corrected p-value", "none" = "p-value", - "p_value" = "p-value", - "q_value" = "q-value") + "p_value" = "p-value" + ) # Check if the column is present. if (is.null(x[[value_column]])) { - stop(paste0( + ..error(paste0( "Univariate importance can not be plotted as the values for ", "the requested p adjustment method (", value_column, - ") were not found in the data.")) + ") were not found in the data." + )) } # Check if any values are valid. - if (all(!is.finite(x[[value_column]]))) { + if (!any(is.finite(x[[value_column]]))) { if (verbose) { - warning("Univariate importance can not be plotted as all values are NA.") + ..warning("Univariate importance can not be plotted as all values are NA.") } return(NULL) @@ -820,5 +905,6 @@ setMethod( return(list( "value_column" = value_column, - "label" = label_name)) + "label" = label_name + )) } diff --git a/R/PlotUtilities.R b/R/PlotUtilities.R index 6fe6647f..2a418548 100644 --- a/R/PlotUtilities.R +++ b/R/PlotUtilities.R @@ -22,24 +22,27 @@ #' @return A complete plotting theme. #' @export theme_familiar <- function( - base_size = 10, + base_size = 10.0, base_family = "", base_line_size = 0.5, - base_rect_size = 0.5) { + base_rect_size = 0.5 +) { # The default familiar theme is based on ggplot2::theme_light. ggtheme <- ggplot2::theme_light( base_size = base_size, base_family = base_family, base_line_size = base_line_size, - base_rect_size = base_rect_size) + base_rect_size = base_rect_size + ) # Set colour to black. ggtheme$axis.text$colour <- "black" ggtheme$axis.ticks$colour <- "black" ggtheme$axis.line <- ggplot2::element_line( colour = "black", - lineend = "square") + lineend = "square" + ) # Legend does not have a legend or border, and reserves less space. ggtheme$legend.background <- ggplot2::element_blank() @@ -69,34 +72,44 @@ theme_familiar <- function( size = ggplot2::rel(1.1), hjust = 0.0, vjust = 1.0, - margin = ggplot2::margin(b = base_size / 2)) + margin = ggplot2::margin(b = base_size / 2.0) + ) # Make subtitle a bit smaller. ggtheme$plot.subtitle <- ggplot2::element_text( size = ggplot2::rel(0.8), hjust = 0.0, vjust = 1.0, - margin = ggplot2::margin(b = base_size / 2)) + margin = ggplot2::margin(b = base_size / 2.0) + ) # Make caption a bit smaller. ggtheme$plot.caption <- ggplot2::element_text( size = ggplot2::rel(0.7), hjust = 1.0, vjust = 1.0, - margin = ggplot2::margin(b = base_size / 2)) + margin = ggplot2::margin(b = base_size / 2.0) + ) # Make tag bold. ggtheme$plot.tag <- ggplot2::element_text( face = "bold", - hjust = 0, - vjust = 0.7) + hjust = 0.0, + vjust = 0.7 + ) # Make strip text black. ggtheme$strip.text <- ggplot2::element_text( size = ggplot2::rel(0.8), colour = "grey10", - margin = grid::unit( - c(base_size / 4, base_size / 4, base_size / 4, base_size / 4), "pt")) + margin = ggplot2::margin( + t = base_size / 4.0, + r = base_size / 4.0, + b = base_size / 4.0, + l = base_size / 4.0, + unit = "pt" + ) + ) # Remove strip background ggtheme$strip.background <- ggplot2::element_blank() @@ -111,14 +124,15 @@ theme_familiar <- function( if (inherits(ggtheme, "theme")) { # Check if the theme is complete. if (!attr(ggtheme, "complete")) { - stop(paste0( + ..error(paste0( "The plotting theme is not complete. The most likely cause is lack ", "of a valid template, such as theme_familiar or ggplot2::theme_light. ", - "Note that ggplot2::theme is designed to tweak existing themes when creating a plot.")) + "Note that ggplot2::theme is designed to tweak existing themes when creating a plot." + )) } } else if (is.null(ggtheme)) { - ggtheme <- theme_familiar(base_size = 9) + ggtheme <- theme_familiar(base_size = 9.0) } else { # Get the specified theme. @@ -133,15 +147,17 @@ theme_familiar <- function( "theme_light" = ggplot2::theme_light, "theme_dark" = ggplot2::theme_dark, "theme_minimal" = ggplot2::theme_minimal, - "theme_classic" = ggplot2::theme_classic) + "theme_classic" = ggplot2::theme_classic + ) if (is.null(ggtheme_fun)) { - stop(paste0( - "The selected theme is not the default theme, or a standard ggplot2 theme. Found: ", ggtheme)) + ..error(paste0( + "The selected theme is not the default theme, or a standard ggplot2 theme. Found: ", ggtheme + )) } # Generate theme - ggtheme <- ggtheme_fun(base_size = 9) + ggtheme <- ggtheme_fun(base_size = 9.0) } return(ggtheme) @@ -196,42 +212,45 @@ theme_familiar <- function( facet_by = NULL, x_axis_by = NULL, y_axis_by = NULL, - available = NULL) { + available = NULL +) { # Find unique variables splitting_vars <- c(split_by, color_by, linetype_by, facet_by, x_axis_by, y_axis_by) - if (is.null(available) && length(splitting_vars) == 0) { + if (is.null(available) && length(splitting_vars) == 0L) { return(list()) - } else if (is.null(available) && length(splitting_vars) > 0) { - stop(paste0( + } else if (is.null(available) && length(splitting_vars) > 0L) { + ..error(paste0( "The current plot has no required splitting variables defined, but ", paste_s(splitting_vars), - ifelse(length(splitting_vars) == 1, " was assigned.", " were assigned."))) + ifelse(length(splitting_vars) == 1L, " was assigned.", " were assigned.") + )) } # Filter available down to those present in the data. filter_available <- intersect(available, colnames(x)) # Filter available down to those that have more than one variable - filter_available <- filter_available[ - sapply( - filter_available, - function(ii, x) (data.table::uniqueN(x = x, by = ii) > 1), - x = x)] + filter_available <- filter_available[sapply( + filter_available, + function(ii, x) (data.table::uniqueN(x = x, by = ii) > 1L), + x = x + )] if (is.null(filter_available)) { return(list()) } else if (!all(filter_available %in% splitting_vars)) { missing_vars <- filter_available[!filter_available %in% splitting_vars] - stop(paste0( + ..error(paste0( "The current plot requires ", paste_s(filter_available), - ifelse(length(filter_available) > 1, " as splitting variables", " as a splitting_variable"), + ifelse(length(filter_available) > 1L, " as splitting variables", " as a splitting_variable"), ", but ", paste_s(missing_vars), - ifelse(length(missing_vars) == 1, " was not assigned.", " were not assigned."))) + ifelse(length(missing_vars) == 1L, " was not assigned.", " were not assigned.") + )) } # Update available @@ -281,8 +300,8 @@ theme_familiar <- function( .check_value_not_shared(output_list$x_axis_by, output_list$y_axis_by, "x_axis_by", "y_axis_by") # Check length of x_axis_by and y_axis_by variables. - .check_argument_length(output_list$x_axis_by, "x_axis_by", min = 0, max = 1) - .check_argument_length(output_list$y_axis_by, "y_axis_by", min = 0, max = 1) + .check_argument_length(output_list$x_axis_by, "x_axis_by", min = 0L, max = 1L) + .check_argument_length(output_list$y_axis_by, "y_axis_by", min = 0L, max = 1L) return(output_list) } @@ -293,7 +312,7 @@ theme_familiar <- function( if (is.null(facet_by)) { return(list()) - } else if (length(facet_by) == 1) { + } else if (length(facet_by) == 1L) { if (is.null(facet_wrap_cols)) { return(list("facet_cols" = quos(!!ensym(facet_by)))) } else { @@ -302,11 +321,12 @@ theme_familiar <- function( } else { if (is.null(facet_wrap_cols)) { - facet_col <- facet_by[1] - facet_rows <- facet_by[2:length(facet_by)] + facet_col <- facet_by[1L] + facet_rows <- facet_by[2L:length(facet_by)] return(list( "facet_cols" = quos(!!ensym(facet_col)), - "facet_rows" = quos(!!!parse_exprs(facet_rows)))) + "facet_rows" = quos(!!!parse_exprs(facet_rows)) + )) } else { return(list("facet_by" = quos(!!!parse_exprs(facet_by)))) @@ -319,10 +339,11 @@ theme_familiar <- function( .create_plot_subtitle <- function( x, split_by = NULL, - additional = NULL) { + additional = NULL +) { # Do not create a subtitle if there is no subtitle to be created. subtitle <- NULL - + # Generate subtitle from splitting variables and data. if (!is.null(split_by)) { subtitle <- c( @@ -332,12 +353,18 @@ theme_familiar <- function( function(name, x) { split_variable_name <- name - if (split_variable_name == "fs_method") { + if (split_variable_name == "vimp_method") { split_variable_name <- "VIMP method" + } else if (split_variable_name == "learner") { + split_variable_name <- "learner" } else if (split_variable_name == "data_set") { split_variable_name <- "data set" } else if (split_variable_name == "evaluation_time") { split_variable_name <- "time point" + } else if (split_variable_name == "sample_id") { + split_variable_name <- "sample" + } else if (split_variable_name %in% c("feature_name", "feature")) { + split_variable_name <- "feature" } # Remove all underscores. @@ -345,16 +372,19 @@ theme_familiar <- function( x = split_variable_name, pattern = "_", replacement = " ", - fixed = TRUE) + fixed = TRUE + ) # Parse to an elementary string. - split_variable_name <- paste0(split_variable_name, ": ", x[[name]][1]) + split_variable_name <- paste0(split_variable_name, ": ", x[[name]][1L]) return(split_variable_name) }, - x = x)) + x = x + ) + ) } - + # Generate additional strings from additional. if (!is.null(additional)) { subtitle <- c( @@ -366,13 +396,16 @@ theme_familiar <- function( x = name, pattern = "_", replacement = " ", - fixed = TRUE) + fixed = TRUE + ) # Parse to an elementary string. split_variable_name <- paste0(split_variable_name, ": ", value) }, name = names(additional), - value = additional)) + value = additional + ) + ) } # Check if any subtitle was generated. @@ -396,21 +429,25 @@ theme_familiar <- function( x, subtype = NULL, split_by = NULL, - additional = NULL) { + additional = NULL +) { # Generate additional terms for the subtype, based on splits. if (!is.null(split_by)) { subtype <- c( subtype, as.character(sapply( split_by, - function(jj, x) (x[[jj]][1]), - x = x))) + function(jj, x) (x[[jj]][1L]), + x = x + )) + ) } if (!is.null(additional)) { subtype <- c( subtype, - sapply(additional, function(jj) as.character(jj[1]))) + sapply(additional, function(jj) as.character(jj[1L])) + ) } if (is.null(subtype)) return(NULL) @@ -427,21 +464,24 @@ theme_familiar <- function( user_label, color_by = NULL, linetype_by = NULL, - combine_legend = FALSE) { + combine_legend = FALSE +) { # Sent for inspection .check_input_plot_args( legend_label = user_label, - combine_legend = combine_legend) + combine_legend = combine_legend + ) if (is.null(color_by) && is.null(linetype_by)) { # No splitting variables are used return(list( "guide_color" = NULL, - "guide_linetype" = NULL)) + "guide_linetype" = NULL + )) } # Collect required list entries - req_entries <- character(0) + req_entries <- character(0L) if (!is.null(color_by)) { req_entries <- c(req_entries, "guide_color") } @@ -456,11 +496,13 @@ theme_familiar <- function( x = paste0(unique(c(color_by, linetype_by)), collapse = " & "), pattern = "_", replacement = " ", - fixed = TRUE) + fixed = TRUE + ) return(list( "guide_color" = legend_label, - "guide_linetype" = legend_label)) + "guide_linetype" = legend_label + )) } else { # Colour labels @@ -469,7 +511,8 @@ theme_familiar <- function( x = paste0(color_by, collapse = " & "), pattern = "_", replacement = " ", - fixed = TRUE) + fixed = TRUE + ) } else { color_guide_label <- NULL @@ -481,7 +524,8 @@ theme_familiar <- function( x = paste0(linetype_by, collapse = " & "), pattern = "_", replacement = " ", - fixed = TRUE) + fixed = TRUE + ) } else { linetype_guide_label <- NULL @@ -489,14 +533,16 @@ theme_familiar <- function( return(list( "guide_color" = color_guide_label, - "guide_linetype" = linetype_guide_label)) + "guide_linetype" = linetype_guide_label + )) } } else if (is.null(user_label)) { # NULL input return(list( "guide_color" = NULL, - "guide_linetype" = NULL)) + "guide_linetype" = NULL + )) } else if (is.list(user_label)) { # List input @@ -504,11 +550,12 @@ theme_familiar <- function( # Check entries for existence for (current_entry in req_entries) { if (!current_entry %in% names(user_label)) { - stop(paste0( + ..error(paste0( "A legend name is missing for ", current_entry, ". Please set this name to a \"", current_entry, "\" list element, e.g. list(\"", current_entry, - "\"=\"some name\", ...).")) + "\"=\"some name\", ...)." + )) } } @@ -516,33 +563,37 @@ theme_familiar <- function( user_label <- user_label[names(user_label) %in% req_entries] # Check that all entries are the same - if (combine_legend && length(req_entries) >= 2) { + if (combine_legend && length(req_entries) >= 2L) { if (!all(sapply( - user_label[2:length(user_label)], + user_label[2L:length(user_label)], identical, - user_label[[1]]))) { - stop(paste0( + user_label[[1L]] + ))) { + ..error(paste0( "Not all provided legend names are identical, but identical legend ", - "names are required for combining the legend.")) + "names are required for combining the legend." + )) } } return(user_label) - } else if (length(req_entries) >= 2 && !combine_legend) { + } else if (length(req_entries) >= 2L && !combine_legend) { # Single input where multiple is required - stop(paste0( + ..error(paste0( "Multiple legend names are required, but only one is provided. ", "Please return a list with ", - paste0("\"", req_entries, "\"", collapse = ", "), " elements.")) + paste0("\"", req_entries, "\"", collapse = ", "), " elements." + )) } else { # Single input return(list( "guide_color" = user_label, - "guide_linetype" = user_label)) + "guide_linetype" = user_label + )) } } @@ -553,7 +604,8 @@ theme_familiar <- function( color_by = NULL, linetype_by = NULL, discrete_palette = NULL, - combine_legend = TRUE) { + combine_legend = TRUE +) { .get_guide_tables <- function(x, color_by, linetype_by, discrete_palette) { # Suppress NOTES due to non-standard evaluation in data.table @@ -569,7 +621,8 @@ theme_familiar <- function( guide_table <- data.table::data.table(expand.grid(lapply( rev(unique_vars), function(ii, x) (levels(x[[ii]])), - x = x))) + x = x + ))) # Rename variables data.table::setnames(x = guide_table, rev(unique_vars)) @@ -578,28 +631,32 @@ theme_familiar <- function( for (ii in unique_vars) { guide_table[[ii]] <- factor( x = guide_table[[ii]], - levels = levels(x[[ii]])) + levels = levels(x[[ii]]) + ) } # Order columns according to unique_vars data.table::setcolorder( x = guide_table, - neworder = unique_vars) + neworder = unique_vars + ) # Order data set by columns data.table::setorderv( x = guide_table, - cols = unique_vars) + cols = unique_vars + ) # Set breaks - breaks <- apply(guide_table, 1, paste, collapse = ", ") + breaks <- apply(guide_table, 1L, paste, collapse = ", ") # Extend guide table if (!is.null(color_by)) { # Generate breaks guide_table$color_breaks <- factor( x = breaks, - levels = breaks) + levels = breaks + ) # Define colour groups guide_table[, "color_id" := .GRP, by = color_by] @@ -608,7 +665,8 @@ theme_familiar <- function( discr_palette <- .get_palette( x = discrete_palette, n = max(guide_table$color_id), - palette_type = "qualitative") + palette_type = "qualitative" + ) # Assign colour values guide_table[, "color_values" := discr_palette[color_id]] @@ -618,7 +676,8 @@ theme_familiar <- function( # Generate breaks guide_table$linetype_breaks <- factor( x = breaks, - levels = breaks) + levels = breaks + ) # Define linetype groups guide_table[, "linetype_id" := .GRP, by = linetype_by] @@ -642,12 +701,15 @@ theme_familiar <- function( x = x, color_by = color_by, linetype_by = linetype_by, - discrete_palette = discrete_palette), + discrete_palette = discrete_palette + ), "guide_linetype" = .get_guide_tables( x = x, color_by = color_by, linetype_by = linetype_by, - discrete_palette = discrete_palette)) + discrete_palette = discrete_palette + ) + ) } else { guide_list <- list( @@ -655,18 +717,21 @@ theme_familiar <- function( x = x, color_by = color_by, linetype_by = NULL, - discrete_palette = discrete_palette), + discrete_palette = discrete_palette + ), "guide_linetype" = .get_guide_tables( x = x, color_by = NULL, linetype_by = linetype_by, - discrete_palette = discrete_palette)) + discrete_palette = discrete_palette + ) + ) } # Filter out lists corresponding to missing split variables guide_list <- guide_list[!sapply(list(color_by, linetype_by), is.null)] - if (length(guide_list) == 0) return(list("data" = x)) + if (length(guide_list) == 0L) return(list("data" = x)) # Initialise return list return_list <- list() @@ -681,7 +746,8 @@ theme_familiar <- function( y = guide_list[[guide_type]][, mget(c(unique(c(color_by, linetype_by)), "color_breaks"))], by = unique(c(color_by, linetype_by)), all.x = TRUE, - all.y = FALSE) + all.y = FALSE + ) } else { x <- merge( @@ -689,7 +755,8 @@ theme_familiar <- function( y = guide_list[[guide_type]][, mget(c(color_by, "color_breaks"))], by = color_by, all.x = TRUE, - all.y = FALSE) + all.y = FALSE + ) } # Return guide_color @@ -703,7 +770,8 @@ theme_familiar <- function( y = guide_list[[guide_type]][, mget(c(unique(c(color_by, linetype_by)), "linetype_breaks"))], by = unique(c(color_by, linetype_by)), all.x = TRUE, - all.y = FALSE) + all.y = FALSE + ) } else { x <- merge( @@ -711,7 +779,8 @@ theme_familiar <- function( y = guide_list[[guide_type]][, mget(c(linetype_by, "linetype_breaks"))], by = linetype_by, all.x = TRUE, - all.y = FALSE) + all.y = FALSE + ) } # Return guide_linetype @@ -731,27 +800,28 @@ theme_familiar <- function( x, color_by = NULL, facet_by = NULL, - singular_cluster_character = "\u2014") { + singular_cluster_character = "\u2014" +) { # Suppress NOTES due to non-standard evaluation in data.table cluster_size <- cluster_id <- feature <- new_cluster_id <- cluster_name <- NULL ..integer_to_char <- function(x) { # Initialise placeholders x_remain <- x - new_string <- character(0) + new_string <- character(0L) - while (ceiling(x_remain / 26) > 0) { + while (as.integer(ceiling(x_remain / 26L)) > 0L) { # Determine the modulo. - mod <- x_remain %% 26 + mod <- x_remain %% 26L # Find if mod is equal to 0, which would indicate Z. - mod <- ifelse(mod == 0, 26, mod) + mod <- ifelse(mod == 0L, 26L, mod) # Add letter new_string <- c(new_string, LETTERS[mod]) # Update the remain variable - x_remain <- (x_remain - mod) / 26 + x_remain <- (x_remain - mod) / 26L } return(paste(rev(new_string), collapse = "")) @@ -761,7 +831,7 @@ theme_familiar <- function( splitting_vars <- unique(c(color_by, facet_by)) # Split x by splitting variables. - if (length(splitting_vars) > 0) { + if (length(splitting_vars) > 0L) { x <- split(x, by = splitting_vars) } else { x <- list(x) @@ -785,7 +855,7 @@ theme_familiar <- function( # Only determine cluster_name for those clusters that have cluster_size > # 1. Also, the most important features should receive a higher replacement # cluster_id. - y_short <- y[cluster_size > 1, mget(c("feature", "cluster_id"))] + y_short <- y[cluster_size > 1L, mget(c("feature", "cluster_id"))] if (!is_empty(y_short)) { # Remove unused levels for the name column. The levels of name are @@ -798,9 +868,9 @@ theme_familiar <- function( new_id <- 1L for (current_feature in levels(y_short$feature)) { # Provide new cluster id in case none exists. - if (is.na(y_short[feature == current_feature, ]$new_cluster_id[1])) { + if (is.na(y_short[feature == current_feature, ]$new_cluster_id[1L])) { # Find the old cluster id. - old_cluster_id <- y_short[feature == current_feature, ]$cluster_id[1] + old_cluster_id <- y_short[feature == current_feature, ]$cluster_id[1L] # Update all entries with the same old cluster id. y_short[cluster_id == old_cluster_id, "new_cluster_id" := new_id] @@ -816,14 +886,16 @@ theme_familiar <- function( # Drop redundant columns y_short[, ":="( "cluster_id" = NULL, - "new_cluster_id" = NULL)] + "new_cluster_id" = NULL + )] # Merge with y. y <- merge( x = y, y = y_short, by = "feature", - all = TRUE) + all = TRUE + ) # Mark singular clusters y[is.na(cluster_name), "cluster_name" := singular_cluster_character] @@ -849,24 +921,25 @@ theme_familiar <- function( if (is.null(plot_layout_table)) { plot_layout_table <- do.call( .get_plot_layout_table, - args = c( - list("x" = x), - list(...))) + args = c(list("x" = x), list(...)) + ) } # Derive facet_by facet_by <- setdiff( colnames(plot_layout_table), - c("col_id", "row_id")) + c("col_id", "row_id") + ) - if (length(facet_by > 0)) { + if (length(facet_by) > 0L) { # Merge the plot_layout_table into x. This will keep things in order. All # levels are kept. x <- merge( x = x, y = plot_layout_table, by = facet_by, - all = TRUE) + all = TRUE + ) } else { x <- cbind(x, plot_layout_table) @@ -876,7 +949,8 @@ theme_familiar <- function( split_data <- split( x, by = c("col_id", "row_id"), - sorted = TRUE) + sorted = TRUE + ) return(split_data) } @@ -888,13 +962,15 @@ theme_familiar <- function( if (is.null(plot_layout_table)) { plot_layout_table <- do.call( .get_plot_layout_table, - args = list(...)) + args = list(...) + ) } # Return (nrows, ncols) return(c( max(plot_layout_table$row_id), - max(plot_layout_table$col_id))) + max(plot_layout_table$col_id) + )) } @@ -904,7 +980,8 @@ theme_familiar <- function( # Simple 1x1 layout without facets. plot_layout_table <- data.table::data.table( "col_id" = 1L, - "row_id" = 1L) + "row_id" = 1L + ) } else if (is.null(facet_wrap_cols)) { # Generate a plot_layout_table and order it @@ -912,23 +989,25 @@ theme_familiar <- function( lapply( facet_by, function(column, x) levels(x[[column]]), - x = x), - KEEP.OUT.ATTRS = FALSE) + x = x + ), + KEEP.OUT.ATTRS = FALSE + ) plot_layout_table <- data.table::as.data.table(plot_layout_table) data.table::setnames(plot_layout_table, facet_by) data.table::setorderv(x = plot_layout_table, cols = facet_by) # Find the number of columns - n_cols <- length(unique(x[[facet_by[1]]])) + n_cols <- length(unique(x[[facet_by[1L]]])) # Add column id to the plot_layout_table - plot_layout_table[, "col_id" := .GRP, by = get(facet_by[1])] + plot_layout_table[, "col_id" := .GRP, by = get(facet_by[1L])] - if (length(facet_by) > 1) { + if (length(facet_by) > 1L) { # Find the number of rows n_levels <- sapply( - facet_by[2:length(facet_by)], + facet_by[2L:length(facet_by)], function(ii, x) { if (is.factor(x[[ii]])) { return(nlevels(x[[ii]])) @@ -936,18 +1015,20 @@ theme_familiar <- function( return(length(unique(x[[ii]]))) } }, - x = x) + x = x + ) n_rows <- prod(n_levels) # Add row id to the plot_layout_table - facet_row_cols <- facet_by[2:length(facet_by)] + facet_row_cols <- facet_by[2L:length(facet_by)] plot_layout_table[, "row_id" := .GRP, by = mget(facet_row_cols)] } else { # There is only one row - n_rows <- 1 + n_rows <- 1L plot_layout_table[, "row_id" := 1L] } + } else { # Generate a plot_layout_table, and order plot_layout_table <- unique(x[, (facet_by), with = FALSE], by = facet_by) @@ -965,7 +1046,8 @@ theme_familiar <- function( # Add column and row ids to the plot_layout_table. plot_layout_table[, ":="( "col_id" = col_ids, - "row_id" = row_ids)] + "row_id" = row_ids + )] } return(plot_layout_table) @@ -973,140 +1055,547 @@ theme_familiar <- function( -.update_plot_layout_table <- function( +.combine_plot_elements <- function( + g_main, + g_new, + element_name, + spacer = NULL, + stack_direction = "vertical" +) { + + for (current_element_name in element_name) { + # Determine matching elements in both g_main and g_new. + element_names_main <- g_main$layout$name + present_elements_main <- element_names_main[sapply( + element_names_main, + startswith_any, + prefix = current_element_name + )] + + element_names_new <- g_new$layout$name + present_elements_new <- element_names_new[sapply( + element_names_new, + startswith_any, + prefix = current_element_name + )] + + if (length(present_elements_main) != 1L || length(present_elements_new) != 1L) next + + grob_index_main <- which(g_main$layout$name == present_elements_main) + grob_index_new <- which(g_new$layout$name == present_elements_new) + + # Determine if there is anything to add from g_new. + if (any(sapply(c("zeroGrob", "nullGrob"), function(ii, x) (is(x, ii)), x = g_new$grobs[[grob_index_new]]))) next + + grob_main <- g_main$grobs[[grob_index_main]] + grob_new <- g_new$grobs[[grob_index_new]] + + # If there is an empty grob in g_main, simply copy the element from g_new + # into g_main. + if (any(sapply(c("zeroGrob", "nullGrob"), function(ii, x) (is(x, ii)), x = g_main$grobs[[grob_index_main]]))) { + g_main$grobs[[grob_index_main]] <- grob_new + + } else { + g <- list(grob_main, grob_new) + + # Find widths and heights + widths <- lapply(g, .gtable_get_grob_aspect_size, aspect = "width") + if (!is.null(spacer) && stack_direction == "horizontal") { + widths <- append(widths, 0L, after = 1L) + # Direct insertion of spacer with append results in spacer losing its + # simpleUnit class. + widths[[2L]] <- spacer + } + widths <- do.call(grid::unit.c, widths) + + heights <- lapply(g, .gtable_get_grob_aspect_size, aspect = "height") + if (!is.null(spacer) && stack_direction == "vertical") { + heights <- append(heights, 0L, after = 1L) + # Direct insertion of spacer with append results in spacer losing its + # simpleUnit class. + heights[[2L]] <- spacer + } + heights <- do.call(grid::unit.c, heights) + + if (stack_direction == "vertical") { + # Concatenate the widths. + widths <- max(widths) + + } else { + # Concatenate the heights. + heights <- max(heights) + } + + # Set up basic gtable. + g_combine <- gtable::gtable( + widths = widths, + heights = heights, + name = present_elements_main + ) + + # Insert grob from main. + g_combine <- gtable::gtable_add_grob( + g_combine, + grobs = g[[1L]], + t = 1L, + l = 1L + ) + + # Insert grob from new. + g_combine <- gtable::gtable_add_grob( + g_combine, + grobs = g[[2L]], + t = length(heights), + l = length(widths) + ) + + # Insert spacer. + if (!is.null(spacer) && stack_direction == "vertical") { + spacer_position <- c(2L, 2L, 1L, 1L) + names(spacer_position) <- c("t", "b", "l", "r") + + g_combine <- .gtable_insert_spacer( + g_combine, + position = spacer_position, + height = spacer + ) + + } else if (!is.null(spacer) && stack_direction == "horizontal") { + spacer_position <- c(1L, 1L, 2L, 2L) + names(spacer_position) <- c("t", "b", "l", "r") + + g_combine <- .gtable_insert_spacer( + g_combine, + position = spacer_position, + width = spacer + ) + } + + g_main$grobs[[grob_index_main]] <- g_combine + } + } + + g_main <- .gtable_update_layout(g = g_main) + + return(g_main) +} + + + +.compose_figure <- function( + figure_list, plot_layout_table, - grobs, x_text_shared = "overall", x_label_shared = "overall", y_text_shared = "overall", y_label_shared = "overall", - facet_wrap_cols = NULL) { + facet_wrap_cols = NULL, + ggtheme = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table - col_id <- row_id <- is_present <- fraction_present <- NULL + col_id <- row_id <- is_present <- n_present <- NULL + type <- NULL + + # Global layout -------------------------------------------------------------- + + # Add figure names to plot_layout_table. + plot_layout_table[, figure_name := paste0(row_id, ".", col_id)] + plot_layout_table[, is_present := figure_name %in% names(figure_list)] + + # Drop columns with only missing information. + empty_cols <- plot_layout_table[ + , + list("n_present" = sum(is_present)), + by = "col_id" + ] + empty_cols <- empty_cols[n_present == 0L]$col_id + if (length(empty_cols) > 0L) { + plot_layout_table <- plot_layout_table[!col_id %in% empty_cols] + } + + # Drop rows with only missing information. + empty_rows <- plot_layout_table[ + , + list("n_present" = sum(is_present)), + by = "row_id" + ] + empty_rows <- empty_rows[n_present == 0L]$row_id + if (length(empty_rows) > 0L) { + plot_layout_table <- plot_layout_table[!row_id %in% empty_rows] + } - # Update the layout table by adding a figure id and determining if the grob - # is present. - plot_layout_table[, ":="( - "figure_id" = .I, - "is_present" = sapply(grobs, gtable::is.gtable))] + # Check that any part of the plot is remaining + if (is_empty(plot_layout_table)) return(NULL) - # Drop panels in the plot. - if (!is.null(facet_wrap_cols)) { - # Keep only panels that are present. - plot_layout_table <- plot_layout_table[is_present == TRUE] - } else { - # Drop rows and columns from the table that do not contain any data. - empty_columns <- plot_layout_table[, list( - fraction_present = sum(is_present) / .N), - by = "col_id"] - empty_columns <- empty_columns[fraction_present == 0.0]$col_id + # Create missing figure panels ----------------------------------------------- + + # Identify and add missing figures. + missing_figures <- plot_layout_table[is_present == FALSE]$figure_name + for (missing_figure in missing_figures) { + # Get col_id and row_id to identify template figures. + current_row_id <- plot_layout_table[figure_name == missing_figure]$row_id + current_col_id <- plot_layout_table[figure_name == missing_figure]$col_id - if (length(empty_columns) > 0) { - plot_layout_table <- plot_layout_table[!col_id %in% empty_columns] - } - - empty_rows <- plot_layout_table[, list( - fraction_present = sum(is_present) / .N), - by = "row_id"] - empty_rows <- empty_rows[fraction_present == 0.0]$row_id + # Identify figures to use as templates. + template_figure_row_name <- head(plot_layout_table[row_id == current_row_id & is_present == TRUE]$figure_name, n = 1L) + template_figure_col_name <- head(plot_layout_table[col_id == current_col_id & is_present == TRUE]$figure_name, n = 1L) - if (length(empty_rows) > 0) { - plot_layout_table <- plot_layout_table[!row_id %in% empty_rows] - } + # Add template. + figure_list[[missing_figure]] <- .create_placeholder_figure( + template_figure_row = figure_list[[template_figure_row_name]], + template_figure_col = figure_list[[template_figure_col_name]], + row_id = current_row_id, + col_id = current_col_id + ) } - - # Check that any part of the plot is remaining - if (is_empty(plot_layout_table)) return(plot_layout_table) - - if (!is.null(facet_wrap_cols)) { - # Number of columns is provided using facet_wrap_cols. - len_table <- nrow(plot_layout_table) - n_cols <- facet_wrap_cols - n_rows <- ceiling(len_table / n_cols) - - # Generate the column and row positions. - col_ids <- rep(seq_len(n_cols), times = n_rows)[seq_len(len_table)] - row_ids <- rep(seq_len(n_rows), each = n_cols)[seq_len(len_table)] - - # Set default elements - plot_layout_table[, ":="( - "col_id" = col_ids, - "row_id" = row_ids, - "has_strip_x" = TRUE, - "has_strip_y" = FALSE, - "has_axis_text_x" = x_text_shared %in% c("individual", "FALSE"), - "has_axis_text_y" = y_text_shared %in% c("individual", "FALSE"), - "has_axis_label_x" = x_label_shared == "individual", - "has_axis_label_y" = y_label_shared == "individual")] - - for (current_col_id in seq_len(n_cols)) { - # Determine the bottom row. - max_row_id <- max(plot_layout_table[col_id == current_col_id]$row_id) - - # Set x labels and text. Note that even when "overall" is set, axis text - # should stick to the panels. - if (x_text_shared %in% c("column", "overall", "TRUE")) { - plot_layout_table[ - col_id == current_col_id & row_id == max_row_id, - "has_axis_text_x" := TRUE] - } - if (x_label_shared == "column") { - plot_layout_table[ - col_id == current_col_id & row_id == max_row_id, - "has_axis_label_x" := TRUE] + + # Check that no figures are missing now. + plot_layout_table[, is_present := figure_name %in% names(figure_list)] + if (!all(plot_layout_table$is_present)) { + ..error_reached_unreachable_code("All panels of the figure should be present, but one or more are missing.") + } + + # Shared elements between figure panels -------------------------------------- + + # Determine top and bottom rows, and left and right columns. + top_row_id <- min(plot_layout_table$row_id) + bottom_row_id <- max(plot_layout_table$row_id) + left_col_id <- min(plot_layout_table$col_id) + right_col_id <- max(plot_layout_table$col_id) + + # Remove elements from figures. + for (figure_name in names(figure_list)) { + # Configure removal. + figure_list[[figure_name]] <- .set_figure_element_removal( + object = figure_list[[figure_name]], + top_row_id = top_row_id, + bottow_row_id = bottom_row_id, + left_col_id = left_col_id, + right_col_id = right_col_id, + x_text_shared = x_text_shared, + y_text_shared = y_text_shared, + x_label_shared = x_label_shared, + y_label_shared = y_label_shared + ) + + # Remove elements by replacing them with a zeroGrob. This maintains the + # size of the figure's gtable. + figure_list[[figure_name]] <- .remove_figure_elements( + object = figure_list[[figure_name]], + replace_by_zero_grob = TRUE + ) + } + + # Compose figure panels ------------------------------------------------------ + + # Form plot rows. + g <- NULL + spacer_width_x <- .get_plot_panel_spacing(ggtheme = ggtheme, axis = "x") + spacer_width_y <- .get_plot_panel_spacing(ggtheme = ggtheme, axis = "y") + unique_rows <- sort(unique(plot_layout_table$row_id)) + unique_cols <- sort(unique(plot_layout_table$col_id)) + for (current_row_id in unique_rows) { + # Merge columns within each row. + g_row <- NULL + for (current_col_id in unique_cols) { + if (is.null(g_row)) { + # Use + g_row <- figure_list[[paste0(current_row_id, ".", current_col_id)]]@gtable + + } else { + # Insert column for spacer. + g_row <- gtable::gtable_add_cols( + g_row, + widths = spacer_width_x, + pos = ncol(g_row) + ) + + # Add spacer. + g_row <- .gtable_insert_spacer( + g = g_row, + position = c("t" = 1L, "b" = nrow(g_row), "l" = ncol(g_row), "r" = ncol(g_row)), + width = spacer_width_x + ) + + # Combine gtable by columns. + g_row <- cbind(g_row, figure_list[[paste0(current_row_id, ".", current_col_id)]]@gtable) } } - - # Set y labels and text. Note that even when "overall" is set, axis text - # should stick to the panels. - if (y_text_shared %in% c("row", "overall", "TRUE")) { - plot_layout_table[col_id == 1L, "has_axis_text_y" := TRUE] - } - if (y_label_shared == "row") { - plot_layout_table[col_id == 1L, "has_axis_label_y" := TRUE] - } - - } else { - # Update the column and row ids. - plot_layout_table[, "col_id" := .GRP, by = "col_id"] - plot_layout_table[, "row_id" := .GRP, by = "row_id"] - - # Set default elements - plot_layout_table[, ":="( - "has_strip_x" = FALSE, - "has_strip_y" = FALSE, - "has_axis_text_x" = x_text_shared %in% c("individual", "FALSE"), - "has_axis_text_y" = y_text_shared %in% c("individual", "FALSE"), - "has_axis_label_x" = x_label_shared == "individual", - "has_axis_label_y" = y_label_shared == "individual")] - # Determine the number of rows and columns - n_cols <- max(plot_layout_table$col_id) - n_rows <- max(plot_layout_table$row_id) - - # Add strips - if (n_rows > 1) plot_layout_table[col_id == n_cols, "has_strip_y" := TRUE] - if (n_cols > 1) plot_layout_table[row_id == 1L, "has_strip_x" := TRUE] - - # Add axis text. Note that even when "overall" is set, axis text should - # stick to the panels. - if (x_text_shared %in% c("column", "overall", "TRUE")) { - plot_layout_table[row_id == n_rows, "has_axis_text_x" := TRUE] + # Merge with existing rows. + if (is.null(g)) { + g <- g_row + + } else { + # Insert row for spacer. + g_row <- gtable::gtable_add_rows( + g_row, + heights = spacer_width_y, + pos = nrow(g_row) + ) + + # Add spacer element in the new row. + g_row <- .gtable_insert_spacer( + g = g_row, + position = c("t" = nrow(g_row), "b" = nrow(g_row), "l" = 1L, "r" = ncol(g_row)), + height = spacer_width_y + ) + + # Combine gtable by rows. + g <- rbind(g, g_row) + } + } + + # Insert global elements ----------------------------------------------------- + + # Insert global elements. + global_element_names <- c( + .all_gtable_title_names(), + .all_gtable_guide_names() + ) + if (x_text_shared %in% c("overall", "TRUE")) { + global_element_names <- c(global_element_names, .all_gtable_axis_x_names()) + } + if (x_label_shared %in% c("overall", "TRUE")) { + global_element_names <- c(global_element_names, .all_gtable_label_x_names()) + } + if (y_text_shared %in% c("overall", "TRUE")) { + global_element_names <- c(global_element_names, .all_gtable_axis_y_names()) + } + if (y_label_shared %in% c("overall", "TRUE")) { + global_element_names <- c(global_element_names, .all_gtable_label_x_names()) + } + + # Isolate global elements that need to be updated. + global_elements <- figure_list[[1L]]@global_elements + global_element_name_list <- lapply( + names(global_elements), + function(x, y) { + if (!startswith_any(x, y)) return(NULL) + return(list( + "name" = x, + "type" = y[sapply(y, function(y, x) {startsWith(x, y)}, x = x)] + )) + }, + y = global_element_names + ) + global_element_name_list <- data.table::rbindlist(global_element_name_list) + + # For title-like objects, insert in place, at the top. + if (any(global_element_name_list$type %in% .all_gtable_title_names("title"))) { + x <- global_element_name_list[type %in% .all_gtable_title_names("title")] + for (ii in seq_len(nrow(x))) { + element_positions <- g$layout[g$layout$name == x$name[ii], c("t", "l", "b", "r"), drop = FALSE] + position <- c("t" = 0L, "l" = 0L, "b" = 0L, "r" = 0L) + position["t"] <- position["b"] <- min(element_positions$t) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + g <- .gtable_insert( + g = g, + g_new = global_elements[[x$name[ii]]], + where = c("at", position), + grob_name = x$name[ii] + ) } - if (y_text_shared %in% c("row", "overall", "TRUE")) { - plot_layout_table[col_id == 1L, "has_axis_text_y" := TRUE] + } + + # For caption-like objects, insert in place, at the bottom. + if (any(global_element_name_list$type %in% .all_gtable_title_names("caption"))) { + x <- global_element_name_list[type %in% .all_gtable_title_names("caption")] + for (ii in seq_len(nrow(x))) { + element_positions <- g$layout[g$layout$name == x$name[ii], c("t", "l", "b", "r"), drop = FALSE] + position <- c("t" = 0L, "l" = 0L, "b" = 0L, "r" = 0L) + position["t"] <- position["b"] <- max(element_positions$b) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + g <- .gtable_insert( + g = g, + g_new = global_elements[[x$name[ii]]], + where = c("at", position), + grob_name = x$name[ii] + ) } + } - # Add axis labels - if (x_label_shared == "column") { - plot_layout_table[row_id == n_rows, "has_axis_label_x" := TRUE] + # For guide-like objects, insert at the corresponding position. + if (any(global_element_name_list$type %in% .all_gtable_guide_names())) { + x <- global_element_name_list[type %in% .all_gtable_guide_names()] + for (ii in seq_len(nrow(x))) { + element_positions <- g$layout[g$layout$name == x$name[ii], c("t", "l", "b", "r"), drop = FALSE] + position <- c("t" = 0L, "l" = 0L, "b" = 0L, "r" = 0L) + + # Positioning + if (x$type[ii] %in% .all_gtable_guide_names("top")) { + position["t"] <- position["b"] <- min(element_positions$t) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + + spacer_position <- position + spacer_position[["t"]] <- spacer_position[["b"]] <- position[["b"]] + 1L + g <- .gtable_insert_spacer( + g = g, + position = spacer_position, + height = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "y"), + make_space = TRUE + ) + + } else if (x$type[ii] %in% .all_gtable_guide_names("bottom")) { + position["t"] <- position["b"] <- max(element_positions$b) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + + spacer_position <- position + spacer_position[["t"]] <- spacer_position[["b"]] <- position[["t"]] + g <- .gtable_insert_spacer( + g = g, + position = spacer_position, + height = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "y"), + make_space = TRUE + ) + + # Inserting the spacer moves the guide object down. + position[["t"]] <- position[["t"]] + 1L + position[["b"]] <- position[["b"]] + 1L + + } else if (x$type[ii] %in% .all_gtable_guide_names("left")) { + position["l"] <- position["r"] <- min(element_positions$l) + position["t"] <- min(element_positions$t) + position["b"] <- max(element_positions$b) + + spacer_position <- position + spacer_position[["l"]] <- spacer_position[["r"]] <- position[["r"]] + 1L + g <- .gtable_insert_spacer( + g = g, + position = spacer_position, + width = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "x"), + make_space = TRUE + ) + + } else if (x$type[ii] %in% .all_gtable_guide_names("right")) { + position["l"] <- position["r"] <- max(element_positions$r) + position["t"] <- min(element_positions$t) + position["b"] <- max(element_positions$b) + + spacer_position <- position + spacer_position[["l"]] <- spacer_position[["r"]] <- position[["l"]] + g <- .gtable_insert_spacer( + g = g, + position = spacer_position, + width = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "x"), + make_space = TRUE + ) + + # Inserting the spacer moves the guide object right. + position[["l"]] <- position[["l"]] + 1L + position[["r"]] <- position[["r"]] + 1L + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", x$type[1L])) + } + + g <- .gtable_insert( + g = g, + g_new = global_elements[[x$name[ii]]], + where = c("at", position), + grob_name = x$name[ii] + ) + } + } + + # Labels + if (any(global_element_name_list$type %in% .all_gtable_label_names())) { + x <- global_element_name_list[type %in% .all_gtable_label_names()] + for (ii in seq_len(nrow(x))) { + element_positions <- g$layout[g$layout$name == x$name[ii], c("t", "l", "b", "r"), drop = FALSE] + position <- c("t" = 0L, "l" = 0L, "b" = 0L, "r" = 0L) + + # Positioning + if (x$type[ii] %in% .all_gtable_label_names("top")) { + position["t"] <- position["b"] <- min(element_positions$t) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + + } else if (x$type[ii] %in% .all_gtable_label_names("bottom")) { + position["t"] <- position["b"] <- max(element_positions$b) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + + } else if (x$type[ii] %in% .all_gtable_label_names("left")) { + position["l"] <- position["r"] <- min(element_positions$l) + position["t"] <- min(element_positions$t) + position["b"] <- max(element_positions$b) + + } else if (x$type[ii] %in% .all_gtable_label_names("right")) { + position["l"] <- position["r"] <- max(element_positions$r) + position["t"] <- min(element_positions$t) + position["b"] <- max(element_positions$b) + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", x$type[1L])) + } + + g <- .gtable_insert( + g = g, + g_new = global_elements[[x$name[ii]]], + where = c("at", position), + grob_name = x$name[ii] + ) } - if (y_label_shared == "row") { - plot_layout_table[col_id == 1L, "has_axis_label_y" := TRUE] + } + + # Axis elements + if (any(global_element_name_list$type %in% .all_gtable_axis_names())) { + x <- global_element_name_list[type %in% .all_gtable_axis_names()] + for (ii in seq_len(nrow(x))) { + element_positions <- g$layout[g$layout$name == x$name[ii], c("t", "l", "b", "r"), drop = FALSE] + position <- c("t" = 0L, "l" = 0L, "b" = 0L, "r" = 0L) + + # Positioning + if (x$type[ii] %in% .all_gtable_axis_names("top")) { + position["t"] <- position["b"] <- min(element_positions$t) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + + } else if (x$type[ii] %in% .all_gtable_axis_names("bottom")) { + position["t"] <- position["b"] <- max(element_positions$b) + position["l"] <- min(element_positions$l) + position["r"] <- max(element_positions$r) + + } else if (x$type[ii] %in% .all_gtable_axis_names("left")) { + position["l"] <- position["r"] <- min(element_positions$l) + position["t"] <- min(element_positions$t) + position["b"] <- max(element_positions$b) + + } else if (x$type[ii] %in% .all_gtable_axis_names("right")) { + position["l"] <- position["r"] <- max(element_positions$r) + position["t"] <- min(element_positions$t) + position["b"] <- max(element_positions$b) + + } else { + ..error_reached_unreachable_code(paste0("unknown type: ", x$type[1L])) + } + + g <- .gtable_insert( + g = g, + g_new = global_elements[[x$name[ii]]], + where = c("at", position), + grob_name = x$name[ii] + ) } } + + # Clean-up ------------------------------------------------------------------- + + # Drop all zeroGrob elements to prevent occlusion by empty objects. + matched_elements <- !sapply(g$grobs, is, "zeroGrob") + g$layout <- g$layout[matched_elements, , drop = FALSE] + g$grobs <- g$grobs[matched_elements] + g <- gtable::gtable_trim(g) + + # Update heights and widths. + g <- .gtable_update_layout(g = g) - return(plot_layout_table) + return(g) } @@ -1117,11 +1606,7 @@ theme_familiar <- function( # Since ggplot 3.4.0, the width of a line is determined by linewidth instead # of size. - if (utils::packageVersion("ggplot2") >= "3.4.0") { - linewidth <- ggtheme$line$linewidth - } else { - linewidth <- ggtheme$line$size - } + linewidth <- ggtheme$line$linewidth return(linewidth) } @@ -1133,12 +1618,39 @@ theme_familiar <- function( # Import default ggtheme in case none is provided. ggtheme <- .check_ggtheme(ggtheme) - - # Get spacing for the specific axis, if present. - spacing <- ggtheme[[paste0(theme_element, ".", axis)]] - - # Get spacing for the main element - if (is.null(spacing)) spacing <- ggtheme[[theme_element]] + + # Basic spacing settings + spacing <- ggtheme$spacing + spacing_rel <- 1.0 + + # Attempt to base the text size on the general axis.text attribute. + if (!is.null(ggtheme[[theme_element]])) { + if (inherits(ggtheme[[theme_element]], "rel")) { + # Find the relative text size of axis text. + spacing_rel <- as.numeric(ggtheme[[theme_element]]) + + } else { + # Set absolute text size. + spacing <- ggtheme[[theme_element]] + spacing_rel <- 1.0 + } + } + + # Attempt to refine the text size using the axis.text.y attribute in + # particular. + if (!is.null(ggtheme[[paste0(theme_element, ".", axis)]])) { + if (inherits(ggtheme[[paste0(theme_element, ".", axis)]], "rel")) { + # Set relative text size of axis text + spacing_rel <- as.numeric(ggtheme[[paste0(theme_element, ".", axis)]]) + + } else { + # Set absolute text size. + spacing <- ggtheme[[paste0(theme_element, ".", axis)]] + spacing_rel <- 1.0 + } + } + + spacing <- spacing * spacing_rel # If no spacing is provided, produce 0.0 length spacing. if (!grid::is.unit(spacing)) spacing <- grid::unit(0.0, "pt") @@ -1153,7 +1665,8 @@ theme_familiar <- function( return(..get_plot_element_spacing( ggtheme = ggtheme, axis = axis, - theme_element = "panel.spacing")) + theme_element = "panel.spacing" + )) } @@ -1163,7 +1676,8 @@ theme_familiar <- function( return(..get_plot_element_spacing( ggtheme = ggtheme, axis = axis, - theme_element = "legend.box.spacing")) + theme_element = "legend.spacing" + )) } @@ -1205,7 +1719,7 @@ theme_familiar <- function( } # Update the text size using the magical ggplot2 point size (ggplot2:::.pt). - geom_text_size <- fontsize * fontsize_rel / 2.845276 + geom_text_size <- fontsize * fontsize_rel / ggplot2::.pt # Obtain lineheight lineheight <- ggtheme$text$lineheight @@ -1237,7 +1751,8 @@ theme_familiar <- function( "colour" = colour, "family" = fontfamily, "face" = fontface, - "lineheight" = lineheight)) + "lineheight" = lineheight + )) } @@ -1246,1038 +1761,63 @@ theme_familiar <- function( -#' Feature arrangement -#' -#' @param grobs list of graphic objects (grobs) -#' @param plot_layout_table layout table -#' @param panel_elements elements that should be added to each panel -#' @param figure_elements elements that are added to the figure as a whole -#' @param element_grobs grobs of the elements -#' @param ggtheme ggtheme -#' -#' @return a single gtable -#' -#' @noRd -.arrange_plot_grobs <- function( - grobs, - plot_layout_table, - element_grobs, - ggtheme) { - # Suppress NOTES due to non-standard evaluation in data.table - col_id <- row_id <- NULL - figure_data <- ..arrange_plot_grobs( - grobs = grobs, - element_grobs = element_grobs, - plot_layout_table = plot_layout_table, - ggtheme = ggtheme - ) - if (is_empty(figure_data)) return(NULL) - # Placeholder for final figure - g <- NULL - # Determine the number of rows and columns. - n_rows <- max(plot_layout_table$row_id) - n_cols <- max(plot_layout_table$col_id) +.rename_plot_grobs <- function(g, extension = "main", use_generic = TRUE) { + if (is.null(g)) return(g) - # Iterate over rows and columns. - for (ii in seq_len(n_rows)) { - # Create a placeholder. - g_current_row <- NULL + element_names <- c( + .all_gtable_panel_names(), + .all_gtable_label_x_names(), + .all_gtable_label_y_names(), + .all_gtable_axis_x_names(), + .all_gtable_axis_y_names() + ) + + # Filter only elements that are present, and generate list of matching + # local and global elements. + renamable_elements <- g$layout$name + element_list <- lapply( + renamable_elements, + function(x, y) { + if (!startswith_any(x, prefix = y)) return(NULL) + + y <- y[sapply(y, function(y, x) {startsWith(x, y)}, x = x)] + return(list("local" = x, "global" = y)) + }, + y = element_names + ) + element_list <- data.table::rbindlist(element_list) + + # If generic names are not used, replace global (generic) names by the local + # names. + if (!use_generic) { + element_list$global <- element_list$local + } - # Populate the current row with figures. - for (jj in seq_len(n_cols)) { - selected_figure_id <- plot_layout_table[col_id == jj & row_id == ii]$figure_id + # Rename elements and add extension. + for (ii in seq_len(nrow(element_list))) { + g <- .gtable_rename_element( + g = g, + old = element_list$local[ii], + new = paste0(element_list$global[ii], "-", extension), + partial_match = FALSE, + allow_missing = FALSE + ) + } + + return(g) +} - # Check if the iterator exceeds the maximum number of available figures. - if (length(selected_figure_id) == 0) break - # Select the current grob. - current_grob <- figure_data[[selected_figure_id]] - if (is.null(g_current_row)) { - # If the current row is still empty, copy the first figure. - g_current_row <- current_grob - - } else { - # If the current row is not empty, use cbind.gtable to combine figures - # column-wise. - - # First insert a column that spaces the facets. - g_current_row <- gtable::gtable_add_cols( - g_current_row, - widths = .get_plot_panel_spacing(ggtheme = ggtheme, axis = "x")) - - # Add the figure to the current figure. - g_current_row <- cbind(g_current_row, current_grob) - } - } - - # Populate the figure. - if (is.null(g)) { - # If the figure is still empty, copy the current row. - g <- g_current_row - - } else { - # Use rbind.gtable to combine rows. - g <- rbind(g, g_current_row) - } - - # Check if the iterator exceeds the maximum number of available figures. - if (length(selected_figure_id) == 0) break - } - - # Identify data that should be re-inserted. - g <- ..insert_global_plot_grobs( - grobs = g, - element_grobs = element_grobs, - plot_layout_table = plot_layout_table, - ggtheme = ggtheme) - - return(g) -} - - - -..arrange_plot_grobs <- function( - grobs, - element_grobs, - plot_layout_table, - keep_axis_text_x = FALSE, - keep_axis_text_y = FALSE, - ggtheme = NULL) { - # Suppress NOTES due to non-standard evaluation in data.table - figure_id <- is_present <- col_id <- row_id <- NULL - - # Check whether the plot layout table is empty. - if (is_empty(plot_layout_table)) return(NULL) - - # Create a placeholder list. This is done to prevent losing a connection - # between figure id and the length of the list in case entire columns or rows - # were removed from the plot_layout_table. - figure_list <- replicate(n = max(plot_layout_table$figure_id), NULL) - - # Iterate over the plot layout table to compile all the data required to - # create the sub-figures. - - for (ii in plot_layout_table$figure_id) { - removed_axis_text_x <- removed_axis_text_y <- FALSE - - current_figure_list <- list() - if (plot_layout_table[figure_id == ii]$is_present) { - # Collect the main dataset. - current_figure_list$main <- grobs[[ii]] - - # Collect additional plot data. - if (plot_layout_table[figure_id == ii]$has_strip_x) { - current_figure_list$strip_x <- element_grobs[[ii]]$strip_x - } - if (plot_layout_table[figure_id == ii]$has_strip_y) { - current_figure_list$strip_y <- element_grobs[[ii]]$strip_y - } - - # Collect labels for the x-axis - if (plot_layout_table[figure_id == ii]$has_axis_label_x) { - current_figure_list$axis_label_b <- element_grobs[[ii]]$axis_label_b - current_figure_list$axis_label_t <- element_grobs[[ii]]$axis_label_t - } - - # Collect labels for the y-axis. - if (plot_layout_table[figure_id == ii]$has_axis_label_y) { - current_figure_list$axis_label_l <- element_grobs[[ii]]$axis_label_l - current_figure_list$axis_label_r <- element_grobs[[ii]]$axis_label_r - } - - # Collect axis text data for the x-axis. - if (plot_layout_table[figure_id == ii]$has_axis_text_x && !keep_axis_text_x) { - current_figure_list$axis_text_b <- element_grobs[[ii]]$axis_text_b - current_figure_list$axis_text_t <- element_grobs[[ii]]$axis_text_t - - } else if (!keep_axis_text_x) { - removed_axis_text_x <- TRUE - - current_figure_list$axis_text_b <- element_grobs[[ii]]$axis_text_b_nt - current_figure_list$axis_text_t <- element_grobs[[ii]]$axis_text_t_nt - } - - # Collect axis text data for the y-axis. - if (plot_layout_table[figure_id == ii]$has_axis_text_y && !keep_axis_text_y) { - current_figure_list$axis_text_l <- element_grobs[[ii]]$axis_text_l - current_figure_list$axis_text_r <- element_grobs[[ii]]$axis_text_r - - } else if (!keep_axis_text_y) { - removed_axis_text_y <- TRUE - - current_figure_list$axis_text_l <- element_grobs[[ii]]$axis_text_l_nt - current_figure_list$axis_text_r <- element_grobs[[ii]]$axis_text_r_nt - } - - } else { - # In this case the main plot data is not present. - replacement_grob <- .create_empty_plot_grob( - g = grobs[[plot_layout_table[is_present == TRUE]$figure_id[1]]], - keep_implicit = TRUE - ) - - # Identify existing grobs from the same row and from the same column. - current_row_id <- plot_layout_table[figure_id == ii]$row_id - current_col_id <- plot_layout_table[figure_id == ii]$col_id - same_row_figure_id <- plot_layout_table[is_present == TRUE & row_id == current_row_id]$figure_id[1] - same_col_figure_id <- plot_layout_table[is_present == TRUE & col_id == current_col_id]$figure_id[1] - - # Set the replacement dataset as the main dataset. - current_figure_list$main <- replacement_grob - - if (plot_layout_table[figure_id == ii]$has_strip_x) { - current_figure_list$strip_x <- element_grobs[[same_col_figure_id]]$strip_x - } - if (plot_layout_table[figure_id == ii]$has_strip_y) { - current_figure_list$strip_y <- element_grobs[[same_row_figure_id]]$strip_y - } - - # Collect labels for the x-axis. - if (plot_layout_table[figure_id == ii]$has_axis_label_x) { - current_figure_list$axis_label_b <- element_grobs[[same_col_figure_id]]$axis_label_b - current_figure_list$axis_label_t <- element_grobs[[same_col_figure_id]]$axis_label_t - } - - # Collect labels for the y-axis - if (plot_layout_table[figure_id == ii]$has_axis_label_y) { - current_figure_list$axis_label_l <- element_grobs[[same_row_figure_id]]$axis_label_l - current_figure_list$axis_label_r <- element_grobs[[same_row_figure_id]]$axis_label_r - } - } - - # Merge elements with the main element. - g <- .reinsert_plot_grobs( - grob_list = current_figure_list, - ggtheme = ggtheme) - - if (removed_axis_text_x) { - g <- .update_axis_text_grobs( - g = g, - type = "heights") - } - - if (removed_axis_text_y) { - g <- .update_axis_text_grobs( - g = g, - type = "widths") - } - - # Add data to the figure list. - figure_list[[ii]] <- g - } - - return(figure_list) -} - - - -..insert_global_plot_grobs <- function( - grobs, - element_grobs, - plot_layout_table, - ggtheme) { - # Suppress NOTES due to non-standard evaluation in data.table - is_present <- NULL - - figure_list <- list() - - # Select a figure that is present. - present_figure_id <- plot_layout_table[is_present == TRUE, ]$figure_id[1] - - if (!gtable::is.gtable(grobs)) { - ..error_reached_unreachable_code( - "..insert_global_plot_grobs: grob is not a gtable.") - } - - # Add main grob - figure_list$main <- grobs - - # Add guide. - figure_list$guide <- element_grobs[[present_figure_id]]$guide - - # Determine if axis labels need to be added. - if (all(plot_layout_table$has_axis_label_x == FALSE)) { - figure_list$axis_label_b <- element_grobs[[present_figure_id]]$axis_label_b - figure_list$axis_label_t <- element_grobs[[present_figure_id]]$axis_label_t - } - - if (all(plot_layout_table$has_axis_label_y == FALSE)) { - figure_list$axis_label_l <- element_grobs[[present_figure_id]]$axis_label_l - figure_list$axis_label_r <- element_grobs[[present_figure_id]]$axis_label_r - } - - # Add title, subtitle and caption. - figure_list$title <- element_grobs[[present_figure_id]]$title - figure_list$subtitle <- element_grobs[[present_figure_id]]$subtitle - figure_list$caption <- element_grobs[[present_figure_id]]$caption - - # Insert global elements. - g <- .reinsert_plot_grobs( - grob_list = figure_list, - ggtheme = ggtheme) - - return(g) -} - - - -.rename_plot_grobs <- function(g = g, extension = "main") { - if (is.null(g)) return(g) - - # Main panel - g <- .gtable_rename_element( - g = g, - old = "panel", - new = paste0("panel-", extension), - partial_match = TRUE, - allow_missing = TRUE) - - # Left axis text and label - g <- .gtable_rename_element( - g = g, - old = "axis-l", - new = paste0("axis-l-", extension), - partial_match = TRUE, - allow_missing = TRUE) - g <- .gtable_rename_element( - g = g, - old = "ylab-l", - new = paste0("ylab-l-", extension), - partial_match = TRUE, - allow_missing = TRUE) - - # Bottom axis text and label - g <- .gtable_rename_element( - g = g, - old = "axis-b", - new = paste0("axis-b-", extension), - partial_match = TRUE, - allow_missing = TRUE) - g <- .gtable_rename_element( - g = g, - old = "xlab-b", - new = paste0("xlab-b-", extension), - partial_match = TRUE, - allow_missing = TRUE) - - # Right axis text and label - g <- .gtable_rename_element( - g = g, - old = "axis-r", - new = paste0("axis-r-", extension), - partial_match = TRUE, - allow_missing = TRUE) - g <- .gtable_rename_element( - g = g, - old = "ylab-r", - new = paste0("ylab-r-", extension), - partial_match = TRUE, - allow_missing = TRUE) - - # Top axis text and label - g <- .gtable_rename_element( - g = g, - old = "axis-t", - new = paste0("axis-t-", extension), - partial_match = TRUE, - allow_missing = TRUE) - g <- .gtable_rename_element( - g = g, - old = "xlab-t", - new = paste0("xlab-t-", extension), - partial_match = TRUE, - allow_missing = TRUE) - - return(g) -} - - - -.extract_plot_grobs <- function(p) { - element_list <- list() - - # Convert to grobs - g <- .convert_to_grob(p) - - # Export list of elements. - if (is.null(g)) return(element_list) - - # Update the names of the plot elements. - g <- .rename_plot_grobs( - g = g, - extension = "main") - - # Legend - element_list$guide <- .gtable_extract( - g = g, - element = "guide-box", - drop_empty = TRUE) - - # Axis label - element_list$axis_label_b <- .gtable_extract( - g = g, - element = "xlab-b-main", - drop_empty = TRUE) - element_list$axis_label_t <- .gtable_extract( - g = g, - element = "xlab-t-main", - drop_empty = TRUE) - element_list$axis_label_l <- .gtable_extract( - g = g, - element = "ylab-l-main", - drop_empty = TRUE) - element_list$axis_label_r <- .gtable_extract( - g = g, - element = "ylab-r-main", - drop_empty = TRUE) - - # Strip x - element_list$strip_x <- .gtable_extract( - g = g, - element = "strip-t", - partial_match = TRUE, - drop_empty = TRUE) - element_list$strip_y <- .gtable_extract( - g = g, - element = "strip-r", - partial_match = TRUE, - drop_empty = TRUE) - - # Axis text (with text) - element_list$axis_text_b <- .gtable_extract( - g = g, - element = "axis-b-main", - partial_match = TRUE, - drop_empty = TRUE) - element_list$axis_text_t <- .gtable_extract( - g = g, element = "axis-t-main", - partial_match = TRUE, - drop_empty = TRUE) - element_list$axis_text_l <- .gtable_extract( - g = g, - element = "axis-l-main", - partial_match = TRUE, - drop_empty = TRUE) - element_list$axis_text_r <- .gtable_extract( - g = g, - element = "axis-r-main", - partial_match = TRUE, - drop_empty = TRUE) - - # Title, subtitle and caption - element_list$title <- .gtable_extract( - g = g, - element = "title", - partial_match = FALSE, - drop_empty = TRUE) - element_list$subtitle <- .gtable_extract( - g = g, - element = "subtitle", - partial_match = FALSE, - drop_empty = TRUE) - element_list$caption <- .gtable_extract( - g = g, - element = "caption", - partial_match = FALSE, - drop_empty = TRUE) - - # Update plot by removing the axis text, title, subtitle and captions. - p <- p + ggplot2::theme( - axis.text.x = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - plot.title = ggplot2::element_blank(), - plot.subtitle = ggplot2::element_blank(), - plot.caption = ggplot2::element_blank()) - - # Convert to grobs - g <- .convert_to_grob(p) - - # Update the names of the plot elements. - g <- .rename_plot_grobs( - g = g, - extension = "main") - - # Axis text (without text) - element_list$axis_text_b_nt <- .gtable_extract( - g = g, - element = "axis-b-main", - partial_match = TRUE, - drop_empty = TRUE) - element_list$axis_text_t_nt <- .gtable_extract( - g = g, - element = "axis-t-main", - partial_match = TRUE, - drop_empty = TRUE) - element_list$axis_text_l_nt <- .gtable_extract( - g = g, - element = "axis-l-main", - partial_match = TRUE, - drop_empty = TRUE) - element_list$axis_text_r_nt <- .gtable_extract( - g = g, - element = "axis-r-main", - partial_match = TRUE, - drop_empty = TRUE) - - # Title, subtitle, caption (without text) - element_list$title_nt <- .gtable_extract( - g = g, - element = "title", - partial_match = FALSE, - drop_empty = TRUE) - element_list$subtitle_nt <- .gtable_extract( - g = g, - element = "subtitle", - partial_match = FALSE, - drop_empty = TRUE) - element_list$caption_nt <- .gtable_extract( - g = g, - element = "caption", - partial_match = FALSE, - drop_empty = TRUE) - - return(element_list) -} - - -.remove_plot_grobs <- function(p) { - # Remove elements that were extracted as a grob from plots. - - # Check whether p is a ggplot. - if (!inherits(p, "ggplot")) return(p) - - # Remove all relevant elements - p <- p + ggplot2::theme( - strip.background.x = ggplot2::element_blank(), - strip.text.x = ggplot2::element_blank(), - strip.background.y = ggplot2::element_blank(), - strip.text.y = ggplot2::element_blank(), - legend.position = "none", - axis.title.x = ggplot2::element_blank(), - axis.text.x = ggplot2::element_blank(), - axis.ticks.x = ggplot2::element_blank(), - axis.line.x = ggplot2::element_blank(), - axis.title.y = ggplot2::element_blank(), - axis.text.y = ggplot2::element_blank(), - axis.ticks.y = ggplot2::element_blank(), - axis.line.y = ggplot2::element_blank(), - plot.title = ggplot2::element_blank(), - plot.subtitle = ggplot2::element_blank(), - plot.caption = ggplot2::element_blank()) - - return(p) -} - - - -.reinsert_plot_grobs <- function( - g = NULL, - elements = NULL, - grob_list, - ggtheme) { - if (is.null(g)) { - g <- grob_list$main - elements <- names(grob_list) - } - - if (is.null(g)) return(g) - - # Re-insert guides. - if ("guide" %in% elements && !is.null(grob_list$guide)) { - # Find legend position - legend_position <- ggtheme$legend.position - - if (legend_position == "right") { - # Align to right of the plot, and iterate inward to find valid reference elements. - for (ref_element in c("strip-r", "ylab-r", "axis-r", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along background. - g <- .gtable_insert_along( - g = g, - g_new = grob_list$guide, - ref_element = ref_element, - along_element = "panel", - spacer = list("l" = .get_plot_legend_spacing(ggtheme = ggtheme, axis = "y")), - where = legend_position, - partial_match_ref = TRUE, - partial_match_along = TRUE, - update_dimensions = FALSE) - - break - } - } - - } else if (legend_position == "left") { - # Align to left of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("strip-l", "ylab-l", "axis-l", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along background. - g <- .gtable_insert_along( - g = g, - g_new = grob_list$guide, - ref_element = ref_element, - along_element = "panel", - spacer = list("r" = .get_plot_legend_spacing(ggtheme = ggtheme, axis = "y")), - where = legend_position, - partial_match_ref = TRUE, - partial_match_along = TRUE, - update_dimensions = FALSE) - - break - } - } - - } else if (legend_position == "bottom") { - # Align to bottom of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("strip-b", "xlab-b", "axis-b", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along background. - g <- .gtable_insert_along( - g = g, - g_new = grob_list$guide, - ref_element = ref_element, - along_element = "panel", - spacer = list("t" = .get_plot_legend_spacing(ggtheme = ggtheme, axis = "x")), - where = legend_position, - partial_match_ref = TRUE, - partial_match_along = TRUE, - update_dimensions = FALSE) - - break - } - } - - } else if (legend_position == "top") { - # Align to top of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("strip-t", "xlab-t", "axis-t", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along background. - g <- .gtable_insert_along( - g = g, - g_new = grob_list$guide, - ref_element = ref_element, - along_element = "panel", - spacer = list("b" = .get_plot_legend_spacing(ggtheme = ggtheme, axis = "x")), - where = legend_position, - partial_match_ref = TRUE, - partial_match_along = TRUE, - update_dimensions = FALSE) - - break - } - } - } - } - - # Insert strip with facet text (for columns) - if ("strip_x" %in% elements && !is.null(grob_list$strip_x)) { - # Align top of the plot, and iterate inward to find valid reference elements. - for (ref_element in c("xlab-t", "axis-t", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$strip_x, - ref_element = ref_element, - along_element = "panel", - where = "top", - partial_match_ref = TRUE, - partial_match_along = TRUE) - - break - } - } - } - - - # Insert strip with facet text (for rows) - if ("strip_y" %in% elements && !is.null(grob_list$strip_y)) { - # Align to right of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("ylab-r", "axis-r", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$strip_y, - ref_element = ref_element, - along_element = "panel", - where = "right", - partial_match_ref = TRUE, - partial_match_along = TRUE) - - break - } - } - } - - # Insert bottom x-axis text - if ("axis_text_b" %in% elements && !is.null(grob_list$axis_text_b)) { - # Align to bottom of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_text_b, - ref_element = ref_element, - along_element = "panel-main", - where = "bottom", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - # Insert top x-axis text - if ("axis_text_t" %in% elements && !is.null(grob_list$axis_text_t)) { - # Align to bottom of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_text_t, - ref_element = ref_element, - along_element = "panel-main", - where = "top", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - # Insert left y-axis text - if ("axis_text_l" %in% elements && !is.null(grob_list$axis_text_l)) { - # Align to bottom of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_text_l, - ref_element = ref_element, - along_element = "panel-main", - where = "left", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - # Insert right y-axis text - if ("axis_text_r" %in% elements && !is.null(grob_list$axis_text_r)) { - # Align to bottom of the plot, and iterate inward to find valid reference - # elements. - for (ref_element in c("panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_text_r, - ref_element = ref_element, - along_element = "panel-main", - where = "right", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - # Insert y-axis label to the left. - if ("axis_label_l" %in% elements && !is.null(grob_list$axis_label_l)) { - # Align to left of the plot, and iterate inward to find valid reference elements. - for (ref_element in c("axis-l-main", "axis-l", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_label_l, - ref_element = ref_element, - along_element = "panel", - where = "left", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - - # Insert y-axis label to the right. - if ("axis_label_r" %in% elements && !is.null(grob_list$axis_label_r)) { - # Align to right of the plot, and iterate inward to find valid reference elements. - for (ref_element in c("axis-r-main", "axis-r", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_label_r, - ref_element = ref_element, - along_element = "panel", - where = "right", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - # Insert x-axis label to the bottom. - if ("axis_label_b" %in% elements && !is.null(grob_list$axis_label_b)) { - # Align to bottom of the plot, and iterate inward to find valid reference elements. - for (ref_element in c("axis-b-main", "axis-b", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_label_b, - ref_element = ref_element, - along_element = "panel", - where = "bottom", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - # Insert x-axis label to the top. - if ("axis_label_t" %in% elements && !is.null(grob_list$axis_label_b)) { - # Align to bottom of the plot, and iterate inward to find valid reference elements. - for (ref_element in c("axis-t-main", "axis-t", "panel-main", "panel")) { - if (.gtable_element_in_layout( - g = g, - element = ref_element, - partial_match = TRUE)) { - # If the reference element exists, add and align along the panel(s). - g <- .gtable_insert_along( - g = g, - g_new = grob_list$axis_label_t, - ref_element = ref_element, - along_element = "panel", - where = "top", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - - break - } - } - } - - if ("subtitle" %in% elements && !is.null(grob_list$subtitle)) { - # Insert subtitle label to the top. - g <- .gtable_insert_along( - g = g, - g_new = grob_list$subtitle, - ref_element = "subtitle", - where = "top", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - } - - - # Insert title label to the top. - if ("title" %in% elements && !is.null(grob_list$title)) { - g <- .gtable_insert_along( - g = g, - g_new = grob_list$title, - ref_element = "title", - where = "top", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - } - - - # Insert caption to the bottom. - if ("caption" %in% elements && !is.null(grob_list$caption)) { - g <- .gtable_insert_along( - g = g, - g_new = grob_list$caption, - ref_element = "caption", - where = "bottom", - attempt_replace = TRUE, - partial_match_ref = FALSE, - partial_match_along = FALSE) - } - - return(g) -} - - - - - -.create_empty_plot_grob <- function(g, keep_implicit = FALSE) { - repl_grob <- g - - # Replace grobs by empty grobs. - repl_grob$grobs <- replicate( - length(g), - ggplot2::zeroGrob(), - simplify = FALSE) - - # Identify the panel grobs. - if (keep_implicit) { - for (grob_id in which(grepl(pattern = "panel", x = repl_grob$layout$name))) { - # Determine the location of the panel. - position <- as.list(repl_grob$layout[grob_id, c("t", "l", "b", "r")]) - - if (position$t == position$b) { - # Identify the height of the original panel. - if (grid::is.unit(g$grobs[[grob_id]]$heights)) { - grob_height <- g$grobs[[grob_id]]$heights - } else if (grid::is.unit(g$grobs[[grob_id]]$height)) { - grob_height <- g$grobs[[grob_id]]$height - } else if (grid::is.unit(g$heights[position$t])) { - grob_height <- g$heights[position$t] - } else { - grob_height <- grid::unit(1.0, "null") - } - - if (as.numeric(grob_height) == 0) { - grob_height <- grid::unit(1.0, "null") - } - - # Set the hight of the new panel. - repl_grob$grobs[[grob_id]]$height <- grob_height - } - - if (position$l == position$r) { - # Identify the height of the original panel. - if (grid::is.unit(g$grobs[[grob_id]]$widths)) { - grob_width <- g$grobs[[grob_id]]$widths - } else if (grid::is.unit(g$grobs[[grob_id]]$width)) { - grob_width <- g$grobs[[grob_id]]$width - } else if (grid::is.unit(g$widths[position$l])) { - grob_width <- g$widths[position$l] - } else { - grob_width <- grid::unit(1.0, "null") - } - - if (as.numeric(grob_width) == 0) { - grob_width <- grid::unit(1.0, "null") - } - - # Set the hight of the new panel. - repl_grob$grobs[[grob_id]]$width <- grob_width - } - } - } - - return(repl_grob) -} - - - -.update_axis_text_grobs <- function(g, type) { - if (type == "widths") { - elements_main <- c("axis-l-main", "axis-r-main") - elements_side <- c("axis-l", "axis-r") - } else if (type == "heights") { - elements_main <- c("axis-t-main", "axis-b-main") - elements_side <- c("axis-t", "axis-b") - } - - for (grob_id in which(g$layout$name %in% elements_main)) { - # Determine the location of the panel. - position <- as.list(g$layout[grob_id, c("t", "l", "b", "r")]) - - if (type == "widths" && position$l != position$r) next - if (type == "heights" && position$b != position$t) next - - if (type == "widths" && - any(g$layout$name %in% elements_side & g$layout$l == position$l)) { - g$grobs[[grob_id]]$widths <- grid::unit(1.0, "npc") - } - - if (type == "heights" && - any(g$layout$name %in% elements_side & g$layout$t == position$t)) { - g$grobs[[grob_id]]$heights <- grid::unit(1.0, "npc") - } - } - - return(g) -} - - - -.convert_to_grob <- function(plots_or_grobs) { - # Convert to list if the input is a single grob or - unlist_grobs <- FALSE - if (grid::is.grob(plots_or_grobs) || ggplot2::is.ggplot(plots_or_grobs)) { - plots_or_grobs <- list(plots_or_grobs) +.convert_to_grob <- function(plots_or_grobs) { + # Convert to list if the input is a single grob or + unlist_grobs <- FALSE + if (grid::is.grob(plots_or_grobs) || ggplot2::is_ggplot(plots_or_grobs)) { + plots_or_grobs <- list(plots_or_grobs) # Set a flag so that we unlist the results after conversion. unlist_grobs <- TRUE @@ -2291,7 +1831,8 @@ theme_familiar <- function( # Convert to grob g <- suppressWarnings(tryCatch( ggplot2::ggplotGrob(p), - error = identity)) + error = identity + )) if (inherits(g, "error")) g <- NULL @@ -2332,11 +1873,13 @@ theme_familiar <- function( } } } + } else if (inherits(p, "ggplot")) { # Convert to grob g <- suppressWarnings(tryCatch( ggplot2::ggplotGrob(p), - error = identity)) + error = identity + )) if (inherits(g, "error")) g <- NULL @@ -2345,16 +1888,25 @@ theme_familiar <- function( g <- p } else { - warning(paste0( - "Could not convert an object of class ", class(p), " to a grob.")) + ..warning(paste0( + "Could not convert an object of class ", class(p), " to a grob." + )) g <- NULL } - + + # Set panel sizes. + if (!is.null(g)) { + # Make panels inherit heights and widths, if they don't have any. This is done + # to ensure that panels retain heights and widths, even if supporting elements + # such as the axis text and label elements are stripped on figure composition. + g <- .gtable_update_panel_aspects(g = g) + } + grobs <- c(grobs, list(g)) } - if (unlist_grobs) grobs <- grobs[[1]] - + if (unlist_grobs) grobs <- grobs[[1L]] + return(grobs) } @@ -2363,14 +1915,19 @@ theme_familiar <- function( .draw_plot <- function(plot_or_grob) { suppress_warnings( ..draw_plot(plot_or_grob), - regexp = c("containing missing values", "containing non-finite values") + regexp = c( + "containing missing values", + "containing non-finite values", + "no non-missing arguments to min", + "no non-missing arguments to max" + ) ) } ..draw_plot <- function(plot_or_grob) { - if (ggplot2::is.ggplot(plot_or_grob)) { + if (ggplot2::is_ggplot(plot_or_grob)) { show(plot_or_grob) } else if (grid::is.grob(plot_or_grob)) { @@ -2378,13 +1935,14 @@ theme_familiar <- function( grid::grid.draw(plot_or_grob) } else { - stop("Plot could not be drawn.") + ..error("Plot could not be drawn.") } return(invisible(NULL)) } + .save_plot_to_file <- function( plot_or_grob, object, @@ -2396,7 +1954,8 @@ theme_familiar <- function( additional = NULL, filename = NULL, device = "png", - ...) { + ... +) { # ... are passed to ggplot2::ggsave # Check if the plot object exists @@ -2405,8 +1964,9 @@ theme_familiar <- function( # Check if directory exists if (is.encapsulated_path(dir_path)) { file_dir <- normalizePath( - file.path(dir_path, object@name, type), - mustWork = FALSE) + file.path(dir_path, type), + mustWork = FALSE + ) } else { file_dir <- normalizePath(dir_path, mustWork = FALSE) @@ -2426,24 +1986,27 @@ theme_familiar <- function( # Test if a file extension is present. device_present <- endswith_any( filename, - suffix = paste0(".", file_extensions)) + suffix = paste0(".", file_extensions) + ) if (any(device_present)) { # Update device indicated by the filename. - device <- head(file_extensions[device_present], n = 1) + device <- head(file_extensions[device_present], n = 1L) # Remove device from filename. filename <- sub_last( pattern = paste0(".", device), replacement = "", - x = filename) + x = filename + ) } # Extend the filename if multiple plots are created from the same data. if (!is.null(split_by)) { subtype <- paste0( - as.character(sapply(split_by, function(jj, x) (x[[jj]][1]), x = x)), - collapse = "_") + as.character(sapply(split_by, function(jj, x) (x[[jj]][1L]), x = x)), + collapse = "_" + ) filename <- paste0(filename, subtype, collapse = "_") } @@ -2454,20 +2017,19 @@ theme_familiar <- function( x = x, subtype = subtype, split_by = split_by, - additional = additional) + additional = additional + ) # Combine type and subtype as the filename. filename <- paste0( type, - ifelse(is.null(subtype), "", paste0("_", subtype))) + ifelse(is.null(subtype), "", paste0("_", subtype)) + ) } for (current_device in device) { # Add in extension again. - filename <- paste0( - filename, - ".", - current_device) + filename <- paste0(filename, ".", current_device) # There may be an issue with a cold RStudio where the plotting devices have # not started. @@ -2482,15 +2044,22 @@ theme_familiar <- function( "filename" = filename, "plot" = plot_or_grob, "device" = current_device, - "path" = file_dir), - list(...)))), + "path" = file_dir + ), + list(...) + ) + ) + ), error = function(err) { logger_warning( paste0( "Could not create plot ", filename, - ". The OS may not allow long file names.")) - }) + ". The OS may not allow long file names." + ) + ) + } + ) } return(invisible(NULL)) @@ -2502,7 +2071,8 @@ theme_familiar <- function( dir_path = NULL, plot_list = NULL, export_collection = FALSE, - object = NULL) { + object = NULL +) { # Do not return plot information. if (!is.null(dir_path)) plot_list <- NULL @@ -2510,7 +2080,8 @@ theme_familiar <- function( if (export_collection) { return(list( "collection" = object, - "plot_list" = plot_list)) + "plot_list" = plot_list + )) } else { return(plot_list) @@ -2519,28 +2090,56 @@ theme_familiar <- function( -.format_plot_number <- function(x, digits = 3) { - # Find the base-10 integer of the data. - x_base <- floor(log10(abs(x))) - x_base <- x_base[is.finite(x_base)] - - # Determine the largest base. - common_base <- ifelse(length(x_base) > 0, max(x_base), 0) +.format_plot_number <- function( + x, + digits = 3L, + common_base = NULL, + min_common_base = NULL, + max_common_base = NULL, + character_out = TRUE +) { + # Determine the common base. + if (is.null(common_base)) { + common_base <- ..format_get_common_base(x) + if (is.numeric(max_common_base)) { + common_base <- ifelse(common_base > max_common_base, max_common_base, common_base) + } + if (is.numeric(min_common_base)) { + common_base <- ifelse(common_base < min_common_base, min_common_base, common_base) + } + } # Round numbers. - x <- round(x / 10^(1 + common_base - digits)) * 10^(1 + common_base - digits) + x <- as.integer(round(x / 10.0^(1.0 + common_base - digits))) * 10.0^(1.0 + common_base - digits) # Format output. - return(format(x, digits = digits, trim = TRUE)) + if (character_out) { + return(format(x, digits = digits, trim = TRUE)) + + } else { + return(x) + } +} + + + +..format_get_common_base <- function(x) { + # Find the base-10 integer of the data. + x_base <- floor(log10(abs(x))) + x_base <- x_base[is.finite(x_base)] + + return(as.integer(max(x_base))) } + .format_plot_number_nice_range <- function(input_range, x) { # Shrink input range to first and last value input_range <- c( - head(input_range, n = 1), - tail(input_range, n = 1)) + head(input_range, n = 1L), + tail(input_range, n = 1L) + ) # Find values in input_range that should be replaced. replace_index <- is.na(input_range) @@ -2556,10 +2155,11 @@ theme_familiar <- function( # Make the input range nice nice_range <- range(labeling::extended( - dmin = input_range[1], - dmax = input_range[2], - m = 5, - only.loose = TRUE)) + dmin = input_range[1L], + dmax = input_range[2L], + m = 5L, + only.loose = TRUE + )) # Update the input_range with nice values input_range[replace_index] <- nice_range[replace_index] @@ -2579,14 +2179,16 @@ theme_familiar <- function( # Determine the metric range. metric_range <- get_similarity_range( similarity_metric = similarity_metric, - as_distance = TRUE) + as_distance = TRUE + ) # Convert dendogram to a list of connectors that can later be used for # plotting. Note that we do not know where the origin should be located on the # x-axis. We will correct for that later. connectors <- .decompose_dendrogram( h = h, - parent_height = max(metric_range)) + parent_height = max(metric_range) + ) # Combine into single data.table. connectors <- data.table::rbindlist(connectors) @@ -2602,17 +2204,20 @@ theme_familiar <- function( min_leaf_pos <- min(c(connectors$x_1, connectors$x_2)) connectors[, ":="( "x_1" = x_1 - min_leaf_pos, - "x_2" = x_2 - min_leaf_pos)] + "x_2" = x_2 - min_leaf_pos + )] return(connectors) } + .decompose_dendrogram <- function( h, parent_height = Inf, parent_x = NA, - leafs_visited = 0) { + leafs_visited = 0L +) { # Decompose dendogram. The function is designed to iterate through a # dendogram, and obtain the connector between node (h) and its parent, as well # as the connectors between the node and its children h[[1]] and h[[2]], @@ -2633,7 +2238,8 @@ theme_familiar <- function( "y_1" = parent_height, "x_2" = parent_x, "y_2" = dend_attr$height, - "feature" = dend_attr$label) + "feature" = dend_attr$label + ) return(list(conn_parent_child)) } @@ -2644,11 +2250,12 @@ theme_familiar <- function( "y_1" = parent_height, "x_2" = parent_x, "y_2" = dend_attr$height, - "feature" = NA_character_) + "feature" = NA_character_ + ) # Left child node x-axis location - if (!is.null(attributes(h[[1]])$midpoint)) { - child_l_pos <- leafs_visited + attributes(h[[1]])$midpoint + if (!is.null(attributes(h[[1L]])$midpoint)) { + child_l_pos <- leafs_visited + attributes(h[[1L]])$midpoint } else { child_l_pos <- leafs_visited } @@ -2659,14 +2266,17 @@ theme_familiar <- function( "y_1" = dend_attr$height, "x_2" = child_l_pos, "y_2" = dend_attr$height, - "feature" = NA_character_) + "feature" = NA_character_ + ) # Right child node x-axis location - if (!is.null(attributes(h[[2]])$midpoint) && - !is.null(attributes(h[[1]])$members)) { - child_r_pos <- leafs_visited + attributes(h[[1]])$members + attributes(h[[2]])$midpoint - } else if (!is.null(attributes(h[[1]])$members)) { - child_r_pos <- leafs_visited + attributes(h[[1]])$members + if ( + !is.null(attributes(h[[2L]])$midpoint) && + !is.null(attributes(h[[1L]])$members) + ) { + child_r_pos <- leafs_visited + attributes(h[[1L]])$members + attributes(h[[2L]])$midpoint + } else if (!is.null(attributes(h[[1L]])$members)) { + child_r_pos <- leafs_visited + attributes(h[[1L]])$members } else { child_r_pos <- leafs_visited } @@ -2677,34 +2287,40 @@ theme_familiar <- function( "y_1" = dend_attr$height, "x_2" = child_r_pos, "y_2" = dend_attr$height, - "feature" = NA_character_) + "feature" = NA_character_ + ) # Add data.tables as list elements. connector_list <- list( - conn_parent_child, conn_child_l_leaf, conn_child_r_leaf) + conn_parent_child, + conn_child_l_leaf, + conn_child_r_leaf + ) # Left leaf - if (!is.null(h[[1]])) { + if (!is.null(h[[1L]])) { left_leaf_connectors <- .decompose_dendrogram( - h = h[[1]], + h = h[[1L]], parent_height = dend_attr$height, parent_x = child_l_pos, - leafs_visited = leafs_visited) + leafs_visited = leafs_visited + ) # Append to list connector_list <- append(connector_list, left_leaf_connectors) } # Right leaf - if (!is.null(h[[2]])) { + if (!is.null(h[[2L]])) { right_leaf_connectors <- .decompose_dendrogram( - h = h[[2]], + h = h[[2L]], parent_height = dend_attr$height, parent_x = child_r_pos, leafs_visited = ifelse( - !is.null(attributes(h[[1]])$members), - leafs_visited + attributes(h[[1]])$members, - leafs_visited) + !is.null(attributes(h[[1L]])$members), + leafs_visited + attributes(h[[1L]])$members, + leafs_visited + ) ) # Append to list @@ -2716,96 +2332,6 @@ theme_familiar <- function( -.combine_guide_grobs <- function(g, ggtheme, no_empty = TRUE) { - # Find how tables should be organised. - guide_position <- ggtheme$legend.position - - # Check if the guide position can be interpreted - if (!all(guide_position %in% c("none", "left", "right", "bottom", "top"))) { - stop(paste0( - ".combine_guide_grobs: Guide position (legend.position in the ggplot2 ", - "theme) is expect to be one of none, left, right, bottom, top.")) - } - - if (guide_position == "none") return(NULL) - - # If necessary, check that all guides are present as a gtable. - if (no_empty) { - if (!all(sapply(g, gtable::is.gtable))) { - stop(paste0( - ".combine_guide_grobs: One of the guides in the g argument ", - "is not a gtable object.")) - } - } - - # Check if all guides are missing. - if (!any(sapply(g, gtable::is.gtable))) return(NULL) - - # Keep only guides that are gtables. - g <- g[sapply(g, gtable::is.gtable)] - - # Find widths and heights - widths <- lapply(g, gtable::gtable_width) - widths <- do.call(grid::unit.c, widths) - - heights <- lapply(g, gtable::gtable_height) - heights <- do.call(grid::unit.c, heights) - - if (guide_position %in% c("left", "right", "none")) { - # Concatenate the widths. - widths <- max(widths) - - # Provide the matrix to order the guides. - order_matrix <- matrix( - data = seq_along(g), - nrow = length(g), - ncol = 1) - - # Create a grob matrix - g_matrix <- matrix( - data = g, - ncol = 1) - - } else { - # Concatenate the heights. - heights <- max(heights) - - # Provide the matrix to order the guides. - order_matrix <- matrix( - data = seq_along(g), - nrow = 1, - ncol = length(g)) - - # Create a grob matrix - g_matrix <- matrix( - data = g, - nrow = 1) - } - - # Create a gtable that combines all guide-boxes. - g <- gtable::gtable_matrix( - name = "guide-box", - grobs = g_matrix, - widths = widths, - heights = heights, - z = order_matrix, - respect = TRUE, - clip = "inherit") - - # Wrap the combined guides into a single grob. - g <- gtable::gtable_matrix( - name = "guide-box", - grobs = matrix(list(g), nrow = 1, ncol = 1), - widths = sum(widths), - heights = sum(heights), - respect = TRUE, - clip = "inherit") - - return(g) -} - - - ..set_edge_points <- function(x, range, type) { # Function used to determine edge points, such as used for ggplot2::geom_rect. if (!is.numeric(x)) { @@ -2813,7 +2339,7 @@ theme_familiar <- function( range <- c(0.5, length(x) + 0.5) } - if (length(x) > 1) { + if (length(x) > 1L) { # Make sure x is sorted ascendingly. sort_index <- sort(x, index.return = TRUE)$ix x <- x[sort_index] @@ -2836,8 +2362,8 @@ theme_familiar <- function( xmin[sort_index] <- xmin } else { - xmin <- range[1] - xmax <- range[2] + xmin <- range[1L] + xmax <- range[2L] } edge_points <- list(xmin, xmax) @@ -2847,8 +2373,16 @@ theme_familiar <- function( names(edge_points) <- c("ymin", "ymax") } else { ..error_reached_unreachable_code(paste0( - "..set_edge_points: unknown type specified: ", type)) + "..set_edge_points: unknown type specified: ", type + )) } return(edge_points) } + + + +..get_luminosity <- function(col) { + values <- as.vector(grDevices::col2rgb(col)) / 255.0 + return ((min(values) + max(values)) / 2.0) +} diff --git a/R/PredictS4Methods.R b/R/PredictS4Methods.R index ef892eed..95b74221 100644 --- a/R/PredictS4Methods.R +++ b/R/PredictS4Methods.R @@ -4,6 +4,12 @@ NULL +.is_available_prediction_type <- function(type) { + return(type %in% c(.get_available_prediction_type_arguments())) +} + + + .get_available_prediction_type_arguments <- function() { return(c( .get_available_novelty_prediction_type_arguments(), @@ -37,10 +43,9 @@ NULL #' @param type Type of prediction made. The following values are directly #' supported: #' -#' * `default`: Default prediction, i.e. value estimates for `count` and -#' `continuous` outcomes, predicted class probabilities and class for -#' `binomial` and `multinomial` and the model response for `survival` -#' outcomes. +#' * `default`: Default prediction, i.e. value estimates for `continuous` +#' outcomes, predicted class probabilities and class for `binomial` and +#' `multinomial` and the model response for `survival` outcomes. #' #' * `survival_probability`: Predicts survival probabilities at the time #' specified by `time`. Only applicable to `survival` outcomes. Some models @@ -77,9 +82,11 @@ NULL #' `stratification_method` and any threshold values that come with the model #' are ignored, and `stratification_threshold` is used instead. #' @param percentiles Currently unused. +#' @param .as_prediction_table Selects whether a data.table or prediction table +#' object should be returned. #' @param ... to be documented. #' -#' @inheritParams extract_data +#' @inheritParams .extract_data #' #' @details This method is used to predict values for instances specified by the #' `newdata` using the model or ensemble of models specified by the `object` @@ -109,7 +116,9 @@ setMethod( stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, - ...) { + .as_prediction_table = FALSE, + ... + ) { # Create ensemble. object <- as_familiar_ensemble(object = object) @@ -124,7 +133,9 @@ setMethod( stratification_threshold = stratification_threshold, stratification_method = stratification_method, percentiles = percentiles, - ...) + .as_prediction_table = .as_prediction_table, + ... + ) return(predictions) } @@ -148,8 +159,10 @@ setMethod( stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, - ...) { - if (missing(newdata)) stop("newdata must be provided.") + .as_prediction_table = FALSE, + ... + ) { + if (missing(newdata)) rlang::abort("newdata must be provided.") if (is_empty(newdata)) ..error_data_set_is_empty() # Make sure the ensemble model object is updated. @@ -159,7 +172,8 @@ setMethod( data <- as_data_object( data = newdata, object = object, - check_stringency = "external") + check_stringency = "external" + ) # Propagate to .predict predictions <- .predict( @@ -171,15 +185,29 @@ setMethod( ensemble_method = ensemble_method, stratification_threshold = stratification_threshold, stratification_method = stratification_method, - percentiles = percentiles) - - if (type %in% .get_available_prediction_type_arguments()) { - # Find non-feature columns. - non_feature_columns <- get_non_feature_columns(object) - prediction_columns <- setdiff(colnames(predictions), non_feature_columns) - - # Update the table with predictions by removing the non-feature columns. - predictions <- data.table::copy(predictions[, mget(prediction_columns)]) + percentiles = percentiles + ) + + if (is(predictions, "familiarDataElementPredictionTable")) { + # Only return prediction columns for external predict calls. + + # Complete the object by adding any missing information, such as the + # predicted class. + predictions <- .complete(predictions) + + # Ensure that values are ordered the same as in the input data. + predictions@data <- merge( + x = data@data[, mget(get_id_columns())], + y = predictions@data, + by = c(familiar:::get_id_columns()), + all.x = TRUE, + sort = FALSE + ) + + # Isolate predicted values. + if (!.as_prediction_table) { + predictions <- .as_data_table(predictions)[, mget(predictions@value_column)] + } } return(predictions) @@ -197,33 +225,23 @@ setMethod( object, newdata, type = "novelty", - ...) { - if (missing(newdata)) stop("newdata must be provided.") - if (is_empty(newdata)) ..error_data_set_is_empty() - - # Make sure the ensemble model object is updated. - object <- update_object(object = object) - - # Parse newdata to data object - data <- as_data_object( - data = newdata, - object = object, - check_stringency = "external") - - # Propagate to .predict - predictions <- .predict( + ensemble_method = "median", + .as_prediction_table = FALSE, + ... + ) { + # Create ensemble. + object <- as_familiar_ensemble(object = object) + + # Create predictions. + predictions <- predict( object = object, - data = data, - type = type) - - if (type %in% .get_available_novelty_prediction_type_arguments()) { - # Find non-feature columns. - non_feature_columns <- get_non_feature_columns(object) - prediction_columns <- setdiff(colnames(predictions), non_feature_columns) - - # Update the table with predictions by removing the non-feature columns. - predictions <- data.table::copy(predictions[, mget(prediction_columns)]) - } + newdata = newdata, + type = type, + time = time, + ensemble_method = ensemble_method, + .as_prediction_table = .as_prediction_table, + ... + ) return(predictions) } @@ -246,7 +264,9 @@ setMethod( stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, - ...) { + .as_prediction_table = FALSE, + ... + ) { # Create ensemble. object <- as_familiar_ensemble(object = object) @@ -261,8 +281,10 @@ setMethod( stratification_threshold = stratification_threshold, stratification_method = stratification_method, percentiles = percentiles, - ...) - + .as_prediction_table = .as_prediction_table, + ... + ) + return(predictions) } ) @@ -285,7 +307,9 @@ setMethod( stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, - ...) { + .as_prediction_table = FALSE, + ... + ) { # Create ensemble. object <- as_familiar_ensemble(object = object) @@ -300,8 +324,10 @@ setMethod( stratification_threshold = stratification_threshold, stratification_method = stratification_method, percentiles = percentiles, - ...) - + .as_prediction_table = .as_prediction_table, + ... + ) + return(predictions) } ) @@ -316,103 +342,68 @@ setMethod( data, allow_recalibration = TRUE, is_pre_processed = FALSE, - time = NULL, type = "default", + time = NULL, + type = "default", dir_path = NULL, ensemble_method = "median", stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, ..., - aggregate_results = TRUE) { + aggregate_results = TRUE + ) { # Predict function for a model ensemble. This will always return ensemble # information, and not details corresponding to the individual models. # Test if the models are loaded, and load the models if they are not. object <- load_models(object, dir_path = dir_path) - + # Extract predictions for each individual model - if (length(object@model_list) > 0) { - predict_list <- lapply(object@model_list, + if (length(object@model_list) > 0L) { + predict_list <- lapply( + object@model_list, .predict, data = data, allow_recalibration = allow_recalibration, is_pre_processed = is_pre_processed, time = time, type = type, + ensemble_method = ensemble_method, stratification_threshold = stratification_threshold, stratification_method = stratification_method, - ...) + percentiles = percentiles, + ... + ) } else { # Generate a placeholder table. - predict_list <- list(get_placeholder_prediction_table( - object = object, - data = data, - type = type)) + predict_list <- NULL } - # ensemble predictions ----------------------------------------------------- # Generate ensemble predictions if (all(type %in% .get_available_prediction_type_arguments())) { if (aggregate_results) { - # Determine class levels. - if (object@outcome_type %in% c("binomial", "multinomial")) { - class_levels <- get_outcome_class_levels(x = object) - } else { - class_levels <- NULL - } - - # Set grouping columns. Remove outcome columns for novelty-only - # predictions. - grouping_column <- get_non_feature_columns(object) - if (all(type %in% .get_available_novelty_prediction_type_arguments())) { - grouping_column <- setdiff(grouping_column, get_outcome_columns(object)) - } - - # Ensemble predictions are done using the - # .compute_data_element_estimates method. - data_element <- methods::new("familiarDataElementPredictionTable", - data = data.table::rbindlist(predict_list), - detail_level = "ensemble", - percentiles = percentiles, - type = type, - ensemble_method = ensemble_method, - estimation_type = ifelse(is.null(percentiles), "point", "bootstrap_confidence_interval"), - outcome_type = object@outcome_type, - class_levels = class_levels, - grouping_column = grouping_column) - + + # Merge prediction data etc. slots into the data slot. + predict_list <- lapply(predict_list, .merge_slots_into_data) + # Compute ensemble values. - data_element <- .compute_data_element_estimates( - x = data_element, - object = object) - - # Check that the data element is not empty. - if (is_empty(data_element)) { - return(get_placeholder_prediction_table( - object = object, - data = data, - type = type)) - } - - # Extract data from data element. - return(data_element[[1]]@data) + predict_list <- .compute_data_element_estimates( + x = predict_list, + object = object + ) - } else { - return(data.table::rbindlist( - predict_list, - use.names = TRUE, - fill = TRUE)) + # Extract the merged object. + predict_list <- predict_list[[1L]] } - } else { - # Return list with custom types. - return(predict_list) } + + return(predict_list) } ) -# predict (model) -------------------------------------------------------------- +# .predict (model) ------------------------------------------------------------- setMethod( ".predict", signature(object = "familiarModel"), @@ -423,11 +414,19 @@ setMethod( is_pre_processed = FALSE, time = NULL, type = "default", + ensemble_method = "median", stratification_threshold = NULL, stratification_method = NULL, - ...) { - # Suppress NOTES due to non-standard evaluation in data.table - .NATURAL <- NULL + percentiles = NULL, + ... + ) { + + if (length(type) != 1L) { + ..error_reached_unreachable_code(paste0( + "Only one type of prediction is expected as argument to .predict. ", + "Found: ", paste_s(type) + )) + } # Prepare input data data <- process_input_data( @@ -435,123 +434,109 @@ setMethod( data = data, is_pre_processed = is_pre_processed, stop_at = "clustering", - keep_novelty = "novelty" %in% type) - - # Set empty prediction table that can be updated - prediction_table <- NULL - + keep_novelty = "novelty" %in% type + ) + # user specified type ------------------------------------------------------ - if (any(!type %in% .get_available_prediction_type_arguments())) { + if (!all(type %in% .get_available_prediction_type_arguments())) { # Select the first non-standard type. - type <- setdiff(type, .get_available_prediction_type_arguments())[1] + type <- setdiff(type, .get_available_prediction_type_arguments())[1L] # Select only features used by the model. data <- select_features( data = data, features = features_after_clustering( features = object@model_features, - feature_info_list = object@feature_info)) - + feature_info_list = object@feature_info + ) + ) + # Call predict from ..predict method with the given type and the # unspecified extra arguments in ... . - prediction_element <- ..predict( + return(..predict( object = object, data = data, time = time, type = type, - ...) - - return(prediction_element) + ... + )) } # novelty ------------------------------------------------------------------ - if ("novelty" %in% type) { + if (type == "novelty") { # Predict instance novelty. - prediction_table <- .predict_novelty( + return(.predict_novelty( object = object, - data = data) - - # Keep only model features in data for the remaining analysis. - data <- select_features( - data = data, - features = features_after_clustering( - features = object@model_features, - feature_info_list = object@feature_info)) + data = data + )) } - - # default response --------------------------------------------------------- - if ("default" %in% type) { + + # Keep only model features in data for the remaining predictions. + data <- select_features( + data = data, + features = features_after_clustering( + features = object@model_features, + feature_info_list = object@feature_info + ) + ) + + if (type == "default") { + # default ---------------------------------------------------------------- + # Predict using the model and the standard type. - temp_prediction_table <- ..predict( + prediction_table <- ..predict( object = object, data = data, - time = time) - - # Recalibrate the results. + type = type, + time = time + ) + + # Recalibrate the default predictions. if (allow_recalibration) { - temp_prediction_table <- .apply_recalibration( + prediction_table <- .apply_recalibration( object = object, - predictions = temp_prediction_table) - } - - # Add new columns to existing prediction table, if necessary. - if (is.null(prediction_table)) { - prediction_table <- temp_prediction_table - } else if (!is_empty(temp_prediction_table)) { - prediction_table <- prediction_table[unique(temp_prediction_table), on = .NATURAL] + prediction_table = prediction_table, + data = data + ) } - } - - # survival probability ----------------------------------------------------- - if ("survival_probability" %in% type) { - # Prediction survival probabilities, - temp_prediction_table <- ..predict_survival_probability( + + } else if (type == "survival_probability") { + # survival probability --------------------------------------------------- + + # Predict using the model and the standard type. + prediction_table <- ..predict( object = object, data = data, - time = time) - - # Add new columns to existing prediction table, if necessary. - if (is.null(prediction_table)) { - prediction_table <- temp_prediction_table - } else if (!is_empty(temp_prediction_table)) { - # Merge with the prediction table - prediction_table <- prediction_table[unique(temp_prediction_table), on = .NATURAL] - } - } - - # risk stratification ------------------------------------------------------ - if ("risk_stratification" %in% type) { + type = type, + time = time + ) + + } else if (type == "risk_stratification") { + # risk stratification ---------------------------------------------------- + # Prediction survival probabilities, - temp_prediction_table <- .predict_risk_stratification( + prediction_table <- .predict_risk_stratification( object = object, data = data, time = time, stratification_threshold = stratification_threshold, stratification_method = stratification_method, - ...) - - # Add new columns to existing prediction table, if necessary. - if (is.null(prediction_table)) { - prediction_table <- temp_prediction_table - } else if (!is_empty(temp_prediction_table)) { - prediction_table <- prediction_table[unique(temp_prediction_table), on = .NATURAL] - } + ... + ) + + } else { + ..error_reached_unreachable_code(paste0( + "Type of prediction was not recognised: ", type + )) } - - if (!is_empty(prediction_table)) { - # Order output columns. - ordered_columns <- intersect( - colnames(get_placeholder_prediction_table( - object = object, - data = data, - type = type)), - colnames(prediction_table)) - - data.table::setcolorder( - x = prediction_table, - neworder = ordered_columns) + + if (is(prediction_table, "familiarDataElementPredictionTable")) { + prediction_table@detail_level <- "ensemble" + prediction_table@percentiles <- percentiles + prediction_table@ensemble_method <- ensemble_method + prediction_table@estimation_type <- ifelse(is.null(percentiles), "point", "bootstrap_confidence_interval") } - + return(prediction_table) } ) @@ -567,29 +552,22 @@ setMethod( data, type = "novelty", is_pre_processed = FALSE, - ...) { + ... + ) { # Prepare input data. data <- process_input_data( object = object, data = data, is_pre_processed = is_pre_processed, - stop_at = "clustering") - + stop_at = "clustering" + ) + # Predict novelty. prediction_table <- ..predict( object = object, data = data, - type = type) - - if (!is_empty(prediction_table)) { - # Order output columns. - data.table::setcolorder( - x = prediction_table, - neworder = colnames(get_placeholder_prediction_table( - object = object, - data = data, - type = type))) - } + type = type + ) return(prediction_table) } @@ -608,10 +586,40 @@ setMethod( return(do.call( .predict, args = c( - list( - "object" = object, - "data" = data), - list(...)))) + list( + "object" = object, + "data" = data + ), + list(...) + ) + )) + } +) + + + +# .predict (list) -------------------------------------------------------------- +setMethod( + ".predict", + signature(object = "list"), + function(object, data, ...) { + if (all(sapply(object, is, class2 = "familiarModel"))) { + object <- as_familiar_ensemble(object = object) + + return(do.call( + .predict, + args = c( + list( + "object" = object, + "data" = data + ), + list(...) + ) + )) + + } else { + ..error_reached_unreachable_code(".predict for list expects a list of familiarModel objects") + } } ) @@ -626,12 +634,14 @@ setMethod( data, type = "novelty", is_pre_processed = FALSE, - ...) { + ... + ) { return(.predict( object = object@novelty_detector, data = data, type = type, - is_pre_processed = is_pre_processed)) + is_pre_processed = is_pre_processed + )) } ) @@ -649,7 +659,9 @@ setMethod( .predict_novelty, args = c( list("object" = object), - list(...)))) + list(...) + ) + )) } ) @@ -665,10 +677,11 @@ setMethod( time, stratification_threshold = NULL, stratification_method = NULL, - ...) { + ... + ) { # Only assess stratification for survival outcomes. if (!object@outcome_type %in% c("survival")) return(NULL) - + # Allow for settings the stratification threshold explicitly. if (is.null(stratification_threshold)) { if (!is.null(stratification_method)) { @@ -676,53 +689,45 @@ setMethod( # First check if the method exists. if (!stratification_method %in% object@km_info$stratification_method) { - stop(paste0( + ..error(paste0( "Data for stratification method ", stratification_method, - " was not found with the object.")) + " was not found with the object." + )) } # Select stratification threshold for the given method. stratification_threshold <- object@km_info$parameters[[stratification_method]]$cutoff } else { # Select stratification threshold for the first method. - stratification_threshold <- object@km_info$parameters[[1]]$cutoff + stratification_threshold <- object@km_info$parameters[[1L]]$cutoff } } - # Generate an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "risk_stratification") - # Check again if a stratification threshold is now set. - if (is.null(stratification_threshold)) return(prediction_table) + if (is.null(stratification_threshold)) return(NULL) # Predict for the instances in data. predictions <- .predict( object = object, data = data, - time = time) - - # Check for valid predictions, - if (is_empty(predictions)) { - return(prediction_table) - } - if (!any_predictions_valid( - prediction_table = predictions, - outcome_type = object@outcome_type)) { - return(prediction_table) - } + time = time + ) # Find risk groups for each instance. assigned_risk_group <- .apply_risk_threshold( - object = object, - predicted_values = predictions$predicted_outcome, - cutoff = stratification_threshold) - - # Set to prediction table. - prediction_table[, "risk_group" := assigned_risk_group] - + x = predictions, + cutoff = stratification_threshold + ) + + # Convert to prediction table + prediction_table <- as_prediction_table( + x = assigned_risk_group, + type = "risk_stratification", + data = data, + time = time, + model_object = object + ) + return(prediction_table) } ) @@ -738,17 +743,9 @@ setMethod( time, stratification_threshold = NULL, stratification_method = NULL, - ...) { - # Only assess stratification for survival outcomes. - if (!object@outcome_type %in% c("survival")) return(NULL) - - # Generate an empty prediction table. - prediction_table <- get_placeholder_prediction_table( - object = object, - data = data, - type = "risk_stratification") - - return(prediction_table) + ... + ) { + return(NULL) } ) @@ -766,7 +763,9 @@ setMethod( .predict_risk_stratification, args = c( list("object" = object), - list(...)))) + list(...) + ) + )) } ) @@ -775,198 +774,3 @@ setMethod( .get_available_ensemble_prediction_methods <- function() { return(c("median", "mean")) } - - - -all_predictions_valid <- function( - prediction_table, - outcome_type = NULL, - type = "default") { - # Return results when checking with the "all" function. - return(.predictions_valid( - prediction_table = prediction_table, - outcome_type = outcome_type, - type = type, - check_type = "all")) -} - - - -any_predictions_valid <- function( - prediction_table, - outcome_type = NULL, - type = "default") { - # Return results when checking with the "any" function. - return(.predictions_valid( - prediction_table = prediction_table, - outcome_type = outcome_type, - type = type, - check_type = "any")) -} - - - -.predictions_valid <- function( - prediction_table, - outcome_type, - type, - check_type) { - # Set the check function. - check_fun <- switch( - check_type, - "all" = all, - "any" = any) - - if (is_empty(prediction_table)) return(FALSE) - - if (type %in% c("default", "survival_probability", "risk_stratification")) { - if (is.null(outcome_type)) { - ..error_reached_unreachable_code( - "any_predictions_valid: outcome_type was not provided.") - } - - if (outcome_type %in% c("continuous", "count")) { - return(check_fun(is.finite(prediction_table$predicted_outcome))) - - } else if (outcome_type %in% c("survival", "competing_risk")) { - if ("predicted_outcome" %in% colnames(prediction_table)) { - return(check_fun(is.finite(prediction_table$predicted_outcome))) - } else if ("survival_probability" %in% colnames(prediction_table)) { - return(check_fun(is.finite(prediction_table$survival_probability))) - } else if ("risk_group" %in% colnames(prediction_table)) { - return(check_fun(!is.na(prediction_table$risk_group))) - } else { - return(FALSE) - } - - } else if (outcome_type %in% c("binomial", "multinomial")) { - return(check_fun(!is.na(prediction_table$predicted_class))) - - } else { - ..error_no_known_outcome_type(outcome_type) - } - - } else if (type %in% c("novelty")) { - return(check_fun(is.finite(prediction_table$novelty))) - - } else { - ..error_reached_unreachable_code( - "any_predictions_valid: unknown type encountered") - } -} - - - - -remove_nonvalid_predictions <- function(prediction_table, outcome_type) { - # Suppress NOTES due to non-standard evaluation in data.table - predicted_outcome <- predicted_class <- survival_probability <- risk_group <- NULL - - if (is_empty(prediction_table)) return(prediction_table) - - # Check predicted outcome columns. - if (outcome_type %in% c("survival", "competing_risk")) { - if ("predicted_outcome" %in% colnames(prediction_table)) { - prediction_table <- prediction_table[is.finite(predicted_outcome), ] - } - if ("survival_probability" %in% colnames(prediction_table)) { - prediction_table <- prediction_table[is.finite(survival_probability), ] - } - if ("risk_group" %in% colnames(prediction_table)) { - prediction_table <- prediction_table[!is.na(risk_group), ] - } - - } else if (outcome_type %in% c("continuous", "count")) { - prediction_table <- prediction_table[is.finite(predicted_outcome), ] - - } else if (outcome_type %in% c("binomial", "multinomial")) { - # predicted_class may be absent (e.g. for ICE-tables), so we need check if - # it exists. - if ("predicted_class" %in% colnames(prediction_table)) { - # Mask based on predicted_class. - prediction_table <- prediction_table[!is.na(predicted_class), ] - - } else { - # Mask probability columns. - class_probability_columns <- grepl( - pattern = "predicted_class_probability_", - x = colnames(prediction_table)) - - # Get the names of the probability columns. - class_probability_columns <- colnames(prediction_table)[class_probability_columns] - - # Create mask for valid instances. - instance_mask <- rep.int(TRUE, nrow(prediction_table)) - for (ii in class_probability_columns) { - instance_mask <- instance_mask & is.finite(prediction_table[[ii]]) - } - - # Apply mask to the prediction table. - prediction_table <- prediction_table[instance_mask, ] - } - - } else { - ..error_no_known_outcome_type(outcome_type) - } - - return(prediction_table) -} - - - -# remove_missing_outcomes (data.table) ----------------------------------------- -setMethod( - "remove_missing_outcomes", - signature(data = "data.table"), - function(data, outcome_type) { - # Suppress NOTES due to non-standard evaluation in data.table - outcome <- outcome_time <- outcome_event <- NULL - - if (is_empty(data)) return(data) - - # Check predicted outcome columns. - if (outcome_type %in% c("survival", "competing_risk")) { - data <- data[is.finite(outcome_time) & !is.na(outcome_event), ] - } else if (outcome_type %in% c("count", "continuous")) { - data <- data[is.finite(outcome), ] - } else if (outcome_type %in% c("binomial", "multinomial")) { - data <- data[!is.na(outcome), ] - } else { - ..error_no_known_outcome_type(outcome_type) - } - - return(data) - } -) - - -# remove_missing_outcomes (dataObject) ----------------------------------------- -setMethod( - "remove_missing_outcomes", - signature(data = "dataObject"), - function(data, outcome_type = NULL) { - if (is_empty(data)) return(data) - - if (is.null(outcome_type)) outcome_type <- data@outcome_type - - # Update data attribute - data@data <- remove_missing_outcomes( - data = data@data, - outcome_type = outcome_type) - - return(data) - } -) - - -# remove_missing_outcomes (ANY) ------------------------------------------------ -setMethod( - "remove_missing_outcomes", - signature(data = "ANY"), - function(data, outcome_type = NULL) { - if (is_empty(data)) return(data) - - ..error_reached_unreachable_code( - "remove_missing_outcomes,ANY: data does not have a known object class, nor is empty.") - } -) diff --git a/R/PredictionTable.R b/R/PredictionTable.R new file mode 100644 index 00000000..53ce207e --- /dev/null +++ b/R/PredictionTable.R @@ -0,0 +1,2209 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +#' @include FamiliarDataComputationPredictionData.R + +# predictionTableRegression ---------------------------------------------------- +setClass( + "predictionTableRegression", + contains = "familiarDataElementPredictionTable", + slots = list( + "observed_value_range" = "numeric" + ), + prototype = list( + "observed_value_range" = NA_real_ + ) +) + +# predictionTableSurvival ------------------------------------------------------ +setClass( + "predictionTableSurvival", + contains = "familiarDataElementPredictionTable", + slots = list( + "censored" = "character", + "event" = "character", + "time" = "numeric" + ), + prototype = list( + "censored" = NA_character_, + "event" = NA_character_, + "time" = Inf + ) +) + +# predictionTableSurvivalHazardRatio ------------------------------------------- +setClass( + "predictionTableSurvivalHazardRatio", + contains = "predictionTableSurvival" +) + +# predictionTableSurvivalCumulativeHazard -------------------------------------- +setClass( + "predictionTableSurvivalCumulativeHazard", + contains = "predictionTableSurvival" +) + +# predictionTableSurvivalTime -------------------------------------------------- +setClass( + "predictionTableSurvivalTime", + contains = "predictionTableSurvival" +) + +# predictionTableSurvivalProbability ------------------------------------------- +setClass( + "predictionTableSurvivalProbability", + contains = "predictionTableSurvival" +) + +# predictionTableGrouping ------------------------------------------------------ +setClass( + "predictionTableGrouping", + contains = "familiarDataElementPredictionTable", + slots = list( + "groups" = "character" + ), + prototype = list( + "groups" = NA_character_ + ) +) + +# predictionTableRiskGroups ---------------------------------------------------- +setClass( + "predictionTableRiskGroups", + contains = "predictionTableGrouping" +) + +# predictionTableClassification ------------------------------------------------ +setClass( + "predictionTableClassification", + contains = "familiarDataElementPredictionTable", + slots = list( + "classes" = "character", + "thresholds" = "ANY" + ), + prototype = list( + "classes" = NA_character_, + "thresholds" = NULL + ) +) + +# predictionTableNovelty ------------------------------------------------------- +setClass( + "predictionTableNovelty", + contains = "familiarDataElementPredictionTable" +) + + +#' Convert to prediction table object +#' +#' Creates a prediction table object from input data. +#' +#' @param x Values predicted using a learner. For all but `classification` +#' problems, predicted values should be a single vector of values in any +#' format that results in a single-column `data.table` using +#' `data.table::as.data.table`. For `classification` problems, predicted +#' values are probabilities for each class. Here, it is recommended to ensure +#' probabilities can be mapped to their respective class, e.g. using a named +#' list. +#' @param type The type of prediction table that should be created. The +#' following types are available: +#' +#' * `regression`: The predicted values are values for a regression. +#' +#' * `classification`: The predicted values are probabilities for specific +#' classes. +#' +#' * `hazard_ratio`: The predicted values are hazard ratios. +#' +#' * `cumulative_hazard`: The predicted values are cumulative hazards at +#' time `time`. +#' +#' * `expected_survival_time`: The predicted values are expected survival times. +#' +#' * `survival_probability`: The predicted values are survival probabilities +#' at time `time`. +#' +#' @param y Known outcome value corresponding to each entry in `x`. For +#' survival-related outcomes, two sets of values are expected, corresponding +#' to the observed time and event status, respectively. Alternatively, a +#' `survival::Surv` object can be provided. +#' +#' @param batch_id (*optional*) Array of batch or cohort identifiers. +#' +#' In familiar any row of data is organised by four identifiers: +#' +#' * The batch identifier `batch_id`: This denotes the group to which a +#' set of samples belongs, e.g. patients from a single study, samples measured +#' in a batch, etc. The batch identifier is used for batch normalisation, as +#' well as selection of development and validation datasets. +#' +#' * The sample identifier `sample_id`: This denotes the sample level, +#' e.g. data from a single individual. Subsets of data, e.g. bootstraps or +#' cross-validation folds, are created at this level. +#' +#' * The series identifier `series_id`: Indicates measurements on a +#' single sample that may not share the same outcome value, e.g. a time +#' series, or the number of cells in a view. +#' +#' * The repetition identifier `repetition_id`: Indicates repeated measurements +#' in a single series where any feature values may differ, but the outcome +#' does not. Repetition identifiers are always implicitly set when multiple +#' entries for the same series of the same sample in the same batch that share +#' the same outcome are encountered. +#' +#' @param sample_id (*optional*) Array of sample or subject identifiers. See +#' `batch_id` above for more details. +#' +#' If unset, every row will be identified as a single sample. +#' @param series_id (*optional*) Array of series identifiers, which distinguish +#' between measurements that are part of a series for a single sample. See +#' `batch_id` above for more details. +#' +#' @param repetition_id (*optional*) Array of repetition identifiers, which +#' distinguishes between repeated measurements within a single series. See +#' `batch_id` above for more details. +#' +#' @param time Time point at which the predicted values are generated e.g. the +#' cumulative risks generated by random forest. +#' +#' This parameter is only relevant for `survival` outcomes. +#' @param value_range Range of observed, **not predicted**, values. +#' +#' This parameter is only relevant for `continuous` outcomes. +#' +#' @param learner The type of learner that generated the predictions. +#' @param vimp_method The type of variable importance method for identifying the +#' features included by the learner that generated the predictions. +#' @param model_object A familiarModel or familiarEnsemble that can be used (and +#' is used internally) for setting several of the other arguments of this +#' function. +#' @param data A familiar dataObject object that can be used (and is used +#' internally) for setting many of the other arguments of this function. +#' +#' @inheritParams .parse_experiment_settings +#' +#' @return A prediction table object. +#' @export +as_prediction_table <- function( + x, + type, + y = waiver(), + batch_id = waiver(), + sample_id = waiver(), + series_id = waiver(), + repetition_id = waiver(), + time = waiver(), + class_levels = waiver(), + value_range = waiver(), + event_indicator = waiver(), + censoring_indicator = waiver(), + learner = waiver(), + vimp_method = waiver(), + model_object = NULL, + data = NULL +) { + + # Create skeleton of object based on the provided type. + if (type == "regression") { + object <- methods::new("predictionTableRegression") + + } else if (type == "classification") { + object <- methods::new("predictionTableClassification") + + } else if (type == "survival") { + object <- methods::new("predictionTableSurvival") + + } else if (type == "hazard_ratio") { + object <- methods::new("predictionTableSurvivalHazardRatio") + + } else if (type == "cumulative_hazard") { + object <- methods::new("predictionTableSurvivalCumulativeHazard") + + } else if (type == "expected_survival_time") { + object <- methods::new("predictionTableSurvivalTime") + + } else if (type == "survival_probability") { + object <- methods::new("predictionTableSurvivalProbability") + + } else if (type == "grouping") { + object <- methods::new("predictionTableGrouping") + + } else if (type == "risk_stratification") { + object <- methods::new("predictionTableRiskGroups") + + } else if (type == "novelty") { + object <- methods::new("predictionTableNovelty") + + } else { + ..error( + paste0( + "The type argument was not recognized: ", type, + "One of regression, classification, hazard_ratio, cumulative_hazard, ", + "expected_survival_time, survival_probability, grouping, + risk_stratification or novelty is expected." + ) + ) + } + + # Infer outcome_type based on known information. + if (is(data, "dataObject") || is(data, "familiarDataElementPredictionTable")) { + object@outcome_type <- data@outcome_type + } else if (is(model_object, "familiarModelUnion")) { + object@outcome_type <- model_object@outcome_type + } + + # Set learner. + if (!is.waive(learner)) { + object@learner <- learner + } else if (is(model_object, "familiarModelUnion")) { + object@learner <- model_object@learner + } + + # Set vimp method. + if (!is.waive(vimp_method)) { + object@vimp_method <- vimp_method + } else if (is(model_object, "familiarModelUnion")) { + object@vimp_method <- model_object@vimp_method + } + + if (is_empty(x)) { + return(object) + } + + # Use x to set prediction_data attribute. + object@prediction_data <- data.table::as.data.table(x) + if (is_empty(object@prediction_data)) return(object) + + # Use y to set reference_data attribute. + if (!is.waive(y) && !is.null(y)) { + if (survival::is.Surv(y)) { + object@reference_data <- data.table::data.table( + "outcome_time" = y[, 1L], + "outcome_event" = y[, 2L] + ) + } else { + object@reference_data <- data.table::as.data.table(y) + } + + } else if (is(data, "dataObject")) { + outcome_columns <- .get_outcome_columns(data@outcome_type) + if (length(outcome_columns) > 0L) { + y <- data@data[, mget(outcome_columns)] + object@reference_data <- data.table::copy(y) + } + + } else if (is(data, "familiarDataElementPredictionTable")) { + outcome_columns <- .get_outcome_columns(data@outcome_type) + if (.is_merged_prediction_table(data) && length(outcome_columns) > 0L) { + y <- data@data[, mget(outcome_columns)] + object@reference_data <- data.table::copy(y) + + } else if (length(outcome_columns) > 0L) { + y <- data@reference_data[, mget(outcome_columns)] + object@reference_data <- data.table::copy(y) + } + } + + # Use batch_id, sample_id, series_id and repetition_id to set identifier_data + # attribute. + if (is.waive(batch_id) && is.waive(sample_id) && is.waive(series_id) && is.waive(repetition_id)) { + if (is(data, "dataObject")) { + data_slot <- "data" + } else if (is(data, "familiarDataElementPredictionTable")) { + data_slot <- ifelse(.is_merged_prediction_table(data), "data", "identifier_data") + } else { + data_slot <- NULL + } + + if (!is.null(data_slot)) { + batch_id <- methods::slot(data, data_slot)[[get_id_columns(single_column = "batch")]] + sample_id <- methods::slot(data, data_slot)[[get_id_columns(single_column = "sample")]] + series_id <- methods::slot(data, data_slot)[[get_id_columns(single_column = "series")]] + repetition_id <- methods::slot(data, data_slot)[[get_id_columns(single_column = "repetition")]] + } + } + + if (is.waive(batch_id)) { + batch_id <- rep_len("generic_batch", nrow(object@prediction_data)) + } + + if (is.waive(sample_id)) { + sample_id <- paste0("generic_sample_", seq_len(nrow(object@prediction_data))) + } + + if (is.waive(series_id)) { + series_id <- rep_len("1", nrow(object@prediction_data)) + } + + if (is.waive(repetition_id)) { + repetition_id <- rep_len("1", nrow(object@prediction_data)) + } + + object@identifier_data <- data.table::data.table( + "V1" = batch_id, "V2" = sample_id, "V3" = series_id, "V4" = repetition_id + ) + + data.table::setnames(object@identifier_data, new = get_id_columns()) + + # Use time to set time attribute of prediction tables that have it. + if (methods::.hasSlot(object, "time") && !is.waive(time)) { + sapply( + time, + .check_number_in_valid_range, + var_name = "time", + range = c(0.0, Inf), + closed = c(TRUE, FALSE) + ) + + object <- add_data_element_identifier( + x = object, + evaluation_time = time + )[[1L]] + + object@time <- time + } + + # Use classes to set classes attribute of prediction tables that have it. + if (methods::.hasSlot(object, "classes")) { + if (is.unset(class_levels) && is(data, "familiarDataElementPredictionTable")) { + if (methods::.hasSlot(data, "classes")) { + class_levels <- data@classes + } + } + if (is.unset(class_levels) && is(data, "dataObject")) { + class_levels <- get_outcome_class_levels(data) + } + if (is.unset(class_levels) && is(model_object, "familiarModelUnion")) { + class_levels <- get_outcome_class_levels(model_object) + } + if (is.unset(class_levels) && !is_empty(object@reference_data)) { + if (is.factor(object@reference_data[[1L]])) { + class_levels <- levels(object@reference_data[[1L]]) + } else { + class_levels <- unique_na(object@reference_data[[1L]]) + } + } + if (is.unset(class_levels) && !is_empty(names(x))) { + class_levels <- names(x) + } + if (is.unset(class_levels)) { + class_levels <- paste0("class_", seq_len(ncol(object@prediction_data))) + } + + object@classes <- class_levels + } + + # Use value range to set observed_value_range of prediction tables that have + # it. + if (methods::.hasSlot(object, "observed_value_range")) { + if (!is.unset(value_range)) { + sapply( + value_range, + .check_number_in_valid_range, + var_name = "value_range", + range = c(-Inf, Inf) + ) + + .check_argument_length( + x = value_range, + var_name = "value_range", + min = 2L, + max = 2L + ) + } + + if (is.unset(value_range) && is(data, "familiarDataElementPredictionTable")) { + if (methods::.hasSlot(data, "observed_value_range")) { + value_range <- data@observed_value_range + } + } + if ((is.unset(value_range) || !all(is.finite(value_range))) && is(data, "dataObject")) { + if (is(data@outcome_info, "outcomeInfo")) { + value_range <- suppressWarnings(range( + data@outcome_info@distribution$fivenum, + na.rm = TRUE, + finite = TRUE + )) + } + } + if ((is.unset(value_range) || !all(is.finite(value_range))) && is(model_object, "familiarModelUnion")) { + if (is(model_object@outcome_info, "outcomeInfo")) { + value_range <- suppressWarnings(range( + model_object@outcome_info@distribution$fivenum, + na.rm = TRUE, + finite = TRUE + )) + } + } + if ((is.unset(value_range) || !all(is.finite(value_range))) && !is_empty(object@reference_data)) { + value_range <- suppressWarnings(range( + object@reference_data[[1L]], + na.rm = TRUE, + finite = TRUE + )) + } + if (is.unset(value_range) || !all(is.finite(value_range))) { + value_range <- suppressWarnings(range( + object@prediction_data[[1L]], + na.rm = TRUE, + finite = TRUE + )) + } + + object@observed_value_range <- value_range + } + + + # Use censored_label to set censored attribute of prediction tables that have + # it. + if (methods::.hasSlot(object, "censored")) { + if (is.unset(censoring_indicator) && is(data, "familiarDataElementPredictionTable")) { + if (methods::.hasSlot(data, "censored")) { + censoring_indicator <- data@censored + } + } + if (is.unset(censoring_indicator) && is(data, "dataObject")) { + if (is(data@outcome_info, "outcomeInfo")) { + censoring_indicator <- data@outcome_info@censored + } + } + if (is.unset(censoring_indicator) && is(model_object, "familiarModelUnion")) { + if (is(model_object@outcome_info, "outcomeInfo")) { + censoring_indicator <- model_object@outcome_info@censored + } + } + if (is.unset(censoring_indicator)) { + censoring_indicator <- .get_available_default_censoring_indicator() + } + + object@censored <- censoring_indicator + } + + # Use event_label to set event attribute of prediction tables that have it. + if (methods::.hasSlot(object, "event")) { + if (is.unset(event_indicator) && is(data, "familiarDataElementPredictionTable")) { + if (methods::.hasSlot(data, "censored")) { + event_indicator <- data@event + } + } + if (is.unset(event_indicator) && is(data, "dataObject")) { + if (is(data@outcome_info, "outcomeInfo")) { + event_indicator <- data@outcome_info@event + } + } + if (is.unset(event_indicator) && is(model_object, "familiarModelUnion")) { + if (is(model_object@outcome_info, "outcomeInfo")) { + event_indicator <- model_object@outcome_info@event + } + } + if (is.unset(event_indicator)) { + event_indicator <- .get_available_default_event_indicator() + } + + object@event <- event_indicator + } + + # Check the prediction table object for consistency. + object <- .complete_new_prediction_table(object) + + return(object) +} + + +# .complete_new_prediction_table (generic) ------------------------------------- + +setGeneric( + ".complete_new_prediction_table", + function(object, ...) standardGeneric(".complete_new_prediction_table") +) + +# .complete_new_prediction_table (general) ------------------------------------- +setMethod( + ".complete_new_prediction_table", + signature(object = "familiarDataElementPredictionTable"), + function(object) { + # Check that prediction_data, identifier_data and reference_data have the + # same number of instances. + if (is_empty(object)) return(object) + + n_instances <- nrow(object@prediction_data) + + if (!is_empty(object@reference_data)) { + if (n_instances != nrow(object@reference_data)) { + ..error( + paste0( + "The number of instances of predicted values (", + n_instances, ") do not match the number of reference values (", + nrow(object@reference_data), ")." + ), + error_class = "prediction_table_error" + ) + } + } + + if (!is_empty(object@identifier_data)) { + if (n_instances != nrow(object@identifier_data)) { + ..error( + paste0( + "The number of instances of predicted values (", + n_instances, ") do not match the number of instances determined ", + "from identifier data (", nrow(object@reference_data), ")." + ), + error_class = "prediction_table_error" + ) + } + } + + return(object) + } +) + +# .complete_new_prediction_table (regression) ---------------------------------- +setMethod( + ".complete_new_prediction_table", + signature(object = "predictionTableRegression"), + function(object) { + + # Pass to superclass method first. + object <- callNextMethod() + + if (is_empty(object)) return(object) + + # Check outcome type + if (is.null(object@outcome_type)) object@outcome_type <- "continuous" + if (object@outcome_type != "continuous") { + ..error_reached_unreachable_code( + "The outcome type of predictionTableRegression objects should be \"continuous\"." + ) + } + + # Check that one set of prediction data are provided. + if (ncol(object@prediction_data) != 1L) { + ..error( + paste0( + "Only one set of predicted values was expected, but (", + ncol(object@prediction_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Update column name of prediction_data to the standard value. + data.table::setnames(object@prediction_data, new = "predicted_outcome") + + # Check that prediction data are numeric. + if (!is.numeric(object@prediction_data$predicted_outcome)) { + ..error( + paste0( + "Predicted values are expected to be numeric, but data with class ", + paste_s(class(object@prediction_data$predicted_outcome)), + " were encountered." + ), + error_class = "prediction_table_error" + ) + } + + if (!is_empty(object@reference_data)) { + # Check that one set of reference data are provided. + if (ncol(object@reference_data) != 1L) { + ..error( + paste0( + "Only one set of reference values was expected, but (", + ncol(object@reference_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Update column name of reference_data to the standard value. + outcome_column <- get_outcome_columns(object@outcome_type) + data.table::setnames(object@reference_data, new = outcome_column) + + # Check that reference data are numeric. + if (!is.numeric(object@reference_data[[outcome_column]])) { + ..error( + paste0( + "Reference values are expected to be numeric, but data with class ", + paste_s(class(object@reference_data[[outcome_column]])), " were encountered." + ), + error_class = "prediction_table_error" + ) + } + } + + return(object) + } +) + + +# .complete_new_prediction_table (classification) ------------------------------ +setMethod( + ".complete_new_prediction_table", + signature(object = "predictionTableClassification"), + function(object) { + + ..in_valid_range <- function(x) { + return(all(x >= 0.0, na.rm = TRUE) && all(x <= 1.0, na.rm = TRUE)) + } + + ..test_columns_numeric <- function(object) { + if (!all(sapply(object@prediction_data, is.numeric))) { + ..error( + paste0( + "Predicted values are expected to be numeric, but data with classes ", + paste_s(unique(sapply(object@prediction_data, class))), + " were encountered." + ), + error_class = "prediction_table_error" + ) + } + } + + ..test_columns_probabilities <- function(object) { + if (!all(sapply(object@prediction_data, ..in_valid_range))) { + ..error( + paste0( + "Predicted values are expected to be probabilities between 0.0 and 1.0, ", + "but values outside this range were found." + ), + error_class = "prediction_table_error" + ) + } + } + + # Pass to superclass method first. + object <- callNextMethod() + + if (is_empty(object)) return(object) + + # Check outcome type + if (is.null(object@outcome_type)) { + object@outcome_type <- ifelse(length(object@classes) == 2L, "binomial", "multinomial") + } + if (!object@outcome_type %in% c("binomial", "multinomial")) { + ..error_reached_unreachable_code(paste0( + "The outcome type of predictionTableClassification objects should be + \"binomial\ or \"multinomial\"." + )) + } + + if (object@outcome_type == "binomial") { + # Under binomial, either 1 or 2 columns can be specified, both of which + # should contain numeric values between 0.0 and 1.0. + + # Check that one or two sets of prediction data are provided. + if (ncol(object@prediction_data) > 2L) { + ..error( + paste0( + "For binomial (two-class) endpoints, either one or two sets of ", + "predicted values are expected. However (", + ncol(object@prediction_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Check that all columns are numeric. + ..test_columns_numeric(object) + + # Check that all columns contain values between 0.0 and 1.0. + ..test_columns_probabilities(object) + + if (length(object@classes) != 2L) { + ..error( + paste0( + "Two classes are expected for binomial (two-class) but ", + length(object@classes), " were found: ", + paste_s(object@classes) + ), + error_class = "prediction_table_error" + ) + } + + # Insert complementary column. First we determine the name of the + # associated class. + if (ncol(object@prediction_data) == 1L) { + if (all(colnames(object@prediction_data) %in% object@classes)) { + positive_class <- colnames(object@prediction_data) + + } else { + positive_class <- tail(object@classes, n = 1L) + + ..warning( + paste0( + "The positive class cannot be directly inferred from names of the ", + "provided prediction data, and is assumed to be ", positive_class, "." + ), + warning_class = "prediction_table_warning" + ) + + data.table::setnames(object@prediction_data, new = positive_class) + } + + negative_class <- setdiff(object@classes, positive_class) + object@prediction_data[, (negative_class) := 1.0 - get(positive_class)] + } + + # Update column names. + if (!any(colnames(object@prediction_data) %in% object@classes)) { + # Here neither of the sets of predicted values can be directly matched + # against a known class, and we infer that these appear in the order of + # classes. + + ..warning( + paste0( + "Neither set of predicted values (", + paste_s(colnames(object@prediction_data)), + ") can be directly assigned to a corresponding class (", + paste_s(object@classes), "). We assume these sets ", + "are ordered according to the provided classes." + ), + warning_class = "prediction_table_warning" + ) + data.table::setnames(object@prediction_data, new = object@classes) + + } else if (!all(colnames(object@prediction_data) %in% object@classes)) { + # Here one of the sets of predicted values can be matched against a + # known class, but the other cannot. We assume that the unmatched class + # corresponds to the unidentified set. + + unassigned_class <- setdiff(object@classes, colnames(object@prediction_data)) + unassigned_column <- setdiff(colnames(object@prediction_data), object@classes) + ..warning( + paste0( + "One of the sets of predicted values (", unassigned_column, + ") cannot be directly assigned to a corresponding class (", + paste_s(object@classes), "). We assume that this ", + "set corresponds to the ", unassigned_class, " class." + ), + warning_class = "prediction_table_warning" + ) + data.table::setnames( + x = object@prediction_data, + old = unassigned_column, + new = unassigned_class + ) + } + + } else { + # Under multinomial, 2 or more columns can be specified, all of which + # should contain numeric values between 0.0 and 1.0. + + # Check that all columns are numeric. + ..test_columns_numeric(object) + + # Check that all columns contain values between 0.0 and 1.0. + ..test_columns_probabilities(object) + + # Check that at least two sets of prediction data are provided. + if (ncol(object@prediction_data) < 2L) { + rlang::abort( + paste0( + "For multinomial (multi-class) endpoints, at least two sets of ", + "predicted values are expected. However (", + ncol(object@prediction_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Check that at least two classes are provided. + if (length(object@classes) < 2L) { + ..error( + paste0( + "At least two classes are expected for multinomial (multi-class) ", + "endpoints, but only ", length(object@classes), " were found: ", + paste_s(object@classes) + ), + error_class = "prediction_table_error" + ) + } + + # Check that the number of classes and provided sets match. + if (length(object@classes) != length(colnames(object@prediction_data))) { + ..error( + paste0( + "The same number of classes and sets of predicted values are ", + "expected. Found: ", length(object@classes), " classes and ", + length(colnames(object@prediction_data)), " sets." + ), + error_class = "prediction_table_error" + ) + } + + # Update column names. + if (!any(colnames(object@prediction_data) %in% object@classes)) { + # Here neither of the sets of predicted values can be directly matched + # against a known class, and we infer that these appear in the order of + # classes. + + ..warning( + paste0( + "Neither set of predicted values (", + paste_s(colnames(object@prediction_data)), + ") can be directly assigned to a corresponding class (", + paste_s(object@classes), "). We assume these sets ", + "are ordered according to the provided classes." + ), + warning_class = "prediction_table_warning" + ) + data.table::setnames(object@prediction_data, new = object@classes) + + } else if (!all(colnames(object@prediction_data) %in% object@classes)) { + # Here at least one of the sets of predicted values can be matched + # against a known class, but some others cannot. We cannot assume + # anything. + + unassigned_class <- setdiff(object@classes, colnames(object@prediction_data)) + unassigned_column <- setdiff(colnames(object@prediction_data), object@classes) + ..error( + paste0( + "Some sets of predicted values (", + paste_s(unassigned_column), + ") cannot be directly assigned to a corresponding class (", + paste_s(object@classes), ". Please name all ", + "sets of predicted values according to their class." + ), + error_class = "prediction_table_warning" + ) + data.table::setnames( + x = object@prediction_data, + old = unassigned_column, + new = unassigned_class + ) + } + } + + # Order columns in prediction data. + data.table::setcolorder(object@prediction_data, object@classes) + + if (!is_empty(object@reference_data)) { + # Check that one set of reference data are provided. + if (ncol(object@reference_data) != 1L) { + ..error( + paste0( + "Only one set of reference values was expected, but (", + ncol(object@reference_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Update column name of reference_data to the standard value. + outcome_column <- get_outcome_columns(object@outcome_type) + data.table::setnames(object@reference_data, new = outcome_column) + + # Check that reference data only contains the known classes. + missing_classes <- setdiff( + unique_na(object@reference_data[[outcome_column]]), + object@classes + ) + + if (length(missing_classes) > 0L) { + ..error( + paste0( + "One or more reference values are present that are not listed as ", + "classes: ", paste_s(missing_classes) + ), + error_class = "prediction_table_error" + ) + } + } + + return(object) + } +) + + +# .complete_new_prediction_table (survival) ------------------------------------ +setMethod( + ".complete_new_prediction_table", + signature(object = "predictionTableSurvival"), + function(object) { + + # Pass to superclass method first. + object <- callNextMethod() + + if (is_empty(object)) return(object) + + # Check outcome type + if (is.null(object@outcome_type)) object@outcome_type <- "survival" + if (object@outcome_type != "survival") { + ..error_reached_unreachable_code( + "The outcome type of predictionTableSurvival objects should be \"survival\"." + ) + } + + # Check that one set of prediction data are provided. + if (ncol(object@prediction_data) != 1L) { + ..error( + paste0( + "Only one set of predicted values was expected, but (", + ncol(object@prediction_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Update column name of prediction_data to the standard value. + data.table::setnames(object@prediction_data, new = "predicted_outcome") + + # Check that prediction data are numeric. + if (!is.numeric(object@prediction_data$predicted_outcome)) { + ..error( + paste0( + "Predicted values are expected to be numeric, but data with class ", + paste_s(class(object@prediction_data$predicted_outcome)), + " were encountered." + ), + error_class = "prediction_table_error" + ) + } + + if (!is_empty(object@reference_data)) { + # Check that two sets of reference data are provided (time, status). + if (ncol(object@reference_data) != 2L) { + ..error( + paste0( + "Both time and status data are expected, but (", + ncol(object@reference_data), ") set(s) of reference data were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Update column name of reference_data to the standard value. + outcome_column <- get_outcome_columns(object@outcome_type) + data.table::setnames(object@reference_data, new = outcome_column) + + # Check that the time column is numeric and positive. + time_column <- object@reference_data[[outcome_column[1L]]] + if (!is.numeric(time_column)) { + ..error( + paste0( + "Observed time is expected to be numeric, but data with class ", + paste_s(time_column), " were encountered." + ), + error_class = "prediction_table_error" + ) + } + + if (any(time_column < 0.0, na.rm = TRUE)) { + negative_values <- time_column + negative_values <- negative_values[is.finite(negative_values)] + negative_values <- negative_values[negative_values < 0.0] + + ..error( + paste0( + "Observed time can not be negative, but negative values were found: ", + paste_sh(negative_values) + ), + error_class = "prediction_table_error" + ) + } + + # Check that the status columns contains 0s and 1s, or can be converted to + # such values. + status_column <- object@reference_data[[outcome_column[2L]]] + status_indicators <- as.character(unique_na(status_column)) + + if (length(status_indicators) > 2L) { + ..error( + paste0( + "Event status may only contain two values that indicate censoring ", + "and event. Found: ", paste_sh(status_indicators) + ), + error_class = "prediction_table_error" + ) + } + + if (all(status_indicators %in% c(object@censored, object@event))) { + # Convert to 0s and 1s. + new_status_column <- rep_len(1L, length(status_column)) + new_status_column[status_column %in% object@censored] <- 0L + + object@reference_data <- data.table::copy(object@reference_data) + object@reference_data[[outcome_column[2L]]] <- new_status_column + + } else if (all(status_indicators %in% c("0", "1"))) { + # Do nothing. + + } else if (all(status_indicators %in% c( + .get_available_default_censoring_indicator(), + .get_available_default_event_indicator() + ))) { + + # Convert to 0s and 1s. + new_status_column <- rep_len(1L, length(status_column)) + new_status_column[status_column %in% .get_available_default_censoring_indicator()] <- 0L + + object@reference_data <- data.table::copy(object@reference_data) + object@reference_data[[outcome_column[2L]]] <- new_status_column + + } else { + + # Find indicator values + if (!all(is.na(c(object@censored, object@event)))) { + indicator_values <- c(object@censored, object@event) + } else { + indicator_values <- c( + .get_available_default_censoring_indicator(), + .get_available_default_event_indicator() + ) + } + + ..error( + paste0( + "Could not map potential status and event indicators (", + paste_s(indicator_values), ") to values present in the status column (", + paste_sh(status_indicators), ")." + ), + error_class = "prediction_table_error" + ) + } + } + + return(object) + } +) + +# .complete_new_prediction_table (novelty) ------------------------------------- +setMethod( + ".complete_new_prediction_table", + signature(object = "predictionTableNovelty"), + function(object) { + + # Pass to superclass method first. + object <- callNextMethod() + + if (is_empty(object)) return(object) + + # Check outcome type + object@outcome_type <- "unsupervised" + + # Check that one set of prediction data are provided. + if (ncol(object@prediction_data) != 1L) { + ..error( + paste0( + "Only one set of predicted values was expected, but (", + ncol(object@prediction_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Update column name of prediction_data to the standard value. + data.table::setnames(object@prediction_data, new = "novelty") + + # Check that prediction data are numeric. + if (!is.numeric(object@prediction_data$novelty)) { + ..error( + paste0( + "Predicted values are expected to be numeric, but data with class ", + paste_s(class(object@prediction_data$novelty)), + " were encountered." + ), + error_class = "prediction_table_error" + ) + } + + return(object) + } +) + +# .complete_new_prediction_table (grouping) ------------------------------------ +setMethod( + ".complete_new_prediction_table", + signature(object = "predictionTableGrouping"), + function(object) { + + # Pass to superclass method first. + object <- callNextMethod() + + if (is_empty(object)) return(object) + + # Set outcome type + object@outcome_type <- "unsupervised" + + # Check that one set of prediction data are provided. + if (ncol(object@prediction_data) != 1L) { + ..error( + paste0( + "Only one set of predicted values was expected, but (", + ncol(object@prediction_data), ") sets were provided." + ), + error_class = "prediction_table_error" + ) + } + + # Update column name of prediction_data to the standard value. + data.table::setnames(object@prediction_data, new = "group") + + # Check that prediction data contains the groups, or set groups if absent. + if (!anyNA(object@groups)) { + group_labels <- unique_na(object@prediction_data$group) + + if (!all(group_labels %in% object@groups)) { + unknown_group_label <- setdiff(group_labels, object@groups) + + ..error( + paste0( + "The set of predicted values contains group labels that could ", + "not be matched to provided labels. The following labels were not ", + "recognised: ", paste_s(unknown_group_label), ". ", + "The following labels were expected: ", paste_s(object@groups) + ), + error_class = "prediction_table_error" + ) + } + } else { + + if (is.factor(object@prediction_data$group)) { + object@groups <- levels(object@prediction_data$group) + + } else { + group_labels <- unique_na(object@prediction_data$group) + if (length(group_labels) > 0L) object@groups <- sort(group_labels) + } + } + + # Set group to factor. + if (!is.factor(object@prediction_data$group)) { + object@prediction_data$group <- factor( + x = object@prediction_data$group, + levels = object@groups + ) + } + + return(object) + } +) + + +# .is_merged_prediction_table (generic) ---------------------------------------- +setGeneric(".is_merged_prediction_table", function(x, ...) standardGeneric(".is_merged_prediction_table")) + +## .is_merged_prediction_table (general) --------------------------------------- +setMethod( + ".is_merged_prediction_table", + signature(x = "familiarDataElementPredictionTable"), + function(x, ...) { + return(!is_empty(x@grouping_column)) + } +) + + +# is_empty --------------------------------------------------------------------- +setMethod( + "is_empty", + signature(x = "familiarDataElementPredictionTable"), + function(x, ...) { + if (.is_merged_prediction_table(x)) { + return(is_empty(x@data)) + } else { + return(is_empty(x@prediction_data)) + } + } +) + + + + +all_predictions_valid <- function(prediction_table) { + # Return results when checking with the "all" function. + return(.check_predictions_valid( + object = prediction_table, + check_type = "all" + )) +} + + + +any_predictions_valid <- function(prediction_table) { + # Return results when checking with the "any" function. + + return(.check_predictions_valid( + object = prediction_table, + check_type = "any" + )) +} + + + +# .check_predictions_valid (generic) ------------------------------------------- +setGeneric(".check_predictions_valid", function(object, ...) standardGeneric(".check_predictions_valid")) + + +# .check_predictions_valid (general) ---------------------------------------- +setMethod( + ".check_predictions_valid", + signature(object = "familiarDataElementPredictionTable"), + function(object, check_type) { + + if (is_empty(object)) return(FALSE) + + check_fun <- switch( + check_type, + "all" = all, + "any" = any + ) + + data_slot <- ifelse(.is_merged_prediction_table(object), "data", "prediction_data") + + return(check_fun(is.finite(slot(object, data_slot)$predicted_outcome))) + } +) + + +# .check_predictions_valid (NULL) ---------------------------------------------- +setMethod( + ".check_predictions_valid", + signature(object = "NULL"), + function(object, check_type) { + return(FALSE) + } +) + + +# .check_predictions_valid (classification) ------------------------------------ +setMethod( + ".check_predictions_valid", + signature(object = "predictionTableClassification"), + function(object, check_type) { + + if (is_empty(object)) return(FALSE) + + check_fun <- switch( + check_type, + "all" = all, + "any" = any + ) + + if (.is_merged_prediction_table(object)) { + return(all(sapply( + object@data[, mget(object@value_column)], + function(x, check_fun) (check_fun(is_valid_data(x))), + check_fun = check_fun + ))) + } else { + return(all(sapply( + object@prediction_data, + function(x, check_fun) (check_fun(is_valid_data(x))), + check_fun = check_fun + ))) + } + } +) + + +# .check_predictions_valid (novelty) ---------------------------------------- +setMethod( + ".check_predictions_valid", + signature(object = "predictionTableNovelty"), + function(object, check_type) { + + if (is_empty(object)) return(FALSE) + + check_fun <- switch( + check_type, + "all" = all, + "any" = any + ) + + data_slot <- ifelse(.is_merged_prediction_table(object), "data", "prediction_data") + + return(check_fun(is.finite(slot(object, data_slot)$novelty))) + } +) + + +# .check_predictions_valid (grouping) ---------------------------------------- +setMethod( + ".check_predictions_valid", + signature(object = "predictionTableGrouping"), + function(object, check_type) { + + if (is_empty(object)) return(FALSE) + + check_fun <- switch( + check_type, + "all" = all, + "any" = any + ) + + data_slot <- ifelse(.is_merged_prediction_table(object), "data", "prediction_data") + + return(check_fun(!is.na(slot(object, data_slot)$group))) + } +) + + + +# .has_reference_data (generic) ------------------------------------------------ +setGeneric( + ".has_reference_data", + function(object, ...) standardGeneric(".has_reference_data") +) + + + +# .has_reference_date (general) ------------------------------------------------ +setMethod( + ".has_reference_data", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + if (is_empty(object)) return(FALSE) + + if (.is_merged_prediction_table(object)) { + outcome_columns <- c("outcome", "outcome_time", "outcome_event") + present_outcome_columns <- intersect(colnames(object@data), outcome_columns) + + return(length(present_outcome_columns) > 0L) + + } else { + return(!is_empty(object@reference_data)) + } + } +) + + + +# .has_reference_date (novelty) ------------------------------------------------ +setMethod( + ".has_reference_data", + signature(object = "predictionTableNovelty"), + function(object, ...) { + return(FALSE) + } +) + + + +# .has_reference_date (grouping) ----------------------------------------------- +setMethod( + ".has_reference_data", + signature(object = "predictionTableGrouping"), + function(object, ...) { + return(FALSE) + } +) + + + +# .has_reference_date (risk groups) -------------------------------------------- +setMethod( + ".has_reference_data", + signature(object = "predictionTableRiskGroups"), + function(object, ...) { + if (is_empty(object)) return(FALSE) + + if (.is_merged_prediction_table(object)) { + outcome_columns <- c("outcome_time", "outcome_event") + present_outcome_columns <- intersect(colnames(object@data), outcome_columns) + + return(length(present_outcome_columns) > 0L) + + } else { + return(!is_empty(object@reference_data)) + } + } +) + + + +# .has_reference_date (NULL) --------------------------------------------------- +setMethod( + ".has_reference_data", + signature(object = "NULL"), + function(object, ...) { + return(FALSE) + } +) + + + +# .drop_reference_data (generic) ----------------------------------------------- +setGeneric( + ".drop_reference_data", + function(object, ...) standardGeneric(".drop_reference_data") +) + + + +# .drop_reference_data (general) ----------------------------------------------- +setMethod( + ".drop_reference_data", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + if (is_empty(object)) return(object) + + outcome_columns <- c("outcome", "outcome_time", "outcome_event") + if (.is_merged_prediction_table(object)) { + present_outcome_columns <- intersect(colnames(object@data), outcome_columns) + if (length(present_outcome_columns) == 0L) return(object) + + object@data[, (present_outcome_columns) := NULL] + + grouping_columns <- setdiff(object@grouping_column, present_outcome_columns) + if (length(grouping_columns) == 0L) grouping_columns <- NULL + object@grouping_column <- grouping_columns + + } else { + object@reference_data <- NULL + } + + return(object) + } +) + + + +# .drop_reference_data (null) -------------------------------------------------- +setMethod( + ".drop_reference_data", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) + + + +# remove_invalid_predictions (generic) ----------------------------------------- +setGeneric("remove_invalid_predictions", function(object, ...) standardGeneric("remove_invalid_predictions")) + + +# remove_invalid_predictions (general) ----------------------------------------- +setMethod( + "remove_invalid_predictions", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + if (is_empty(object)) return(object) + + if (.is_merged_prediction_table(object)) { + instance_mask <- is.finite(object@data$predicted_outcome) + + object@data <- object@data[instance_mask, ] + + } else { + instance_mask <- is.finite(object@prediction_data$predicted_outcome) + + object@identifier_data <- object@identifier_data[instance_mask, ] + object@prediction_data <- object@prediction_data[instance_mask, ] + if (!is_empty(object@reference_data)) { + object@reference_data <- object@reference_data[instance_mask, ] + } + } + + return(object) + } +) + + +# remove_invalid_predictions (classification) ---------------------------------- +setMethod( + "remove_invalid_predictions", + signature(object = "predictionTableClassification"), + function(object, ...) { + if (is_empty(object)) return(object) + + if (.is_merged_prediction_table(object)) { + instance_mask <- as.logical( + do.call(pmin, lapply(object@data[, mget(object@value_column)], is.finite)) + ) + + object@data <- object@data[instance_mask, ] + + } else { + instance_mask <- as.logical( + do.call(pmin, lapply(object@prediction_data, is.finite)) + ) + + object@identifier_data <- object@identifier_data[instance_mask, ] + object@prediction_data <- object@prediction_data[instance_mask, ] + if (!is_empty(object@reference_data)) { + object@reference_data <- object@reference_data[instance_mask, ] + } + } + + return(object) + } +) + + +# remove_invalid_predictions (novelty) ----------------------------------------- +setMethod( + "remove_invalid_predictions", + signature(object = "predictionTableNovelty"), + function(object, ...) { + if (is_empty(object)) return(object) + + if (.is_merged_prediction_table(object)) { + instance_mask <- is.finite(object@data$novelty) + + object@data <- object@data[instance_mask, ] + + } else { + instance_mask <- is.finite(object@prediction_data$novelty) + + object@identifier_data <- object@identifier_data[instance_mask, ] + object@prediction_data <- object@prediction_data[instance_mask, ] + if (!is_empty(object@reference_data)) { + object@reference_data <- object@reference_data[instance_mask, ] + } + } + + return(object) + } +) + + +# remove_invalid_predictions (grouping) ---------------------------------------- +setMethod( + "remove_invalid_predictions", + signature(object = "predictionTableGrouping"), + function(object, ...) { + if (is_empty(object)) return(object) + + if (.is_merged_prediction_table(object)) { + instance_mask <- is.finite(object@data$group) + + object@data <- object@data[instance_mask, ] + + } else { + instance_mask <- is.finite(object@prediction_data$group) + + object@identifier_data <- object@identifier_data[instance_mask, ] + object@prediction_data <- object@prediction_data[instance_mask, ] + if (!is_empty(object@reference_data)) { + object@reference_data <- object@reference_data[instance_mask, ] + } + } + + return(object) + } +) + + + +# remove_invalid_predictions (null) -------------------------------------------- +setMethod( + "remove_invalid_predictions", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) + + + +# .complete (general) ---------------------------------------------------------- +setMethod( + ".complete", + signature(object = "familiarDataElementPredictionTable"), + function(object, ...) { + object <- .merge_slots_into_data(object) + + return(object) + } +) + + + +# .complete (null) ------------------------------------------------------------- +setMethod( + ".complete", + signature(object = "NULL"), + function(object, ...) { + return(NULL) + } +) + + + +# .complete (classification) --------------------------------------------------- +setMethod( + ".complete", + signature(object = "predictionTableClassification"), + function(object, ...) { + # Call general method first. + object <- callNextMethod() + + if (is_empty(object)) return(object) + if (!any_predictions_valid(object)) return(object) + + # Add predicted class. + if (!"predicted_class" %in% colnames(object@data)) { + + # First define the class with the highest probability. + class_indices <- apply(object@data[, mget(object@classes)], 1L, which.max, simplify = FALSE) + class_indices <- sapply(class_indices, function(x) (ifelse(length(x) == 1L, x, NA_integer_))) + class_predictions <- factor(class_indices, levels = seq_along(object@classes), labels = object@classes) + + object@data[, "predicted_class" := class_predictions] + + # Updated value columns. + object@value_column <- c(object@value_column, "predicted_class") + } + + return(object) + } +) + + + +# filter_missing_outcome (general) --------------------------------------------- +setMethod( + "filter_missing_outcome", + signature(data = "familiarDataElementPredictionTable"), + function( + data, + is_validation = FALSE, + outcome_type = NULL, + ... + ) { + # This method removes instances where reference data are missing. + # See other methods for filter_missing_outcome in DataObject.R. + + # Check if data itself or the reference data contained therein is empty. + if (is_empty(data)) return(data) + + merged_table <- .is_merged_prediction_table(data) + data_slot <- ifelse(merged_table, "data", "reference_data") + + if (is_empty(slot(data, data_slot))) return(data) + + # Determine outcome type. This is not merely a shortcut, e.g. for some + # prediction tables (e.g. predictionTableRiskGroups) the outcome type is + # unsupervised (which is correct), but outcome columns might still be + # present. + if (is.null(outcome_type)) { + outcome_type <- data@outcome_type + } + + if (outcome_type %in% c("survival", "competing_risk")) { + if (merged_table && !all(c("outcome_time", "outcome_event") %in% data@grouping_column)) return(data) + + outcome_is_valid <- is_valid_data(slot(data, data_slot)$outcome_time) & + is_valid_data(slot(data, data_slot)$outcome_event) + + } else if (outcome_type %in% c("binomial", "multinomial", "continuous")) { + if (merged_table && !("outcome" %in% data@grouping_column)) return(data) + + outcome_is_valid <- is_valid_data(slot(data, data_slot)$outcome) + } else { + ..error_outcome_type_not_implemented(outcome_type) + } + + if (is_validation) { + # Check whether all outcome information is missing for validation. It may + # be a prospective study. In that case, keep all data. + if (!any(outcome_is_valid)) outcome_is_valid <- !outcome_is_valid + } + + # Filter instances. + if (merged_table) { + data@data <- data@data[outcome_is_valid, ] + + } else { + data@identifier_data <- data@identifier_data[outcome_is_valid, ] + data@reference_data <- data@reference_data[outcome_is_valid, ] + data@prediction_data <- data@prediction_data[outcome_is_valid, ] + } + + return(data) + } +) + + + +setMethod( + ".as_data_table", + signature(x = "familiarDataElementPredictionTable"), + function(x, ...) { + x <- .merge_slots_into_data(x) + + return(data.table::copy(x@data)) + } +) + + + +# .merge_slots_into_data (general) --------------------------------------------- +setMethod( + ".merge_slots_into_data", + signature(x = "familiarDataElementPredictionTable"), + function(x, ...) { + # Merge identifier_data, reference_data and prediction_data and set + # value column and grouping columns. + + # Do not merge prediction tables that are already merged. + if (.is_merged_prediction_table(x)) return(x) + if (is_empty(x)) return(x) + + # Set grouping and value columns. + x@grouping_column <- c(x@grouping_column, colnames(x@identifier_data), colnames(x@reference_data)) + x@value_column <- colnames(x@prediction_data) + + # Merge data and set data attribute. + x@data <- cbind(x@identifier_data, x@reference_data, x@prediction_data) + + # Empty data slots. + slot(x, "identifier_data", check = FALSE) <- NULL + slot(x, "reference_data", check = FALSE) <- NULL + slot(x, "prediction_data", check = FALSE) <- NULL + + return(x) + } +) + + +# .merge_slots_into_data (null) ------------------------------------------------ +setMethod( + ".merge_slots_into_data", + signature(x = "NULL"), + function(x, ...) { + return(NULL) + } +) + + +# .extract_slots_from_data (general) ------------------------------------------- +setMethod( + ".extract_slots_from_data", + signature(x = "familiarDataElementPredictionTable"), + function(x, ...) { + # Extract identifier_data, reference_data and prediction_data from data. + + if (!.is_merged_prediction_table(x)) return(x) + + # Get reference columns. + reference_columns <- get_outcome_columns(x@outcome_type) + + # Get identifier columns. + identifier_columns <- setdiff(x@grouping_column, reference_columns) + + # Set identifier data. + x@identifier_data <- x@data[, mget(identifier_columns)] + + # Set or generate reference columns. + if (is.null(reference_columns)) { + # Pass. Do not set reference data if none are required. + + } else if (all(reference_columns %in% colnames(x@data))) { + x@reference_data <- x@data[, mget(reference_columns)] + + } else { + # Pass do not set reference data it is missing. + } + + # Set prediction data. + x@prediction_data <- x@data[, mget(x@value_column)] + + # Reset grouping and value column attributes, and empty data. + slot(x, "grouping_column", check = FALSE) <- NULL + slot(x, "value_column") <- NA_character_ + slot(x, "data", check = FALSE) <- NULL + + return(x) + } +) + + +# .extract_slots_from_data (null) ---------------------------------------------- +setMethod( + ".extract_slots_from_data", + signature(x = "NULL"), + function(x, ...) { + + return(NULL) + } +) + + +# ..compute_ensemble_prediction_estimates (general) ---------------------------- +setMethod( + "..compute_ensemble_prediction_estimates", + signature(x = "familiarDataElementPredictionTable"), + function(x, data, ensemble_method, ...) { + # Suppress NOTES due to non-standard evaluation in data.table + estimation_type <- NULL + + # Check if ensembling is actually required -- computing ensemble values is + # somewhat expensive because it is done for each subset of data. + if (data.table::uniqueN(data, by = x@grouping_column) == nrow(data)) { + return(data[ + , mget(c(x@grouping_column, x@value_column)) + ]) + } + + # Check if ensembling uses standard functions where we don't actually need + # do difficult stuff. + if (ensemble_method == "median") { + data <- data[ + estimation_type != "point", + (x@value_column) := lapply(.SD, stats::median, na.rm = TRUE), + by = c(x@grouping_column), + .SDcols = c(x@value_column) + ] + data <- unique(data[, mget(c(x@grouping_column, x@value_column))]) + + } else if (ensemble_method == "mean") { + data <- data[ + estimation_type != "point", + (x@value_column) := lapply(.SD, mean, na.rm = TRUE), + by = c(x@grouping_column), + .SDcols = c(x@value_column) + ] + data <- unique(data[, mget(c(x@grouping_column, x@value_column))]) + + } else { + # Compute bootstrap estimates. + data <- data[ + , + ...compute_bootstrap_ensemble_estimates( + x = .SD, + prediction_columns = x@value_column, + confidence_level = x@confidence_level, + percentiles = x@percentiles, + ensemble_method = ensemble_method, + ... + ), + by = c(x@grouping_column), + .SDcols = c("estimation_type", x@value_column) + ] + } + + return(data) + } +) + + +# ..compute_ensemble_prediction_estimates (general groups) --------------------- +setMethod( + "..compute_ensemble_prediction_estimates", + signature(x = "predictionTableGrouping"), + function(x, data, ensemble_method, ...) { + # Suppress NOTES due to non-standard evaluation in data.table + estimation_type <- NULL + + # There is no natural way to estimate bootstrap intervals for groups, and we + # therefore revert to the "median" method. + if (ensemble_method %in% c("percentile", "bc")) { + ensemble_method <- "median" + data <- data[estimation_type != "point"] + } + + # Check if ensembling is actually required -- the computation is somewhat + # expensive because it is done on the subset of data. + if (data.table::uniqueN(data, by = x@grouping_column) == nrow(data)) { + return(data[, mget(c(x@grouping_column, x@value_column))]) + + } else { + # For median, we use + return(data[ + estimation_type != "point", + (x@value_column) := lapply(.SD, get_mode), + by = c(x@grouping_column), + .SDcols = c(x@value_column) + ][ + , mget(c(x@grouping_column, x@value_column)) + ]) + } + } +) + + + +# ..compute_ensemble_prediction_estimates (risk strata) ------------------------ +setMethod( + "..compute_ensemble_prediction_estimates", + signature(x = "predictionTableRiskGroups"), + function(x, data, ensemble_method, ...) { + # Suppress NOTES due to non-standard evaluation in data.table + estimation_type <- NULL + + # There is no natural way to estimate bootstrap intervals for groups, and we + # therefore revert to the "median" method. + if (ensemble_method %in% c("percentile", "bc")) { + ensemble_method <- "median" + data <- data[estimation_type != "point"] + } + + # Check if ensembling is actually required -- the computation is somewhat + # expensive because it is done on the subset of data. + if (data.table::uniqueN(data, by = x@grouping_column) == nrow(data)) { + return(data[, mget(c(x@grouping_column, x@value_column))]) + + } else if (ensemble_method == "median") { + # For median, we use the closest approximate: the most commonly selected + # group. + return(data[ + estimation_type != "point", + (x@value_column) := lapply(.SD, get_mode), + by = c(x@grouping_column), + .SDcols = c(x@value_column) + ][ + , mget(c(x@grouping_column, x@value_column)) + ]) + + } else if (ensemble_method == "mean") { + return(data[ + estimation_type != "point", + (x@value_column) := lapply(.SD, get_mean_risk_group), + by = c(x@grouping_column), + .SDcols = c(x@value_column) + ][ + , mget(c(x@grouping_column, x@value_column)) + ]) + } + } +) + + + +...compute_bootstrap_ensemble_estimates <- function( + x, + prediction_columns, + ensemble_method, + confidence_level = NULL, + percentiles = NULL +) { + + # Suppress NOTES due to non-standard evaluation in data.table + estimation_type <- NULL + + # Compute ensemble estimates using bootstraps. + ensemble_values <- lapply( + prediction_columns, + function(ii_col, x) { + return(..bootstrap_ci( + x = x[estimation_type != "point"][[ii_col]], + x0 = x[estimation_type == "point"][[ii_col]], + bootstrap_ci_method = ensemble_method, + confidence_level = confidence_level, + percentiles = percentiles + )) + }, + x = x + ) + + # Determine column names + column_names <- lapply( + seq_along(prediction_columns), + function(ii, prediction_columns, ensemble_values, parse_percentile) { + # If the content of element ii is not a list itself, it contains only a + # single value that should be named. + if (!is.list(ensemble_values[[ii]])) return(prediction_columns[ii]) + + if (!parse_percentile) { + # If the content of element ii is a list, assign the prediction column + # name to the first column, and add the name to the remainder. + + column_names <- prediction_columns[ii] + + if (length(ensemble_values[[ii]]) > 1L) { + column_names <- c( + column_names, + paste0(prediction_columns[ii], "_", names(ensemble_values[[ii]])[2L:length(ensemble_values[[ii]])]) + ) + } + + return(column_names) + + } else { + # Assign the prediction column name to every column in case percentiles + # are returned. + return(paste0(prediction_columns[ii], "_", names(ensemble_values[[ii]]))) + } + }, + prediction_columns = prediction_columns, + ensemble_values = ensemble_values, + parse_percentile = is.null(confidence_level) && !is.null(percentiles) + ) + + # Flatten list of column names + column_names <- unlist(column_names) + + # Flatten list of ensemble values. + ensemble_values <- unlist(ensemble_values, recursive = FALSE) + if (!is.list(ensemble_values)) ensemble_values <- as.list(ensemble_values) + + # Set column names. + names(ensemble_values) <- column_names + + return(ensemble_values) +} + + + +# add_model_name (familiarDataElement, prediction table)------------------------ +setMethod( + "add_model_name", + signature( + data = "familiarDataElement", + object = "familiarDataElementPredictionTable" + ), + function(data, object) { + + data <- add_data_element_identifier( + x = data, + model_name = "custom_prediction_table" + )[[1L]] + + return(data) + } +) + + +# load_familiar_object (prediction table) -------------------------------------- +setMethod( + "load_familiar_object", + signature(object = "familiarDataElementPredictionTable"), + function(object) { + return(object) + } +) + + +# get_outcome_class_levels (prediction table) ---------------------------------- +setMethod( + "get_outcome_class_levels", + signature(x = "familiarDataElementPredictionTable"), + function(x) { + ..error_reached_unreachable_code("This prediction table object does not have a classes attribute.") + } +) + + +# get_outcome_class_levels (classification) ------------------------------------ +setMethod( + "get_outcome_class_levels", + signature(x = "predictionTableClassification"), + function(x) { + return(x@classes) + } +) + + +# get_n_samples (prediction table) --------------------------------------------- +setMethod( + "get_n_samples", + signature(x = "familiarDataElementPredictionTable"), + function(x, id_depth = "sample", count_unique = TRUE) { + data_slot <- ifelse(.is_merged_prediction_table(x), "data", "identifier_data") + return(get_n_samples(methods::slot(x, data_slot), id_depth = id_depth, count_unique = count_unique)) + } +) + + + +# get_bootstrap_sample (prediction table) -------------------------------------- +setMethod( + "get_bootstrap_sample", + signature(data = "familiarDataElementPredictionTable"), + function( + data, + seed = NULL, + rstream_object = NULL, + n_samples = NULL, + ... + ) { + data <- .merge_slots_into_data(data) + data@data <- get_bootstrap_sample( + data = data@data, + seed = seed, + rstream_object = rstream_object, + n_samples = n_samples + ) + + return(data) + } +) + + + +# get_object_name (prediction table) ------------------------------------------- +setMethod( + "get_object_name", + signature(object = "familiarDataElementPredictionTable"), + function(object, abbreviated = FALSE) { + + return("prediction_table") + } +) + + + +# #export_prediction_data (collection) ----------------------------------------- + +#'@rdname export_prediction_data-methods +setMethod( + "export_prediction_data", + signature(object = "familiarCollection"), + function( + object, + dir_path = NULL, + export_collection = FALSE, + ... + ) { + + # Make sure the collection object is updated. + object <- update_object(object = object) + + .export_looper <- function(object, object_class, subtype, dir_path, export_collection) { + .export( + x = object, + data_slot = "prediction_data", + dir_path = dir_path, + object_class = object_class, + type = "prediction", + subtype = subtype, + export_collection = export_collection + ) + } + + object_class <- c( + "predictionTableRegression", + "predictionTableSurvival", + "predictionTableSurvivalHazardRatio", + "predictionTableSurvivalCumulativeHazard", + "predictionTableSurvivalTime", + "predictionTableSurvivalProbability", + "predictionTableGrouping", + "predictionTableRiskGroups", + "predictionTableClassification", + "predictionTableNovelty" + ) + + subtype <- c( + "regression", + "survival_generic", + "hazard_ratio", + "cumulative_hazard", + "expected_survival_time", + "survival_probability", + "grouping", + "risk_stratification", + "classification", + "novelty" + ) + + export_data <- mapply( + FUN = .export_looper, + object_class = object_class, + subtype = subtype, + MoreArgs = list( + "object" = object, + "dir_path" = dir_path, + "export_collection" = export_collection + ), + SIMPLIFY = FALSE, + USE.NAMES = FALSE + ) + + names(export_data) <- subtype + export_data <- export_data[!sapply(export_data, is_empty)] + + return(export_data) + } +) diff --git a/R/ProcessTimeUtilities.R b/R/ProcessTimeUtilities.R index f18d07ea..7a43b995 100644 --- a/R/ProcessTimeUtilities.R +++ b/R/ProcessTimeUtilities.R @@ -4,13 +4,15 @@ ProcessClock <- setRefClass( fields = list( clock_process = "ANY", start_time = "numeric", - interrupt_time = "ANY"), + interrupt_time = "ANY" + ), methods = list( "initialize" = function() { # Make sure that the packages are installed and can their namespaces can # be attached. require_package(c("callr", "microbenchmark"), - purpose = "to measure process time") + purpose = "to measure process time" + ) # Set-up fields. .self$initFields( @@ -35,7 +37,7 @@ ProcessClock <- setRefClass( # Warn for interrupts if, for some reason (e.g. process suspension, OS # hibernation, etc.) the process slept for at least 1 second. - if ((time_current - time_start) > 1E9) { + if ((time_current - time_start) > 1.0E9) { cat(format(time_start, scientific = FALSE), ":", format(time_current, scientific = FALSE), @@ -69,13 +71,13 @@ ProcessClock <- setRefClass( .self$clock_process$read_output_lines() ) - if (length(interrupt) > 0) { + if (length(interrupt) > 0L) { # Split into start and endtimes. interrupt <- strsplit(x = interrupt, split = ":") interrupt_data <- data.table::data.table( - "time_start" = as.numeric(sapply(interrupt, function(x) x[1], USE.NAMES = FALSE)), - "time_end" = as.numeric(sapply(interrupt, function(x) x[2], USE.NAMES = FALSE)) + "time_start" = as.numeric(sapply(interrupt, function(x) x[1L], USE.NAMES = FALSE)), + "time_end" = as.numeric(sapply(interrupt, function(x) x[2L], USE.NAMES = FALSE)) ) # Update interrupt_time field. @@ -93,10 +95,11 @@ ProcessClock <- setRefClass( # Select only data that contains (part of) the reference time interval. # Work on a copy of the data to avoid updating by reference. interrupt_data <- data.table::copy( - .self$interrupt_time[ref_start_time < time_end & ref_end_time > time_start]) + .self$interrupt_time[ref_start_time < time_end & ref_end_time > time_start] + ) # If all interrupts fall outside the reference time interval, return 0. - if (nrow(interrupt_data) == 0) return(0.0) + if (nrow(interrupt_data) == 0L) return(0.0) # Update partial interrupt windows. interrupt_data[ref_start_time > time_start, "time_start" := ref_start_time] @@ -109,7 +112,7 @@ ProcessClock <- setRefClass( total_interrupt_duration <- sum(interrupt_data$duration) # Return 0 if the total interrupt was smaller than 1s. - if (total_interrupt_duration < 1E9) return(0.0) + if (total_interrupt_duration < 1.0E9) return(0.0) return(total_interrupt_duration) }, @@ -132,27 +135,27 @@ ProcessClock <- setRefClass( ) conversion_factor <- switch(units, - "secs" = 1E9, - "sec" = 1E9, - "s" = 1E9, - "mins" = 60E9, - "min" = 60E9, - "m" = 60E9, - "hours" = 3600E9, - "hour" = 3600E9, - "h" = 3600E9, - "millisecs" = 1E6, - "millisec" = 1E6, - "milli" = 1E6, - "ms" = 1E6, - "microsecs" = 1E3, - "microsec" = 1E3, - "micro" = 1E3, - "us" = 1E3, - "nanosecs" = 1, - "nanosec" = 1, - "nano" = 1, - "ns" = 1 + "secs" = 1.0E9, + "sec" = 1.0E9, + "s" = 1.0E9, + "mins" = 60.0E9, + "min" = 60.0E9, + "m" = 60.0E9, + "hours" = 3600.0E9, + "hour" = 3600.0E9, + "h" = 3600.0E9, + "millisecs" = 1.0E6, + "millisec" = 1.0E6, + "milli" = 1.0E6, + "ms" = 1.0E6, + "microsecs" = 1.0E3, + "microsec" = 1.0E3, + "micro" = 1.0E3, + "us" = 1.0E3, + "nanosecs" = 1.0, + "nanosec" = 1.0, + "nano" = 1.0, + "ns" = 1.0 ) return((current_time - sum_interrupt_time - reference_time) / conversion_factor) diff --git a/R/Random.R b/R/Random.R index ff1e1752..8710388d 100644 --- a/R/Random.R +++ b/R/Random.R @@ -15,12 +15,14 @@ size, replace, seed = NULL, - rstream_object = NULL) { + rstream_object = NULL +) { # Create a random generator stream to avoid touching seeds globally. if (is.null(seed) && is.null(rstream_object)) { ..error_reached_unreachable_code( - "..fam_sample: seed and rstream_object cannot both be NULL") + "..fam_sample: seed and rstream_object cannot both be NULL" + ) } if (!is.null(seed) && is.null(rstream_object)) { @@ -29,7 +31,8 @@ if (!is(rstream_object, "rstream.runif")) { ..error_reached_unreachable_code( - "..fam_sample: rstream_object is not an rstream.runif object.") + "..fam_sample: rstream_object is not an rstream.runif object." + ) } # Determine the number of random values to generate. When samples are @@ -42,10 +45,11 @@ if (replace) { # Generate sample indices. - x_indices <- ceiling(random_values * length(x)) + x_indices <- as.integer(ceiling(random_values * length(x))) # Replace index 0, if present. - x_indices[x_indices == 0] <- 1 + x_indices[x_indices == 0L] <- 1L + } else { # Create sample indices by ranking indices. x_indices <- data.table::frank(random_values, ties.method = "first") @@ -77,7 +81,8 @@ fam_rnorm <- function( mean = mean, sd = sd, seed = seed, - rstream_object = rstream_object)) + rstream_object = rstream_object + )) } @@ -87,12 +92,14 @@ fam_rnorm <- function( mean = 0.0, sd = 1.0, seed = NULL, - rstream_object = NULL) { + rstream_object = NULL +) { # Based on Marsaglia polar method. if (is.null(seed) && is.null(rstream_object)) { ..error_reached_unreachable_code( - "..fam_rnorm: seed and rstream_object cannot both be NULL") + "..fam_rnorm: seed and rstream_object cannot both be NULL" + ) } if (!is.null(seed) && is.null(rstream_object)) { @@ -101,13 +108,15 @@ fam_rnorm <- function( if (!is(rstream_object, "rstream.runif")) { ..error_reached_unreachable_code( - "..fam_rnorm: rstream_object is not an rstream.runif object.") + "..fam_rnorm: rstream_object is not an rstream.runif object." + ) } x <- sapply( seq_len(n), ..fam_rnorm, - rstream_object = rstream_object) + rstream_object = rstream_object + ) return(mean + sd * x) } @@ -120,12 +129,12 @@ fam_rnorm <- function( x_1 <- rstream::rstream.sample(rstream_object, 1L) * 2.0 - 1.0 x_2 <- rstream::rstream.sample(rstream_object, 1L) * 2.0 - 1.0 - s <- x_1^2 + x_2^2 + s <- x_1^2.0 + x_2^2.0 - if (s < 1) break + if (s < 1.0) break } - if (s == 0) return(0) + if (s == 0.0) return(0.0) return(x_1 * sqrt(-2.0 * log(s) / s)) } @@ -137,13 +146,15 @@ fam_runif <- function( min = 0.0, max = 1.0, seed = NULL, - rstream_object = NULL) { + rstream_object = NULL +) { if (is.null(seed) && is.null(rstream_object)) { return(stats::runif( n = n, min = min, - max = max)) + max = max + )) } return(.fam_runif( @@ -151,7 +162,8 @@ fam_runif <- function( min = min, max = max, seed = seed, - rstream_object = rstream_object)) + rstream_object = rstream_object + )) } @@ -161,10 +173,12 @@ fam_runif <- function( min = 0.0, max = 1.0, seed = NULL, - rstream_object = NULL) { + rstream_object = NULL +) { if (is.null(seed) && is.null(rstream_object)) { ..error_reached_unreachable_code( - "..fam_runif: seed and rstream_object cannot both be NULL") + "..fam_runif: seed and rstream_object cannot both be NULL" + ) } if (!is.null(seed) && is.null(rstream_object)) { @@ -173,7 +187,8 @@ fam_runif <- function( if (!is(rstream_object, "rstream.runif")) { ..error_reached_unreachable_code( - "..fam_runif: rstream_object is not an rstream.runif object.") + "..fam_runif: rstream_object is not an rstream.runif object." + ) } # Create uniformly sampled data. diff --git a/R/RandomGrouping.R b/R/RandomGrouping.R deleted file mode 100644 index 5ef349e1..00000000 --- a/R/RandomGrouping.R +++ /dev/null @@ -1,451 +0,0 @@ -#' Create randomised groups Creates randomised groups, e.g. for tests that -#' depend on splitting (continuous) data into groups, such as the -#' Hosmer-Lemeshow test -#' -#' The default fast mode is based on random sampling, whereas the slow mode is -#' based on probabilistic joining of adjacent groups. As the name suggests, fast -#' mode operates considerably more efficient. -#' -#' @param x Vector with data used for sorting. Groups are formed based on -#' adjacent values. -#' @param y Vector with markers, e.g. the events. Should be 0 or 1 (for an -#' event). -#' @param sample_identifiers data.table with sample_identifiers. If provide, a -#' list of grouped sample_identifiers will be returned, and integers -#' otherwise. -#' @param n_max_groups Maximum number of groups that need to be formed. -#' @param n_min_groups Minimum number of groups that need to be formed. -#' @param n_min_y_in_group Minimum number of y=1 in each group for a valid -#' group. -#' @param n_groups_init Number of initial groups (default: 30) -#' @param fast_mode Enables fast randomised grouping mode (default: TRUE) -#' -#' @details Creates randomised groups, e.g. for tests that depend on splitting -#' (continuous) data into groups, such as the Hosmer-Lemeshow test -#' * Determine maximum number of groups: either 10 or number so that each group -#' has 5 events (if smaller). -#' * Determine minimum number of groups (half the maximum, or 2). Groups cannot -#' the exceed corresponding group size. -#' * Start with 50 very small groups. -#' * Iterate while the maximum number of groups has not been reached. -#' * Selection probability is 1/n_j -#' * If a group exceeds the maximum group size, selection probability is 0. -#' * Break if all groups have exceeded the maximum size. -#' * Get cumulative probability and normalise by total. -#' * Draw random number between 0 and 1. -#' * Select the group which has a cumulative probability range that contains -#' the random number. -#' * Draw a random number to decide whether to join the group with right or -#' left adjacent group, and assign the group number to the adjacent group. -#' Probability depends on the size of adjacent groups. Smaller sizes have -#' greater probability of being joined. No joining with groups already -#' exceeding the maximum group size. If surrounded on both sides, force -#' selection probability for current group to 0. If joining is possible, -#' update group size, and selection probability for the new group. -#' * Check that 5 events are present in each group. For each group with < 5 -#' events, try to join with neighbours. -#' * Start over if the number of groups is smaller than the minimum number. -#' -#' @return List of group sample ids or indices. -#' @md -#' @keywords internal -create_randomised_groups <- function( - x, - y = NULL, - sample_identifiers, - n_max_groups = NULL, - n_min_groups = NULL, - n_min_y_in_group = NULL, - n_groups_init = 30, - fast_mode = TRUE) { - - # Suppress NOTES due to non-standard evaluation in data.table - group_id <- cum_y <- weight <- cum_prob_lower <- cum_prob_upper <- NULL - exclude <- y_in_group <- NULL - - # initial parsing ------------------------------------------------------------ - # - Get number of x - n_x <- length(x) - - # - Get number of y - if (is.null(y)) y <- rep(0, n_x) - n_y <- sum(y) - - # - Get the maximum of groups - if (is.null(n_max_groups)) { - n_max_groups <- ceiling(2.5 * n_x^(1 / 3)) - } - - # - Update maximum number of groups - if (n_y > 0 && !is.null(n_min_y_in_group)) { - n_max_groups <- min(c(n_max_groups, floor(n_y / n_min_y_in_group))) - } - - # - Update mininum number of groups based on n_max_groups - if (is.null(n_min_groups)) { - n_min_groups <- min(c(n_max_groups, ceiling(1.0 * n_x^(1 / 3)))) - } - - # Some checks - if (n_max_groups < n_min_groups || n_max_groups > n_x || n_max_groups < 2) { - return(NULL) - } - - # Populate the generic table. - dt <- data.table::copy(sample_identifiers[, mget(get_id_columns(id_depth = "series"))]) - - if (fast_mode) { - # Fast mode ---------------------------------------------------------------- - - # Create table - dt_agg <- data.table::copy(dt) - dt_agg <- dt_agg[, ":="("x" = x, "y" = y)][order(x)] - - # Initial loop counter - loop_iter <- 0 - - while (TRUE) { - # Draw a random number of groups between n_min_groups and n_max_groups - if (n_min_groups == n_max_groups) { - n_group_draw <- n_max_groups - } else { - n_group_draw <- fam_sample( - x = seq.int(from = n_min_groups, to = n_max_groups, by = 1L), - size = 1, - replace = FALSE) - } - - # Draw a randomised groups assignment - random_group_id <- sort( - fam_sample( - x = seq_len(n_group_draw), - size = n_x, - replace = TRUE)) - - # Assign group id - dt_agg[, "group_id" := random_group_id] - - # Check if all groups have the minimum required y (e.g. events/group size) - if (n_y > 0 && !is.null(n_min_y_in_group)) { - dt_y <- dt_agg[, list(y_in_group = sum(y)), by = group_id] - if (all(dt_y$y_in_group >= n_min_y_in_group)) break - - } else { - # If there is no minimum number of events required, only run one - # iteration - break - } - - # Update loop_iter in case the sample was not good enough - loop_iter <- loop_iter + 1 - - # Break from outer loop after 10 unsuccessful random samplings and create - # a static split instead - if (loop_iter >= 10) { - # Cumulative sum over y - dt_agg[, "cum_y" := cumsum(y)] - - # Assign static group ids - dt_agg[, "group_id" := findInterval( - x = cum_y, - vec = c( - -Inf, - stats::quantile(x = cum_y, (1:n_min_groups - 1) / n_min_groups), - Inf))] - - # Break from loop - break - } - } - - } else { - # Slow mode ---------------------------------------------------------------- - - # - Update maximum number of groups based on n_min_groups - if (!is.null(n_min_groups)) { - if (n_max_groups < n_min_groups + 2) { - n_max_groups <- n_min_groups + 2 - } - } - - # - Update number of initial groups so that each group size is one or more - if (n_groups_init > n_x) n_groups_init <- n_x - - # - Maximum group size, which corresponds to n_min_groups - max_group_size <- ceiling(n_x / n_min_groups) - - # Create table - dt <- dt[, ":="("x" = x, "y" = y)][order(x)] - - # Create initial groups - init_group_size <- ceiling(n_x / n_groups_init) - - # Create oversampled groups - group_size <- rep(init_group_size, n_groups_init) - - # Randomly reduce group sizes by 1 - n_samples_subtract <- init_group_size * n_groups_init - n_x - if (n_samples_subtract > 0) { - group_ind <- fam_sample( - x = seq_len(n_groups_init), - size = n_samples_subtract, - replace = FALSE) - group_size[group_ind] <- group_size[group_ind] - 1 - rm("group_ind") - } - - # Add group_id to table - dt[, "group_id" := rep(seq_len(n_groups_init), times = group_size)] - rm("init_group_size", "n_samples_subtract", "group_size", "n_groups_init") - - loop_iter <- 0 - - # Outer loop that checks whether the final number of groups is not smaller - # than n_min_groups - while (TRUE) { - dt_agg <- data.table::copy(dt) - n_groups <- data.table::uniqueN(dt_agg, by = "group_id") - - # Get a summary table - # - group size is the number of samples in the group - # - weight is the unnormalised selection probability - # - exclude is a flag to set weights to 0 for groups that would otherwise - # grow too large. - dt_s <- dt_agg[, list(group_size = .N, exclude = FALSE, weight = 1 / .N), by = group_id] - - # Determine the total weight for normalizing weights into probabilities - total_weight <- sum(dt_s$weight) - dt_s[, "cum_prob_upper" := cumsum(weight) / (total_weight)] - dt_s[, "cum_prob_lower" := c(0, dt_s$cum_prob_upper[seq_along(dt_s$cum_prob_upper) - 1])] - - # Inner loop that agglomerates groups - while (n_groups > n_max_groups) { - # Draw two numbers uniformly from [0,1] - r_prob <- stats::runif(n = 2) - - # Get the group id that contains r_prob[1] - sel_group_id <- dt_s[data.table::between( - r_prob[1], - lower = cum_prob_lower, - upper = cum_prob_upper)]$group_id[1] - - # Get neighbouring group_ids - group_left <- tail(dt_s[group_id < sel_group_id], n = 1) - group_right <- head(dt_s[group_id > sel_group_id], n = 1) - - # Get join probabilities - if (nrow(group_left) == 0) { - left_prob <- 0 - } else { - left_prob <- group_left$weight - } - if (nrow(group_right) == 0) { - right_prob <- 0 - } else { - right_prob <- group_right$weight - } - cum_join_prob <- left_prob + right_prob - - # Only join if the combined joining probability is not 0 - if (cum_join_prob > 0) { - # Normalise probability - left_prob <- left_prob / cum_join_prob - - # Determine join - if (r_prob[2] < left_prob) { - join_id <- group_left$group_id - } else { - join_id <- group_right$group_id - } - - # Apply join - dt_s[group_id == join_id, "group_id" := sel_group_id] - dt_agg[group_id == join_id, "group_id" := sel_group_id] - rm("join_id") - - } else { - # Force exclusion of the current group - dt_s[group_id == sel_group_id, "exclude" := TRUE] - } - rm("r_prob", "sel_group_id", "group_left", "group_right", - "left_prob", "right_prob", "cum_join_prob") - - # Update summary table by determining new group sizes. Group sizes are summed for entries with the same - # group_id (i.e. those just joined), whereas an OR operation is applied to exclude. - dt_s <- dt_s[, list(group_size = sum(group_size), exclude = as.logical(max(exclude))), by = group_id] - - # Exclude groups that exceed the max_group_size in size - dt_s[group_size >= max_group_size, "exclude" := TRUE] - - # Set weights - dt_s[, "weight" := 1 / group_size] - dt_s[exclude == TRUE, "weight" := 0] - - # Get total weight for normalisation - total_weight <- sum(dt_s$weight) - - # Break from inner loop if there are no more weights to set - if (total_weight == 0) { - dt_s[, "cum_prob_upper" := 0] - dt_s[, "cum_prob_lower" := 0] - - break - } - - # Set probabilities - dt_s[, "cum_prob_upper" := cumsum(weight) / (total_weight)] - dt_s[, "cum_prob_lower" := c(0, dt_s$cum_prob_upper[seq_along(dt_s$cum_prob_upper) - 1])] - - # Finally, determine n_groups - n_groups <- data.table::uniqueN(dt_s, by = "group_id") - } - rm("total_weight") - - # Check if all groups have the minimum required y (e.g. events/group size) - if (n_y > 0 && !is.null(n_min_y_in_group)) { - # Count y in each group - dt_y <- dt_agg[, list(y_in_group = sum(y)), by = group_id] - dt_y <- merge(dt_y, dt_s, by = "group_id")[order(group_id)] - - # Inner loop to resolve all y - dt_y[, "exclude" := FALSE] - dt_y[y_in_group >= n_min_y_in_group, "exclude" := TRUE] - - # Combine data until every group is valid. - while (!all(dt_y$exclude)) { - # Find the smallest group, and add this to a neighbour - sel_group_id <- dt_y[exclude == FALSE][group_size == min(dt_y$group_size)]$group_id[1] - - # Get neighbouring group_ids - group_left <- tail(dt_y[group_id < sel_group_id], n = 1) - group_right <- head(dt_y[group_id > sel_group_id], n = 1) - - # Preferentially add to a neighbour without sufficient y, but where - # addition would allow the combined group to exist Break if there is - # just one group. - if (nrow(group_left) == 0 && nrow(group_right) == 0) { - break - } - - if (nrow(group_left) == 0) { - join <- "right" - } else if (nrow(group_right) == 0) { - join <- "left" - } else { - # This requires some heuristics. General principle is to combine the - # smallest groups, unless a new group with at least n_min_y_in_group - # can be produced - n_y_left <- group_left$y_in_group - n_y_right <- group_right$y_in_group - n_y_sel <- dt_y[group_id == sel_group_id]$y_in_group - - c_y_left <- n_y_left + n_y_sel - c_y_right <- n_y_right + n_y_sel - if (c_y_left >= n_min_y_in_group && c_y_right >= n_min_y_in_group) { - # All joins would produce good groups: choose the combined - # smallest - if (c_y_left > c_y_right) { - join <- "right" - } else { - join <- "left" - } - } else if (c_y_left >= n_min_y_in_group && n_y_left < n_min_y_in_group) { - # Left join would produce a new good group: choose left - join <- "left" - } else if (c_y_right >= n_min_y_in_group && n_y_right < n_min_y_in_group) { - # Right join would produce a new good group: choose right - join <- "right" - } else if (n_y_left < n_min_y_in_group && n_y_right >= n_min_y_in_group) { - # Add to the smaller left group, as the right group is already fine. - join <- "left" - } else if (n_y_right < n_min_y_in_group && n_y_left >= n_min_y_in_group) { - # Add to the smaller right group, as the left group is already fine. - join <- "right" - } else if (n_y_left < n_y_right) { - # Add to the smaller left group - join <- "left" - } else if (n_y_left > n_y_right) { - # Add to the smaller right group - join <- "right" - } else { - # It's a toss-up - join <- sample(c("left", "right"), size = 1) - } - rm("n_y_left", "n_y_right", "n_y_sel", "c_y_left", "c_y_right") - } - - # Get join id - if (join == "left") { - join_id <- group_left$group_id - } else { - join_id <- group_right$group_id - } - rm("group_left", "group_right") - - # Apply join - dt_y[group_id == join_id, "group_id" := sel_group_id] - dt_agg[group_id == join_id, "group_id" := sel_group_id] - rm("join_id", "sel_group_id") - - # Update table - dt_y <- dt_y[, list( - group_size = sum(group_size), - y_in_group = sum(y_in_group), - exclude = as.logical(max(exclude))), - by = group_id] - dt_y[y_in_group >= n_min_y_in_group, "exclude" := TRUE] - } - - rm("dt_y") - } - - # Determine n_groups - n_groups <- data.table::uniqueN(dt_agg, by = "group_id") - - # Break from outer loop - if (n_groups >= n_min_groups) { - break - } - - # Update loop_iter in case efforts were not successful - loop_iter <- loop_iter + 1 - - # Break from outer loop after 5 unsuccessful iterations and create a - # static split instead - if (loop_iter >= 5) { - if (n_y > 0 && !is.null(n_min_y_in_group)) { - # Cumulative sum over y - dt_agg[, "cum_y" := cumsum(y)] - - # Assign static group ids - dt_agg[, "group_id" := findInterval( - x = cum_y, - vec = c( - -Inf, - stats::quantile(x = cum_y, (1:n_min_groups - 1) / n_min_groups), - Inf))] - - } else { - # Assign static group ids - dt_agg[, "group_id" := findInterval( - x = seq_len(n_x), - vec = c( - -Inf, - stats::quantile(x = seq_len(n_x), (1:n_min_groups - 1) / n_min_groups), - Inf))] - } - - # Break from loop - break - } - } - } - - # Get sample identifiers for each group - out_groups <- split( - dt_agg[, mget(c(get_id_columns(id_depth = "series"), "group_id"))], - by = "group_id", - keep.by = FALSE) - - return(out_groups) -} diff --git a/R/RankBordaAggregation.R b/R/RankBordaAggregation.R index b744fd81..fa093f7e 100644 --- a/R/RankBordaAggregation.R +++ b/R/RankBordaAggregation.R @@ -1,7 +1,9 @@ -.compute_rank_borda <- function(x, - rank_threshold, - truncated = FALSE, - enhanced = FALSE) { +.compute_rank_borda <- function( + x, + rank_threshold, + truncated = FALSE, + enhanced = FALSE +) { # Borda selection methods, as in Wald R, Khoshgoftaar TM, Dittman D, Awada W, # Napolitano A. An extensive comparison of feature ranking aggregation # techniques in bioinformatics. 2012 IEEE 13th Int. Conf. Inf. Reuse Integr., @@ -36,7 +38,8 @@ # Any remaining features receive a score of 0. borda_count_table[ rank <= rank_threshold, - "borda_score" := (rank_threshold - rank + 1) / rank_threshold] + "borda_score" := (rank_threshold - rank + 1L) / rank_threshold + ] borda_count_table[is.na(borda_score), "borda_score" := 0.0] } else { @@ -46,13 +49,15 @@ borda_count_table[, "max_rank" := max(rank), by = "run_id"] # Compute a normalised Borda score, with maximum 1 and minimum 1/max_rank. - borda_count_table[, "borda_score" := (max_rank - rank + 1) / max_rank] + borda_count_table[, "borda_score" := (max_rank - rank + 1L) / max_rank] } # Sum all scores over the different lists - borda_count_table <- borda_count_table[, list( - sum_score = sum(borda_score)), - by = "name"] + borda_count_table <- borda_count_table[ + , + list("sum_score" = sum(borda_score)), + by = "name" + ] if (enhanced) { # Enhanced borda methods use the occurrence (as in stability selection) for @@ -60,7 +65,8 @@ occurrence_table <- .compute_feature_occurrence( vimp_table = vimp_table, threshold = rank_threshold, - n_runs = n_runs) + n_runs = n_runs + ) # Merge tables by name vimp_table <- merge( @@ -68,7 +74,8 @@ y = occurrence_table, all.x = FALSE, all.y = TRUE, - by = c("name")) + by = c("name") + ) # Compute the enhanced borda score. vimp_table[, "score" := sum_score * occurrence] @@ -80,7 +87,8 @@ data.table::setnames( x = vimp_table, old = "sum_score", - new = "score") + new = "score" + ) } # Attach to vimpTable object. diff --git a/R/RankMain.R b/R/RankMain.R index 8fd259c9..45deb6ea 100644 --- a/R/RankMain.R +++ b/R/RankMain.R @@ -10,7 +10,8 @@ "borda", "enhanced_borda", "truncated_borda", - "enhanced_truncated_borda")) + "enhanced_truncated_borda" + )) } @@ -24,8 +25,8 @@ max_rank <- max(vimp_table$rank) # Check if there is only one feature or only one run - if (n_features == 1) return(1L) - if (n_runs == 1) return(max_rank) + if (n_features == 1L) return(1L) + if (n_runs == 1L) return(max_rank) # Set max threshold to either 50 or max_rank, if lower. max_threshold <- min(c(max_rank, 50L)) @@ -35,14 +36,17 @@ threshold_var <- sapply( seq_len(max_threshold), function(threshold, n_runs, vimp_table) { - return(stats::var(.compute_feature_occurrence( - vimp_table = vimp_table, - n_runs = n_runs, - threshold = threshold - )$occurrence)) + return(stats::var( + .compute_feature_occurrence( + vimp_table = vimp_table, + n_runs = n_runs, + threshold = threshold + )$occurrence + )) }, vimp_table = vimp_table, - n_runs = n_runs) + n_runs = n_runs + ) # Return optimal threshold return(which.max(threshold_var)) diff --git a/R/RankStabilityAggregation.R b/R/RankStabilityAggregation.R index b0d79929..86b7224d 100644 --- a/R/RankStabilityAggregation.R +++ b/R/RankStabilityAggregation.R @@ -19,13 +19,15 @@ vimp_table <- .compute_feature_occurrence( vimp_table = vimp_table, threshold = rank_threshold, - n_runs = n_runs) + n_runs = n_runs + ) # Rename "occurrence" column for consistency data.table::setnames( x = vimp_table, old = "occurrence", - new = "score") + new = "score" + ) # Attach to vimpTable object. x@vimp_table <- vimp_table @@ -46,9 +48,11 @@ # Calculate occurrence with a rank l.eq rank_threshold and weight by # exponential rank: better ranks receive higher scores - x@vimp_table <- x@vimp_table[, list( - "score" = sum(exp(-rank / rank_threshold) * (rank <= rank_threshold))), - by = c("name")] + x@vimp_table <- x@vimp_table[ + , + list("score" = sum(exp(-rank / rank_threshold) * (rank <= rank_threshold))), + by = c("name") + ] # Set correct invert value. x@invert <- TRUE diff --git a/R/SocketServer.R b/R/SocketServer.R index 4ca35009..4be07c0f 100644 --- a/R/SocketServer.R +++ b/R/SocketServer.R @@ -1,7 +1,7 @@ socket_server <- function( host = "local_host", - port = 6311, - timeout = 2678400) { + port = 6311L, + timeout = 2678400.0) { # The socket server basically runs until a client gives a shutdown command. server_status <- "active" @@ -46,9 +46,12 @@ socket_server_handshake <- function(con) { serialize( list( "FUN" = eval, - "args" = list(quote(Sys.getpid()))), - connection = con), - error = identity) + "args" = list(quote(Sys.getpid())) + ), + connection = con + ), + error = identity + ) # Check if the attempt was successful, otherwise return FALSE, which closes # the connection. @@ -57,7 +60,8 @@ socket_server_handshake <- function(con) { # Attempt to read the process id of the client. pid <- tryCatch( unserialize(con), - error = identity) + error = identity + ) # Return TRUE or FALSE. TRUE indicates that the connection is accepted and # works. FALSE closes the connection. @@ -71,7 +75,8 @@ socket_server_execution_loop <- function(con) { input <- tryCatch( unserialize(connection = con), warning = identity, - error = identity) + error = identity + ) # Break from loop in case a warning or error is given. if (inherits(input, "warning") || inherits(input, "error")) { @@ -87,7 +92,8 @@ socket_server_execution_loop <- function(con) { # Send back output of the function. output_send <- tryCatch( serialize(object = output, connection = con), - error = identity) + error = identity + ) return("active") @@ -105,7 +111,8 @@ socket_server_execution_loop <- function(con) { socket_client_open_connection <- function( host = "localhost", - port = 6311) { + port = 6311L +) { # Open a client-side connection. repeat { @@ -119,9 +126,11 @@ socket_client_open_connection <- function( blocking = TRUE, server = FALSE, open = "a+b", - timeout = 1), + timeout = 1.0 + ), warning = identity, - error = identity) + error = identity + ) if (inherits(con, "sockconn")) { # Try to perform the handshake with the server process. The connection is @@ -145,7 +154,8 @@ socket_client_handshake <- function(con) { # the client pid. received <- tryCatch( unserialize(con), - error = identity) + error = identity + ) # If the socket connection cannot be read, return a FALSE. This closes the # connection in the socket_client_open_connection. @@ -158,7 +168,8 @@ socket_client_handshake <- function(con) { # Try to send the pid to the server. success <- tryCatch( serialize(pid, connection = con), - error = identity) + error = identity + ) return(!inherits(success, "error")) } @@ -175,14 +186,17 @@ socket_client_do_call <- function(con, FUN, args = NULL) { object = list( "type" = "EXEC", "FUN" = FUN, - "args" = args), - connection = con) + "args" = args + ), + connection = con + ) # Wait for output to be received from server. repeat { output <- tryCatch( unserialize(connection = con), - error = identity) + error = identity + ) # Break from the loop if the output is not an error. if (!inherits(output, "error")) break @@ -213,7 +227,8 @@ socket_client_close_connection <- function(con) { socket_client_server_shutdown <- function( con = NULL, host = "localhost", - port = 6311) { + port = 6311L +) { if (!inherits(con, "sockconn")) { # Open a connection @@ -235,7 +250,8 @@ socket_client_server_shutdown <- function( # Signal the server to close the connection and shutdown. serialize( list("type" = "SHUTDOWN"), - connection = con) + connection = con + ) return(invisible(NULL)) } diff --git a/R/StringUtilities.R b/R/StringUtilities.R index 74b704a8..5257aebe 100644 --- a/R/StringUtilities.R +++ b/R/StringUtilities.R @@ -30,19 +30,21 @@ paste_s <- function(...) { # "element_1, element_2, ..., and element_n". dots <- c(...) - if (length(dots) > 2) { + if (length(dots) > 2L) { # For more than 2 elements, split into an initial and final section. initial_string <- paste0( - head(dots, n = length(dots) - 2), - collapse = ", ") + head(dots, n = length(dots) - 2L), + collapse = ", " + ) final_string <- paste0( - tail(dots, n = 2), - collapse = " and ") + tail(dots, n = 2L), + collapse = " and " + ) return(paste0(c(initial_string, final_string), collapse = ", ")) - } else if (length(dots) == 2) { + } else if (length(dots) == 2L) { # For exactly 2 elements, combine with "and". return(paste0(dots, collapse = " and ")) @@ -54,6 +56,22 @@ paste_s <- function(...) { +paste_sh <- function(..., n = 6L) { + # Function to collapse the first few elements of a series of strings into a + # summation of the form: "element_1, element_2, element_3, ..." + + dots <- c(...) + + # Check if all elements can be collapsed. + if (length(dots) <= n) return(paste_s(...)) + + initial_string <- paste0(head(dots, n = n), collapse = ", ") + + return(paste0(initial_string, ", ...")) +} + + + paste_c <- function(x, y, collapse = NULL) { # Create combinations of strings in x and y. str_combinations <- unlist(lapply(x, paste0, y, collapse = collapse)) @@ -63,12 +81,13 @@ paste_c <- function(x, y, collapse = NULL) { + rstring <- function(n = 1L, character_set = "alphanumeric") { # Initialise the available set. available_characters <- NULL # Sanity check on n. - if (n < 1) stop("n cannot be smaller than 1.") + if (n < 1L) stop("n cannot be smaller than 1.") # Uppercase characters if (character_set %in% c("uppercase", "alphanumeric", "letters")) { @@ -89,17 +108,19 @@ rstring <- function(n = 1L, character_set = "alphanumeric") { } # Draw random indices and convert to integer values by rounding up. - random_indices <- ceiling(stats::runif( + random_indices <- as.integer(ceiling(stats::runif( n = n, - min = 0, - max = length(available_characters))) + min = 0L, + max = length(available_characters) + ))) # Replaces any 0 (which is improbable, but could happen). - random_indices[random_indices == 0] <- 1 + random_indices[random_indices == 0L] <- 1L return(paste0( available_characters[random_indices], - collapse = "")) + collapse = "" + )) } @@ -112,7 +133,8 @@ startswith_any <- function(x, prefix) { any(startsWith(x = x, prefix = prefix)) }, prefix = prefix, - USE.NAMES = FALSE)) + USE.NAMES = FALSE + )) } @@ -125,7 +147,8 @@ endswith_any <- function(x, suffix) { any(endsWith(x = x, suffix = suffix)) }, suffix = suffix, - USE.NAMES = FALSE)) + USE.NAMES = FALSE + )) } @@ -138,7 +161,8 @@ sub_all_patterns <- function(pattern, replacement, x, ...) { x = x, replacement = replacement, pattern = current_pattern, - ...) + ... + ) } return(x) @@ -153,7 +177,8 @@ gsub_all_patterns <- function(pattern, replacement, x, ...) { x = x, replacement = replacement, pattern = current_pattern, - ...) + ... + ) } return(x) @@ -169,30 +194,32 @@ sub_last <- function(pattern, replacement, x, ...) { pattern = pattern, replacement = replacement, ..., - USE.NAMES = FALSE)) + USE.NAMES = FALSE + )) } .sub_last <- function(x, pattern, replacement, ...) { # Replace last instance of a pattern in x. - instances <- gregexpr(pattern = pattern, text = x, ...)[[1]] + instances <- gregexpr(pattern = pattern, text = x, ...)[[1L]] # Skip if pattern has not been found. - if (all(instances == -1)) return(x) + if (all(instances == -1L)) return(x) # Select last instance. instances <- tail(instances, n = 1L) # Replace the pattern with its replacement. - initial_string <- substr(x, start = 1L, instances - 1) + initial_string <- substr(x, start = 1L, instances - 1L) final_string <- substr(x, start = instances + nchar(pattern), stop = nchar(x)) return(paste0( initial_string, replacement, final_string, - collapse = "")) + collapse = "" + )) } @@ -205,10 +232,12 @@ strsplit_all <- function(x, split, ...) { return(strsplit( x = x, split = split, - ...)[[1]]) + ... + )[[1L]]) }, split = split, - ...) + ... + ) return(y) } diff --git a/R/TaskEvaluate.R b/R/TaskEvaluate.R new file mode 100644 index 00000000..20f80af3 --- /dev/null +++ b/R/TaskEvaluate.R @@ -0,0 +1,928 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + +# familiarTaskCollect ---------------------------------------------------------- +setClass( + "familiarTaskCollect", + contains = "familiarTask", + slots = list( + "data_file" = "character" + ), + prototype = methods::prototype( + data_file = NA_character_, + task_name = "collect_data" + ) +) + + + +# .set_file_name (collection task) --------------------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskCollect"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + name <- NULL + if (object@data_id == 1L && object@run_id == 1L) { + name <- "pooled" + } + + # Generate file name of the model. + object@file <- get_object_file_name( + object_type = "familiarCollection", + data_id = object@data_id, + run_id = object@run_id, + name = name, + project_id = object@project_id, + dir_path = file_paths$fam_coll_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (collection task) --------------------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskCollect"), + function(object, ...) { + return(paste0( + object@task_name, "_", + object@data_id, "_", + object@run_id + )) + } +) + + + +# .perform_task (collection task, NULL) ---------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskCollect", + data = "NULL" + ), + function( + object, + data, + return_results = TRUE, + ... + ) { + # Suppress NOTES due to non-standard evaluation in data.table + internal <- label_order <- NULL + + # Set collection name. + if (!is.na(object@data_id) && !is.na(object@run_id)) { + name <- NULL + if (object@data_id == 1L && object@run_id == 1L) { + name <- "pooled" + } + + # Generate file name of the model. + collection_name <- get_object_file_name( + object_type = "familiarCollection", + data_id = object@data_id, + run_id = object@run_id, + name = name, + project_id = object@project_id, + with_extension = FALSE + ) + + } else { + collection_name <- "collection" + } + + # Process collection. + collection_object <- suppressWarnings( + as_familiar_collection( + object = object@data_file, + collection_name = collection_name + ) + ) + + # Update labels of datasets, which affect how datasets are ordered in + # plots and tables. Labels are only updated and ordered when the internal + # naming system is used. + standard_names <- data.table::data.table( + "internal" = c("development", "internal_validation", "external_validation"), + "label" = c("development", "int. validation", "ext. validation"), + "label_order" = seq_len(3L) + ) + old_names <- get_data_set_names(collection_object) + if (all(old_names %in% standard_names$internal)) { + standard_names <- standard_names[internal %in% old_names][order(label_order)] + collection_object <- set_data_set_names( + x = collection_object, + old = standard_names$internal, + new = standard_names$label, + order = standard_names$label + ) + } + + if (!is.na(object@file)) { + saveRDS(collection_object, file = object@file) + } + + if (return_results) { + return(collection_object) + } + } +) + + + +# .perform_task (collection task, ANY) ----------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskCollect", + data = "ANY" + ), + function( + object, + data, + return_results = TRUE, + ... + ) { + # Process collection. + collection_object <- suppressWarnings( + as_familiar_collection( + object = data + ) + ) + + if (!is.na(object@file)) { + saveRDS(collection_object, file = object@file) + } + + if (return_results) { + return(collection_object) + } + + return(TRUE) + } +) + + + +# familiarTaskEvaluate --------------------------------------------------------- +setClass( + "familiarTaskEvaluate", + contains = "familiarTask", + slots = list( + "validation" = "logical", + "ensemble_data_id" = "integer", + "ensemble_run_id" = "integer", + "predict_data_id" = "integer", + "force_ensemble_detail_level" = "logical", + "vimp_method" = "character", + "learner" = "character", + "data_set_name" = "character", + "model_files" = "character" + ), + prototype = methods::prototype( + validation = NA, + # Ensemble data id and run ids are *only* used for generating unique file + # names. + ensemble_data_id = NA_integer_, + ensemble_run_id = NA_integer_, + # Whereas data_id describes where the overall data comes from, the + # ensemble_data_id describes where ensembles are formed. + predict_data_id = NA_integer_, + # If individual models do not have sufficient data to perform hybrid + # analysis (each model is used to compute part of the bootstraps when + # computing confidence intervals) for an evaluation step, that evaluation + # step may fail, even though over all models, sufficient data are present. + # In that case, we need to force an ensemble detail level. + force_ensemble_detail_level = FALSE, + vimp_method = NA_character_, + learner = NA_character_, + data_set_name = NA_character_, + model_files = NA_character_, + task_name = "evaluate" + ) +) + + + +# .set_file_name (evaluation task) --------------------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskEvaluate"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + # Generate file name of the model. + object@file <- get_object_file_name( + object_type = "familiarData", + data_id = object@data_id, + run_id = object@run_id, + ensemble_data_id = object@ensemble_data_id, + ensemble_run_id = object@ensemble_run_id, + learner = object@learner, + vimp_method = object@vimp_method, + name = object@data_set_name, + project_id = object@project_id, + dir_path = file_paths$fam_data_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (evaluation task) --------------------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskEvaluate"), + function(object, ...) { + return(paste0( + object@task_name, "_", + object@data_id, "_", + object@run_id, "_", + object@ensemble_data_id, "_", + object@ensemble_run_id, "_", + object@vimp_method, "_", + object@learner, "_", + object@data_set_name + )) + } +) + + + +# .perform_task (evaluation task , NULL) -------------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskEvaluate", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("experiment_data is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Set up a dataObject that allows for delayed loading. Importantly, we set + # run_id to NA_integer_. This allows for loading the data based on the + # context provided by data_id and the ensemble or its underlying models. + data <- methods::new( + "delayedDataObject", + data = NULL, + data_id = object@predict_data_id, + run_id = NA_integer_, + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info, + validation = object@validation, + aggregate_on_load = FALSE + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + + + +# .perform_task (evaluation task, dataObject) ---------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskEvaluate", + data = "dataObject" + ), + function( + object, + data, + settings, + cl = NULL, + message_indent = 0L, + verbose = FALSE, + return_results = TRUE, + ... + ) { + # Prevent notes. + n <- data_id <- NULL + + # Signal evaluation start for the current task. + logger_message( + paste0( + "Evaluation: Starting evaluation for the \"", object@learner, + "\" learner and the \"", object@vimp_method, + "\" variable importance method for ", + object@data_set_name, " data (data_id: ", + object@data_id, "; run_id: ", object@run_id, + "). This is task ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + # Form an ensemble using the associated or provided models. + + # Check which detail level should be provided based on the number of + # available instances for each model. + fam_ensemble <- methods::new( + "familiarEnsemble", + model_list = as.list(object@model_files), + learner = object@learner, + vimp_method = object@vimp_method, + data_id = object@data_id, + run_id = object@run_id + ) + + # Add package version. + fam_ensemble <- add_package_version(object = fam_ensemble) + + # Load models and prevent auto-detaching. + fam_ensemble <- load_models( + object = fam_ensemble, + suppress_auto_detach = TRUE + ) + + # Create a run table. Select only the runs that consistently appear for + # all models. + run_table <- data.table::rbindlist(lapply( + fam_ensemble@model_list, + function(fam_model) fam_model@run_table) + ) + + # Count how many times each run appears. Run tables can start bifurcating + # for underlying models, e.g. through bootstraps. + run_table <- run_table[, list("n" = .N), by = eval(colnames(run_table))] + fam_ensemble@run_table <- run_table[n == length(fam_ensemble@model_list)][order(data_id)] + + # Complete the ensemble using information provided by the model + fam_ensemble <- complete_familiar_ensemble( + object = fam_ensemble, + message_indent = message_indent + 1L, + verbose = verbose + ) + + # Set evaluation level. + detail_level <- settings$eval$detail_level + if (object@force_ensemble_detail_level) { + detail_level <- "ensemble" + } + + # Compute evaluation data. + evaluation_data <- extract_data( + object = fam_ensemble, + data = data, + cl = cl, + data_element = settings$eval$evaluation_data_elements, + time_max = settings$eval$time_max, + evaluation_times = settings$eval$eval_times, + sample_limit = settings$eval$sample_limit, + n_important_features = settings$eval$n_important_features, + detail_level = detail_level, + estimation_type = settings$eval$estimation_type, + aggregate_results = settings$eval$aggregate_results, + aggregation_method = settings$eval$aggregation, + rank_threshold = settings$eval$aggr_rank_threshold, + ensemble_method = settings$eval$ensemble_method, + stratification_method = settings$eval$strat_method, + metric = settings$eval$metric, + feature_cluster_method = settings$eval$feature_cluster_method, + feature_cluster_cut_method = settings$eval$feature_cluster_cut_method, + feature_linkage_method = settings$eval$feature_linkage_method, + feature_similarity_metric = settings$eval$feature_similarity_metric, + feature_similarity_threshold = settings$eval$feature_similarity_threshold, + sample_cluster_method = settings$eval$sample_cluster_method, + sample_linkage_method = settings$eval$sample_linkage_method, + sample_similarity_metric = settings$eval$sample_similarity_metric, + confidence_level = settings$eval$confidence_level, + bootstrap_ci_method = settings$eval$bootstrap_ci_method, + dynamic_model_loading = settings$eval$auto_detach, + icc_type = settings$eval$icc_type, + message_indent = message_indent + 1L, + verbose = verbose + ) + + # Add additional details. + evaluation_data@name <- object@data_set_name + evaluation_data@project_id <- object@project_id + + if (!is.na(object@file)) { + saveRDS(evaluation_data, file = object@file) + } + + if (return_results) { + return(evaluation_data) + } + + return(TRUE) + } +) + + + +.generate_evaluation_tasks <- function( + experiment_data, + vimp_methods, + learners, + file_paths, + pool_only, + skip_existing = FALSE, + ... +) { + + # Suppress NOTES due to non-standard evaluation in data.table + train <- internal_validation <- external_validation <- NULL + can_pre_process <- perturbation_level <- main_data_id <- NULL + data_id <- run_id <- NULL + + # collection tasks ----------------------------------------------------------- + # Always created the top-layer pooled collection. + collect_task_list <- list( + methods::new( + "familiarTaskCollect", + data_id = 1L, + run_id = 1L, + project_id = experiment_data@project_id + ) + ) + + # Find the data_id related to ensembling of models. + train_data_id <- experiment_data@experiment_setup[train == TRUE, ]$main_data_id[1L] + internal_validation_data_id <- experiment_data@experiment_setup[internal_validation == TRUE, ]$main_data_id[1L] + external_validation_data_id <- experiment_data@experiment_setup[external_validation == TRUE, ]$main_data_id[1L] + + # If there is no train data id, we have an issue. + if (is.na(train_data_id)) return(NULL) + + # Determine which parts of the experiment can be used for internal validation.. + run_table <- .get_run_table_from_experiment_setup( + data_id = train_data_id, + experiment_setup = experiment_data@experiment_setup + ) + + if (!pool_only && !is.na(internal_validation_data_id)) { + # Determine the collections at the last experimental level that can + # pre-process and is part of the model-building branch. + collection_run_ids <- seq_len(run_table[main_data_id == internal_validation_data_id]$n_runs[1L]) + + ii <- 2L + for (run_id in collection_run_ids) { + collect_task_list[[ii]] <- methods::new( + "familiarTaskCollect", + task_id = ii + 1L, + data_id = internal_validation_data_id, + run_id = run_id, + project_id = experiment_data@project_id + ) + + ii <- ii + 1L + } + } + + # evaluation tasks ----------------------------------------------------------- + + n_min_model_instances <- Inf + + # External validation: the top level has associated validation data. + if (!is.na(external_validation_data_id)) { + n_min_model_instances <- min( + c(experiment_data@experiment_setup[main_data_id == external_validation_data_id]$max_validation_instances), + n_min_model_instances + ) + } + + # Internal validation: the lowest model ensembling level has associated + # validation data. + if (!is.na(internal_validation_data_id)) { + n_min_model_instances <- min( + c(experiment_data@experiment_setup[main_data_id == internal_validation_data_id]$max_validation_instances), + n_min_model_instances + ) + } + + # Development data: the lowest model ensembling level has associated + # development data. NOTE: this should always be the case. + if (!is.na(train_data_id)) { + n_min_model_instances <- min( + c(experiment_data@experiment_setup[main_data_id == train_data_id]$max_training_instances), + n_min_model_instances + ) + } + + # Check model instances and determine if we need to force ensemble detail + # level for evaluation. + force_ensemble_detail_level <- n_min_model_instances < 10L + + # Then select the run-tables which contain this data_id as their final + # (bottom) level. + run_tables <- .collect_run_tables(iteration_list = experiment_data@iteration_list) + run_tables <- run_tables[sapply( + run_tables, + function(x, data_id) { + return (tail(x, n = 1L)$data_id == data_id) + }, + data_id = train_data_id + )] + + # Use collection tasks to set up the evaluation tasks, including for internal + # validation. + evaluate_task_list <- list() + ii <- 1L + + for (jj in seq_along(collect_task_list)) { + + # Select run tables where the ensemble data and run identifiers appear. + selected_run_tables <- run_tables[ + sapply( + X = run_tables, + FUN = function(x, task_data_id, task_run_id) { + return(!is_empty(x[data_id == task_data_id & run_id == task_run_id])) + }, + task_data_id = collect_task_list[[jj]]@data_id, + task_run_id = collect_task_list[[jj]]@run_id + ) + ] + + # Initialise file names. + data_file_names <- NULL + for (learner in learners) { + for (vimp_method in vimp_methods) { + + # Set model files. + model_files <- unname(sapply( + selected_run_tables, + function(x, ...) { + get_object_file_name( + object_type = "familiarModel", + data_id = tail(x, n = 1L)$data_id, + run_id = tail(x, n = 1L)$run_id, + ... + ) + }, + learner = learner, + vimp_method = vimp_method, + project_id = experiment_data@project_id, + dir_path = file_paths$mb_dir + )) + + ## external validation ------------------------------------------------- + + if (!is.na(external_validation_data_id)) { + # Initialise task. + evaluate_task <- methods::new( + "familiarTaskEvaluate", + data_id = external_validation_data_id, + run_id = 1L, + validation = TRUE, + ensemble_data_id = collect_task_list[[jj]]@data_id, # Only used for naming. + ensemble_run_id = collect_task_list[[jj]]@run_id, # Only used for naming. + predict_data_id = external_validation_data_id, # Determines which data are dynamically loaded. + force_ensemble_detail_level = force_ensemble_detail_level, + learner = learner, + vimp_method = vimp_method, + model_files = model_files, + data_set_name = "external_validation", + project_id = experiment_data@project_id + ) + + # Set file name. + evaluate_task <-.set_file_name( + object = evaluate_task, + file_paths = file_paths + ) + + # Make task and associated file names available. + data_file_names <- c(data_file_names, evaluate_task@file) + evaluate_task_list[[ii]] <- evaluate_task + + ii <- ii + 1L + } + + # internal validation -------------------------------------------------- + + if (!is.na(internal_validation_data_id)) { + # Initialise task. + evaluate_task <- methods::new( + "familiarTaskEvaluate", + data_id = collect_task_list[[jj]]@data_id, + run_id = collect_task_list[[jj]]@run_id, + validation = TRUE, + ensemble_data_id = collect_task_list[[jj]]@data_id, + ensemble_run_id = collect_task_list[[jj]]@run_id, + predict_data_id = internal_validation_data_id, + force_ensemble_detail_level = force_ensemble_detail_level, + learner = learner, + vimp_method = vimp_method, + model_files = model_files, + data_set_name = "internal_validation", + project_id = experiment_data@project_id + ) + + # Set file name. + evaluate_task <-.set_file_name( + object = evaluate_task, + file_paths = file_paths + ) + + # Make task and associated file names available. + data_file_names <- c(data_file_names, evaluate_task@file) + evaluate_task_list[[ii]] <- evaluate_task + + ii <- ii + 1L + } + + # development ---------------------------------------------------------- + + if (!is.na(train_data_id)) { + # Initialise task. + evaluate_task <- methods::new( + "familiarTaskEvaluate", + data_id = collect_task_list[[jj]]@data_id, + run_id = collect_task_list[[jj]]@run_id, + validation = FALSE, + ensemble_data_id = collect_task_list[[jj]]@data_id, + ensemble_run_id = collect_task_list[[jj]]@run_id, + predict_data_id = train_data_id, + force_ensemble_detail_level = force_ensemble_detail_level, + learner = learner, + vimp_method = vimp_method, + model_files = model_files, + data_set_name = "development", + project_id = experiment_data@project_id + ) + + # Set file name. + evaluate_task <-.set_file_name( + object = evaluate_task, + file_paths = file_paths + ) + + # Make task and associated file names available. + data_file_names <- c(data_file_names, evaluate_task@file) + evaluate_task_list[[ii]] <- evaluate_task + + ii <- ii + 1L + + } else { + ..error_reached_unreachable_code("development data are always present.") + } + } + } + + # Update collection tasks by adding file paths to + collect_task_list[[jj]]@data_file <- data_file_names + collect_task_list[[jj]] <- .set_file_name( + object = collect_task_list[[jj]], + file_paths = file_paths + ) + } + + # train and variable importance tasks ---------------------------------------- + task_list <- .generate_trainer_tasks( + experiment_data = experiment_data, + learners = learners, + vimp_methods = vimp_methods, + file_paths = file_paths, + skip_existing = skip_existing, + ... + ) + + return(c( + task_list, + evaluate_task_list, + collect_task_list + )) +} + + + +.run_evaluation <- function( + cl, + tasks, + message_indent = 0L, + verbose, + ... +) { + + # Check that any tasks are available for processing. + if (is_empty(tasks$evaluate) || is_empty(tasks$collect)) return(invisible(FALSE)) + + # Determine which evaluation tasks need to be performed. + finished_tasks <- sapply(tasks$evaluate, .file_exists) + unfinished_tasks <- tasks$evaluate[!finished_tasks] + finished_tasks <- tasks$evaluate[finished_tasks] + + # Process any unfinished tasks. + if (length(unfinished_tasks) > 0L) { + ..run_evaluation( + cl = cl, + tasks = unfinished_tasks, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + # Determine which collection tasks are required. + finished_tasks <- sapply(tasks$collect, .file_exists) + unfinished_tasks <- tasks$collect[!finished_tasks] + finished_tasks <- tasks$collect[finished_tasks] + + # Process any unfinished tasks. + if (length(unfinished_tasks) > 0L) { + ..run_collection( + tasks = unfinished_tasks, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + return(invisible(TRUE)) +} + + + +..run_evaluation <- function( + tasks, + cl, + settings, + message_indent = 0L, + verbose, + ... +) { + + # Message that evaluation is starting. + logger_message( + paste0( + "Evaluation: Starting model evaluation." + ), + indent = message_indent, + verbose = verbose + ) + + # Set outer vs. inner loop parallelisation. + if (settings$eval$do_parallel %in% c("TRUE", "inner")) { + cl_inner <- cl + cl_outer <- NULL + + } else if (settings$eval$do_parallel %in% c("outer")) { + cl_inner <- NULL + cl_outer <- cl + + logger_message( + paste0( + "Evaluation: Parallel processing is done in the outer loop. ", + "No progress can be displayed." + ), + indent = message_indent, + verbose = verbose && !is.null(cl_outer) + ) + + } else { + cl_inner <- cl_outer <- NULL + } + + fam_mapply_lb( + cl = cl_outer, + assign = "all", + FUN = .perform_task, + progress_bar = !is.null(cl_outer), + object = tasks, + MoreArgs = list( + "data" = NULL, + "return_results" = FALSE, + "settings" = settings, + "message_indent" = message_indent + 1L, + "verbose" = verbose && is.null(cl_outer), + "cl" = cl_inner, + ... + ) + ) + + # Message that models were evaluated. + logger_message( + paste0( + "Evaluation: Models were evaluated.\n" + ), + indent = message_indent, + verbose = verbose + ) +} + + + +..run_collection <- function( + tasks, + message_indent = 0L, + verbose, + ... +) { + + # Message that evaluation is starting. + logger_message( + paste0( + "Evaluation: Starting collection of evaluation datasets." + ), + indent = message_indent, + verbose = verbose + ) + + fam_mapply_lb( + cl = NULL, + assign = "all", + FUN = .perform_task, + progress_bar = verbose, + object = tasks, + MoreArgs = list( + "data" = NULL, + "return_results" = FALSE, + "message_indent" = message_indent + 1L, + "verbose" = verbose, + ... + ) + ) + + # Message that variable importances have been computed. + logger_message( + paste0( + "Evaluation: Evaluation datasets were collected.\n" + ), + indent = message_indent, + verbose = verbose + ) +} + + + +.run_export <- function( + tasks, + message_indent = 0L, + verbose, + file_paths +) { + # Message start of export. + logger_message( + paste0( + "Export: exporting collected evaluation data to plots and tables." + ), + indent = message_indent, + verbose = verbose + ) + + for (task in tasks$collect) { + # Set path for directory where data are exported to. + dir_path <- file.path( + file_paths$results_dir, + tools::file_path_sans_ext(basename(task@file)) + ) + + # Load collection locally. + fam_collection <- load_familiar_object(task@file) + + # Export tables. + export_all( + object = fam_collection, + dir_path = dir_path + ) + + # Export plots. + plot_all( + object = fam_collection, + dir_path = dir_path + ) + } + + logger_message( + paste0( + "Export: all plots and tables were exported to ", + file_paths$results_dir, + ".\n" + ), + indent = message_indent, + verbose = verbose + ) +} diff --git a/R/TaskFeatureInfo.R b/R/TaskFeatureInfo.R new file mode 100644 index 00000000..0047cdb9 --- /dev/null +++ b/R/TaskFeatureInfo.R @@ -0,0 +1,625 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + +# familiarTaskGenericFeatureInfo ----------------------------------------------- +setClass( + "familiarTaskGenericFeatureInfo", + contains = "familiarTask", + prototype = methods::prototype( + task_name = "create_generic_feature_info", + data_id = 1L, + run_id = 1L + ) +) + + +# .set_file_name (generic feature info task) ----------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskGenericFeatureInfo"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + # Generate file name of pre-processing file + object@file <- get_object_file_name( + object_type = "genericFeatureInfo", + project_id = object@project_id, + dir_path = file_paths$process_data_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (generic feature info task) ----------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskGenericFeatureInfo"), + function(object, ...) { + return(object@task_name) + } +) + + + +# .perform_task (generic feature info task, NULL) ------------------------------ +setMethod( + ".perform_task", + signature( + object = "familiarTaskGenericFeatureInfo", + data = "NULL" + ), + function( + object, + data, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to .perform_task for dataObject. + return(.perform_task( + object = object, + data = data, + ... + )) + } +) + + + +# .perform_task (generic feature info task, dataObject) ------------------------ +setMethod( + ".perform_task", + signature( + object = "familiarTaskGenericFeatureInfo", + data = "dataObject" + ), + function( + object, + data, + descriptor = NULL, + experiment_data = NULL, + return_results = TRUE, + ... + ) { + + # Check if the desired data already exist elsewhere. + results_exist <- FALSE + + if (is(experiment_data, "experimentData")) { + if (!is_empty(experiment_data@feature_info[["generic"]])) { + feature_info_list <- experiment_data@feature_info[["generic"]] + results_exist <- TRUE + } + } + + if (file.exists(object@file)) { + feature_info_list <- update_object(object = readRDS(object@file)) + results_exist <- TRUE + } + + if (results_exist) { + if (!is.na(object@file)) { + saveRDS(feature_info_list, file = object@file) + } + + if (return_results) { + return(feature_info_list) + } + + return(TRUE) + } + + # If this point is reached, results will be created de novo. + # Extract basic feature information from the data. + feature_info_list <- .get_generic_feature_info( + data = data, + outcome_type = data@outcome_type, + descriptor = descriptor, + project_id = object@project_id + ) + + # Write to file or return. + if (!is.na(object@file)) { + saveRDS(feature_info_list, file = object@file) + } + + if (return_results) { + return(feature_info_list) + } + + return(TRUE) + } +) + + + +# .get_feature_info_list (generic feature info task) --------------------------- +setMethod( + ".get_feature_info_list", + signature(object = "familiarTaskGenericFeatureInfo"), + function(object, feature_info_list, ...) { + ..error_reached_unreachable_code(".get_feature_info_list does not exist for this task") + } +) + + + +# familiarTaskFeatureInfo ------------------------------------------------------ +setClass( + "familiarTaskFeatureInfo", + contains = "familiarTask", + prototype = methods::prototype( + task_name = "create_feature_info" + ) +) + + + +# .set_file_name (feature info task) ------------------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskFeatureInfo"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + # Generate file name of pre-processing file + object@file <- get_object_file_name( + object_type = "featureInfo", + project_id = object@project_id, + data_id = object@data_id, + run_id = object@run_id, + dir_path = file_paths$process_data_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (feature info task) ------------------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskFeatureInfo"), + function(object, ...) { + return(paste0(object@task_name, "_", object@data_id, "_", object@run_id)) + } +) + + + +# .perform_task (feature info task , NULL) ------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskFeatureInfo", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("project_info is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Find the run list. + run_list <- .get_run_list( + iteration_list = experiment_data@iteration_list, + data_id = object@data_id, + run_id = object@run_id + ) + + # Select unique samples. + sample_identifiers <- .get_sample_identifiers( + run = run_list, + train_or_validate = "train" + ) + sample_identifiers <- unique(sample_identifiers) + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(sample_identifiers = sample_identifiers), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + +# .perform_task (feature info task, dataObject) -------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskFeatureInfo", + data = "dataObject" + ), + function( + object, + data, + experiment_data = NULL, + settings = NULL, + feature_info_list = NULL, + message_indent = 0L, + verbose = FALSE, + cl = NULL, + signature_features = NULL, + novelty_features = NULL, + fairness_features = NULL, + return_results = TRUE, + ... + ) { + logger_message( + paste0( + "Pre-processing: Starting preprocessing for run ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + + # Check if the desired data already exist elsewhere. + results_exist <- FALSE + + if (is(experiment_data, "experimentData")) { + if (!is_empty(experiment_data@feature_info[[paste0(object@data_id, ".", object@run_id)]])) { + feature_info_list <- experiment_data@feature_info[[paste0(object@data_id, ".", object@run_id)]] + results_exist <- TRUE + } + } + + if (file.exists(object@file)) { + feature_info_list <- update_object(object = readRDS(object@file)) + results_exist <- TRUE + } + + if (results_exist) { + if (!is.na(object@file)) { + saveRDS(feature_info_list, file = object@file) + } + + if (return_results) { + return(feature_info_list) + } + + return(TRUE) + } + + # Check that a feature info list is provided, otherwise create an ad-hoc + # list as an template. + if (is.null(feature_info_list)) { + # Set up task, and explicitly don't write to file. + generic_feature_info_task <- methods::new( + "familiarTaskGenericFeatureInfo", + project_id = object@project_id, + file = NA_character_ + ) + + # Execute the task. + feature_info_list <- .perform_task( + object = generic_feature_info_task, + data = data + ) + } + + # Add workflow control info. + feature_info_list <- add_control_info( + feature_info_list = feature_info_list, + data_id = object@data_id, + run_id = object@run_id, + project_id = object@project_id + ) + + # Add signature feature info. + if (is.null(signature_features)) signature_features <- settings$data$signature + feature_info_list <- add_signature_info( + feature_info_list = feature_info_list, + signature = signature_features + ) + + # Add novelty feature info. + if (is.null(novelty_features)) novelty_features <- settings$data$novelty_features + feature_info_list <- add_novelty_info( + feature_info_list = feature_info_list, + novelty_features = novelty_features + ) + + # Add fairness feature info. + if (is.null(fairness_features)) fairness_features <- settings$data$fairness_features + feature_info_list <- add_fairness_info( + feature_info_list = feature_info_list, + fairness_features = fairness_features + ) + + # Find currently available features. + available_features <- get_available_features(feature_info_list = feature_info_list) + + # Remove unavailable features from the data object. + data <- filter_features( + data = data, + available_features = available_features + ) + + # Use data to determine pre-processing parameters. + feature_info_list <- .determine_preprocessing_parameters( + cl = cl, + data = data, + feature_info_list = feature_info_list, + settings = settings, + message_indent = message_indent + 1L, + verbose = verbose + ) + + if (!is.na(object@file)) { + saveRDS(feature_info_list, file = object@file) + } + + if (return_results) { + return(feature_info_list) + } + + return(TRUE) + } +) + + + +# .get_feature_info_list (feature info task) ----------------------------------- +setMethod( + ".get_feature_info_list", + signature(object = "familiarTaskFeatureInfo"), + function(object, feature_info_list, ...) { + ..error_reached_unreachable_code(".get_feature_info_list does not exist for this task") + } +) + + +# .get_variable_importance_table (feature info task) --------------------------- +setMethod( + ".get_variable_importance_table", + signature(object = "familiarTaskFeatureInfo"), + function( + object, + ... + ) { + ..error_reached_unreachable_code(".get_variable_importance_table does not exist for this task") + } +) + + +.generate_data_preprocessing_tasks <- function( + data_ids, + run_ids, + file_paths, + project_id, + skip_existing = FALSE + ) { + task_list <- list() + + # Create task to generic feature_info. + generic_info_task <- methods::new( + "familiarTaskGenericFeatureInfo", + project_id = project_id + ) + + # Add file names. + generic_info_task <- .set_file_name( + object = generic_info_task, + file_paths = file_paths + ) + + # Add to list, if the file does not exist on disk. + if (!skip_existing || !.file_exists(generic_info_task)) { + task_list[[1L]] <- generic_info_task + } + + ii <- 2L + for (data_id in data_ids) { + for (run_id in run_ids) { + # Create task to generate run-specific feature info. + run_info_task <- methods::new( + "familiarTaskFeatureInfo", + data_id = data_id, + run_id = run_id, + project_id = project_id + ) + + # Add file names. + run_info_task <- .set_file_name( + object = run_info_task, + file_paths = file_paths + ) + + # Add to list, if the file does not exist on disk. + if (!skip_existing || !.file_exists(run_info_task)) { + task_list[[ii]] <- run_info_task + ii <- ii + 1L + } + } + } + + return(task_list) +} + + + +.run_preprocessing <- function( + tasks, + experiment_data, + ... +) { + + # Suppress NOTES due to non-standard evaluation in data.table + data_id <- run_id <- list_name <- complete <- NULL + + # Create or load generic feature info. + if (!is_empty(tasks$generic_feature_info)) { + if (!.file_exists(tasks$generic_feature_info[[1L]])) { + generic_feature_info <- .perform_task( + object = tasks$generic_feature_info[[1L]], + data = NULL, + experiment_data = experiment_data, + ... + ) + + } else { + generic_feature_info <- readRDS(tasks$generic_feature_info[[1L]]@file) + } + + } else { + generic_feature_info <- NULL + } + + # Check that any feature info tasks are required. + if (is_empty(tasks$feature_info)) return(invisible(FALSE)) + + # Determine which feature info objects need to be obtained. + finished_tasks <- sapply(tasks$feature_info, .file_exists) + unfinished_tasks <- tasks$feature_info[!finished_tasks] + finished_tasks <- tasks$feature_info[finished_tasks] + + # Process any unfinished tasks. + if (length(unfinished_tasks) > 0L) { + ..run_preprocessing( + tasks = unfinished_tasks, + generic_feature_info = generic_feature_info, + experiment_data = experiment_data, + ... + ) + } + + # Load processed data from files. + feature_info_list <- lapply( + tasks$feature_info, + function(x) (readRDS(x@file)) + ) + + # Set names. + names(feature_info_list) <- sapply( + tasks$feature_info, + function(x) (paste0(x@data_id, ".", x@run_id)) + ) + + # Attach generic feature information. + feature_info_list[["generic"]] <- generic_feature_info + + # Attach feature preprocessing information to the backend. + .assign_feature_info_to_backend(feature_info_list = feature_info_list) + + return(invisible(TRUE)) +} + + + +..run_preprocessing <- function( + tasks, + generic_feature_info, + settings, + cl, + message_indent = 0L, + verbose, + ... +) { + logger_message( + paste0( + "Pre-processing: Start identifying data processing parameters." + ), + indent = message_indent, + verbose = verbose + ) + + # Determine how parallel processing takes place. + if (settings$prep$do_parallel %in% c("TRUE", "inner")) { + # Parallel processing in inner function, i.e. within each data subset. + cl_inner <- cl + cl_outer <- NULL + + } else if (settings$prep$do_parallel %in% c("outer")) { + # Parallel processing in outer loop, i.e. over all data subsets. + cl_inner <- NULL + cl_outer <- cl + + if (!is.null(cl_outer)) { + logger_message( + paste0( + "Pre-processing: Load-balanced parallel processing is done in the outer loop. ", + "No progress can be displayed." + ), + indent = message_indent, + verbose = verbose + ) + } + + } else { + # No parallel processing. + cl_inner <- cl_outer <- NULL + } + + # Iterate over data subsets for which parameters have not yet been set. + fam_mapply_lb( + cl = cl_outer, + assign = "data", + FUN = .perform_task, + progress_bar = !is.null(cl_outer), + object = tasks, + MoreArgs = list( + "cl" = cl_inner, + "data" = NULL, + "feature_info_list" = generic_feature_info, + "settings" = settings, + "message_indent" = message_indent + 1L, + "verbose" = verbose && is.null(cl_outer), + "return_results" = FALSE, + ... + ) + ) + + logger_message( + paste0( + "Pre-processing: Completed identifying data processing parameters.", + "\n" + ), + indent = message_indent, + verbose = verbose + ) + + return(invisible(TRUE)) +} diff --git a/R/TaskLearn.R b/R/TaskLearn.R new file mode 100644 index 00000000..d401ea86 --- /dev/null +++ b/R/TaskLearn.R @@ -0,0 +1,643 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# familiarTaskTrain ------------------------------------------------------------- +setClass( + "familiarTaskTrain", + contains = "familiarTask", + slots = list( + "vimp_method" = "character", + "learner" = "character", + "vimp_table_file" = "character", + "hyperparameter_file" = "character", + "feature_info_file" = "character" + ), + prototype = methods::prototype( + vimp_method = NA_character_, + learner = NA_character_, + vimp_table_file = NA_character_, + hyperparameter_file = NA_character_, + feature_info_file = NA_character_, + task_name = "train_model" + ) +) + + + +# .set_file_name (train task) -------------------------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskTrain"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + # Generate file name of the model. + object@file <- get_object_file_name( + object_type = "familiarModel", + data_id = object@data_id, + run_id = object@run_id, + learner = object@learner, + vimp_method = object@vimp_method, + project_id = object@project_id, + dir_path = file_paths$mb_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (train task) -------------------------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskTrain"), + function(object, ...) { + return(paste0( + object@task_name, "_", + object@data_id, "_", + object@run_id, "_", + object@vimp_method, "_", + object@learner + )) + } +) + + + +# .perform_task (train task , NULL) -------------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskTrain", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("experiment_data is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Find the run list. + run_list <- .get_run_list( + iteration_list = experiment_data@iteration_list, + data_id = object@data_id, + run_id = object@run_id + ) + + # Select unique samples. + sample_identifiers <- .get_sample_identifiers( + run = run_list, + train_or_validate = "train" + ) + sample_identifiers <- unique(sample_identifiers) + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(sample_identifiers = sample_identifiers), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + +# .perform_task (train task, dataObject) --------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskTrain", + data = "dataObject" + ), + function( + object, + data, + vimp_aggregation_method = NULL, + vimp_rank_threshold = NULL, + settings = NULL, + feature_info_list = NULL, + vimp_table = NULL, + hyperparameters = NULL, + novelty_detector = NULL, + detector_parameters = NULL, + message_indent = 0L, + verbose = FALSE, + cl = NULL, + return_results = TRUE, + ... + ) { + logger_message( + paste0( + "Training: Starting model training for the \"", object@learner, + "\" learner and the \"", object@vimp_method, + "\" variable importance method for run ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + + # Check that outcome_info is present on data + if (!is(data@outcome_info, "outcomeInfo")) { + ..error_reached_unreachable_code( + "outcome_info attribute of data (dataObject) does not contain an outcomeInfo object" + ) + } + + # Set vimp aggregation method and vimp_rank_threshold based on settings. + if (!is.null(settings)) { + if (is.null(vimp_aggregation_method)) { + vimp_aggregation_method <- settings$vimp$aggregation + } + if (is.null(vimp_rank_threshold)) { + vimp_rank_threshold <- settings$vimp$aggr_rank_threshold + } + } + + # Check and retrieve feature info list. + feature_info_list <- .get_feature_info_list( + object = object, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # Check and retrieve hyperparameters. We do this prior to retrieving the + # variable importance tables, as these may be attached to hyperparameter + # object. + hyperparameters <- .get_hyperparameters( + object = object, + hyperparameters = hyperparameters, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + if (is_empty(hyperparameters$vimp_table)) { + # Check and retrieve variable importances from the drive, or generate in + # place, if the hyperparameter object did not contain a variable + # importance table. + vimp_table <- .get_variable_importance_table( + object = object, + vimp_table = vimp_table, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + } else { + vimp_table <- hyperparameters$vimp_table + } + + # Create the raw model object for training. + model_object <- methods::new( + "familiarModel", + outcome_type = data@outcome_type, + hyperparameters = hyperparameters$hyperparameters, + hyperparameter_data = hyperparameters$hyperparameter_data, + vimp_method = object@vimp_method, + vimp_table = vimp_table, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + learner = object@learner, + feature_info = feature_info_list, + outcome_info = data@outcome_info, + data_id = object@data_id, + run_id = object@run_id, + run_table = .get_current_run_table(object = object), + settings = settings$eval, + project_id = object@project_id + ) + + # Select features based on variable importances. + model_object <- set_model_features( + object = model_object, + minimise_footprint = FALSE + ) + + # Train model. + model_object <- .train( + object = model_object, + data = data, + get_additional_info = TRUE, + ... + ) + + # Set up task to train novelty detector + detector_task <- methods::new( + "familiarTaskTrainNovelty", + learner = novelty_detector, + vimp_method = object@vimp_method, + data_id = object@data_id, + run_id = object@run_id, + project_id = object@project_id + ) + + # Train novelty detector and add to model. + model_object@novelty_detector <- .perform_task( + object = detector_task, + data = data, + selected_features = features_after_clustering( + features = model_object@novelty_features, + feature_info_list = feature_info_list), + settings = settings, + feature_info_list = feature_info_list, + vimp_table = vimp_table, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + hyperparameters = detector_parameters, + return_results = TRUE + ) + + # Add model name + model_object <- set_object_name(model_object) + + if (!is.na(object@file)) { + saveRDS(model_object, file = object@file) + } + + if (return_results) { + return(model_object) + } + + return(TRUE) + } +) + + + +# .get_hyperparameters (train task) -------------------------------------------- +setMethod( + ".get_hyperparameters", + signature(object = "familiarTaskTrain"), + function( + object, + hyperparameters, + file_paths = NULL, + ... + ) { + # Suppress NOTES due to non-standard evaluation in data.table + can_pre_process <- NULL + + hyperparameter_object <- NULL + if (is.null(hyperparameters) && !is.null(object@run_table)) { + # This routine loads hyperparameters from disk, and is used when an + # experiment is run using summon_familiar. + + # This check exists to make sure that the standard workflow passes the + # correct objects. + if (is.null(file_paths)) { + ..error_reached_unreachable_code("file_paths was expected, but not provided.") + } + + # Find the last entry on the run table that is marked as available for + # pre-processing. This is what hyperparameters are based on. + hyperparameter_run <- tail( + object@run_table[[paste0(object@data_id, ".", object@run_id)]][can_pre_process == TRUE, ], + n = 1L + ) + + # Find the file name. + hyperparameter_file <- get_object_file_name( + project_id = object@project_id, + data_id = hyperparameter_run$data_id[1L], + run_id = hyperparameter_run$run_id[1L], + learner = object@learner, + vimp_method = object@vimp_method, + object_type = "hyperparametersLearner", + dir_path = file_paths$mb_dir + ) + + if (file.exists(hyperparameter_file)) { + hyperparameter_object <- update_object(readRDS(hyperparameter_file)) + } + } + + + if (is.null(hyperparameter_object) && is.na(object@hyperparameter_file)) { + # Create an ad-hoc list of hyperparameters + + # Set up task, and explicitly don't write to file. + hyperparameter_task <- methods::new( + "familiarTaskLearnerHyperparameters", + project_id = object@project_id, + vimp_method = object@vimp_method, + learner = object@learner, + file = NA_character_ + ) + + # Execute the task. + hyperparameter_object <- .perform_task( + object = hyperparameter_task, + hyperparameters = hyperparameters, + ... + ) + + } else if (is.null(hyperparameter_object)) { + # Assume that the hyperparameter_file attribute contains the path to the + # file containing the vimp method hyperparameters. + if (!file.exists(object@hyperparameter_file)) { + ..error(paste0("hyperparameter file does not exist at location: ", object@hyperparameter_file)) + } + hyperparameter_object <- update_object(readRDS(object@hyperparameter_file)) + + } else if (is.character(hyperparameters)) { + # If hyperparameters is a string, interpret this as a path to the + # file containing the vimp method hyperparameters. + if (!file.exists(hyperparameters)) { + ..error(paste0("hyperparameter file does not exist at location: ", hyperparameters)) + } + hyperparameter_object <- update_object(readRDS(hyperparameters)) + } + + if (is(hyperparameter_object, "familiarModel")) { + hyperparameters <- list( + "hyperparameters" = hyperparameter_object@hyperparameters, + "hyperparameter_data" = hyperparameter_object@hyperparameter_data, + "vimp_table" = hyperparameter_object@vimp_table + ) + + } else { + hyperparameters <- list("hyperparameters" = hyperparameters) + } + + return(hyperparameters) + } +) + + + +.generate_trainer_tasks <- function( + experiment_data, + optimisation_determine_vimp, + vimp_methods, + learners, + file_paths, + skip_existing = FALSE +) { + # Suppress NOTES due to non-standard evaluation in data.table + train <- main_data_id <- can_pre_process <- vimp <- NULL + + # Find the data_id related to model training. + data_id <- experiment_data@experiment_setup[train == TRUE, ]$main_data_id[1L] + if (is_empty(data_id)) return(NULL) + + # Initialise empty list. + task_list <- list() + ii <- 1L + run_tables <- .collect_run_tables(iteration_list = experiment_data@iteration_list) + + # train tasks ---------------------------------------------------------------- + + # Get run ids. + run_ids <- seq_len(experiment_data@experiment_setup[main_data_id == data_id]$n_runs[1L]) + + # Set up variable importance computation task. + for (learner in learners) { + for (vimp_method in vimp_methods) { + for (run_id in run_ids) { + + # Create task to generate run-specific feature info. + train_task <- methods::new( + "familiarTaskTrain", + data_id = data_id, + run_id = run_id, + vimp_method = vimp_method, + learner = learner, + run_table = run_tables, + project_id = experiment_data@project_id + ) + + # Add file names. + train_task <- .set_file_name( + object = train_task, + file_paths = file_paths + ) + + # Add to list, if the file does not exist on disk. + if (!skip_existing || !.file_exists(train_task)) { + task_list[[ii]] <- train_task + ii <- ii + 1L + } + } + } + } + + # Check if any train-related tasks are required. + if (length(task_list) == 0L) return(NULL) + + # learner hyperparameter tasks ----------------------------------------------- + + # Check how variable importance data should be handled. + if (is_empty(experiment_data@experiment_setup[vimp == TRUE, ])) { + use_vimp <- "return_hpo_vimp" + + } else if (optimisation_determine_vimp) { + use_vimp <- "use_hpo_vimp" + + } else { + use_vimp <- "use_main_vimp" + } + + # Set up variable importance hyperparameter task. + train_run_table <- .get_run_table_from_experiment_setup( + data_id = data_id, + experiment_setup = experiment_data@experiment_setup + ) + learner_hyperparameter_data_id <- tail( + train_run_table[main_data_id <= data_id & can_pre_process == TRUE, ], + n = 1L + )$main_data_id[1L] + + # Get run ids. + run_ids <- seq_len(train_run_table[main_data_id == learner_hyperparameter_data_id, ]$n_runs[1L]) + + for (learner in learners) { + for (vimp_method in vimp_methods) { + for (run_id in run_ids) { + # Create task to generate run-specific feature info. + learner_hyperparameter_task <- methods::new( + "familiarTaskLearnerHyperparameters", + data_id = learner_hyperparameter_data_id, + run_id = run_id, + use_vimp = use_vimp, + vimp_method = vimp_method, + learner = learner, + run_table = run_tables, + project_id = experiment_data@project_id + ) + + # Add file names. + learner_hyperparameter_task <- .set_file_name( + object = learner_hyperparameter_task, + file_paths = file_paths + ) + + # Add to list, if the file does not exist on disk. + if (!skip_existing || !.file_exists(learner_hyperparameter_task)) { + task_list[[ii]] <- learner_hyperparameter_task + ii <- ii + 1L + } + } + } + } + + # Add tasks related to data processing for learner methods. + task_list <- c( + task_list, + .generate_learner_data_preprocessing_tasks( + experiment_data = experiment_data, + file_paths = file_paths + ) + ) + + # variable importance tasks -------------------------------------------------- + task_list <- c( + task_list, + .generate_vimp_tasks( + experiment_data = experiment_data, + vimp_methods = vimp_methods, + file_paths = file_paths, + skip_existing = skip_existing + ) + ) + + return(task_list) +} + + + +.run_learner <- function( + cl, + tasks, + message_indent = 0L, + verbose, + ... +) { + + # Check that any tasks are available for processing. + if (is_empty(tasks$hyperparameters_learner) || is_empty(tasks$train)) return(invisible(FALSE)) + + # Determine which learner hyperparameter sets need to be found. + finished_tasks <- sapply(tasks$hyperparameters_learner, .file_exists) + unfinished_tasks <- tasks$hyperparameters_learner[!finished_tasks] + finished_tasks <- tasks$hyperparameters_learner[finished_tasks] + + # Process any unfinished tasks. + if (length(unfinished_tasks) > 0L) { + ..run_learner_computation_hyperparameters( + cl = cl, + tasks = unfinished_tasks, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + # Determine which variable importance tasks are required. + finished_tasks <- sapply(tasks$train, .file_exists) + unfinished_tasks <- tasks$train[!finished_tasks] + finished_tasks <- tasks$train[finished_tasks] + + # Process any unfinished tasks. + if (length(unfinished_tasks) > 0L) { + ..run_learner( + cl = cl, + tasks = unfinished_tasks, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + return(invisible(TRUE)) +} + + + +..run_learner <- function( + tasks, + cl, + settings, + message_indent = 0L, + verbose, + ... +) { + + # Message that variable importances computation is starting. + logger_message( + paste0( + "Training: Starting model training." + ), + indent = message_indent, + verbose = verbose + ) + + fam_mapply_lb( + cl = cl, + assign = "all", + FUN = .perform_task, + progress_bar = FALSE, + object = tasks, + MoreArgs = list( + "data" = NULL, + "return_results" = FALSE, + "settings" = settings, + "novelty_detector" = settings$mb$novelty_detector, + "detector_paramaters" = settings$mb$detector_parameters[[settings$mb$novelty_detector]], + "vimp_aggregation_method" = settings$vimp$aggregation, + "vimp_rank_threshold" = settings$vimp$aggr_rank_threshold, + "message_indent" = message_indent + 1L, + "verbose" = verbose, + ... + ) + ) + + # Message that variable importances have been computed. + logger_message( + paste0( + "Training: Models were trained.\n" + ), + indent = message_indent, + verbose = verbose + ) +} diff --git a/R/TaskLearnerHyperparameters.R b/R/TaskLearnerHyperparameters.R new file mode 100644 index 00000000..a9a64827 --- /dev/null +++ b/R/TaskLearnerHyperparameters.R @@ -0,0 +1,390 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# familiarTaskLearnerHyperparameters ------------------------------------------- +setClass( + "familiarTaskLearnerHyperparameters", + contains = "familiarTask", + slots = list( + "learner" = "character", + "vimp_method" = "character", + "use_vimp" = "character", + "feature_info_file" = "character", + "vimp_table_file" = "character" + ), + prototype = methods::prototype( + learner = NA_character_, + vimp_method = NA_character_, + use_vimp = "use_hpo_vimp", + feature_info_file = NA_character_, + vimp_table_file = NA_character_, + task_name = "set_learner_hyperparameters" + ) +) + + + +# .set_file_name (learner hyperparameters task) -------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskLearnerHyperparameters"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + # Generate file name of variable importance table + object@file <- get_object_file_name( + object_type = "hyperparametersLearner", + data_id = object@data_id, + run_id = object@run_id, + learner = object@learner, + vimp_method = object@vimp_method, + project_id = object@project_id, + dir_path = file_paths$mb_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (learner hyperparameters task) -------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskLearnerHyperparameters"), + function(object, ...) { + return(paste0( + object@task_name, "_", + object@data_id, "_", + object@run_id, "_", + object@vimp_method, "_", + object@learner + )) + } +) + + + +# .perform_task (learner hyperparameters task , NULL) -------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskLearnerHyperparameters", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("experiment_data is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Find the run list. + run_list <- .get_run_list( + iteration_list = experiment_data@iteration_list, + data_id = object@data_id, + run_id = object@run_id + ) + + # Select unique samples. + sample_identifiers <- .get_sample_identifiers( + run = run_list, + train_or_validate = "train" + ) + sample_identifiers <- unique(sample_identifiers) + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(sample_identifiers = sample_identifiers), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + +# .perform_task (learner hyperparameters task, dataObject) --------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskLearnerHyperparameters", + data = "dataObject" + ), + function( + object, + data, + settings = NULL, + feature_info_list = NULL, + vimp_table = NULL, + vimp_aggregation_method = NULL, + vimp_rank_threshold = NULL, + hyperparameters = NULL, + message_indent = 0L, + verbose = FALSE, + cl = NULL, + return_results = TRUE, + ... + ) { + + # Check that outcome_info is present on data + if (!is(data@outcome_info, "outcomeInfo")) { + ..error_reached_unreachable_code( + "outcome_info attribute of data (dataObject) does not contain an outcomeInfo object" + ) + } + + # Check and retrieve feature info list. + feature_info_list <- .get_feature_info_list( + object = object, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # Check and retrieve variable importances. + if (object@use_vimp == "use_main_vimp") { + vimp_table <- .get_variable_importance_table( + object = object, + vimp_table = vimp_table, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + } else if (object@use_vimp %in% c("use_hpo_vimp", "return_hpo_vimp")) { + vimp_table <- NULL + + } else { + ..error_reached_unreachable_code(paste0("use_vimp attribute has an unrecognised ")) + } + + # Set vimp aggregation method and vimp_rank_threshold based on settings. + if (!is.null(settings)) { + if (is.null(vimp_aggregation_method)) { + vimp_aggregation_method <- settings$vimp$aggregation + } + if (is.null(vimp_rank_threshold)) { + vimp_rank_threshold <- settings$vimp$aggr_rank_threshold + } + } + + # Get user-provided hyperparameters. + if (is.null(hyperparameters)) { + hyperparameters <- settings$mb$hyper_param[[object@learner]] + + } else if (rlang::is_bare_list(hyperparameters)) { + if (object@learner %in% names(hyperparameters)) { + hyperparameters <- hyperparameters[[object@learner]] + } + } + + # Create a model object to set hyperparameters. + hyperparameter_object <- promote_learner( + object = methods::new( + "familiarModel", + outcome_type = data@outcome_type, + hyperparameters = NULL, + learner = object@learner, + vimp_method = object@vimp_method, + vimp_table = vimp_table, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + outcome_info = data@outcome_info, + run_table = .get_current_run_table(object = object), + settings = settings, + project_id = object@project_id + ) + ) + + # Find required features. + required_features <- get_required_features( + x = feature_info_list, + exclude_signature = FALSE + ) + + # Limit to required features. This removes signature features which are not + # assessed through variable importance. + feature_info_list <- feature_info_list[required_features] + hyperparameter_object@required_features <- required_features + hyperparameter_object@feature_info <- feature_info_list + + # Make sure the input data is processed. + data <- process_input_data( + object = hyperparameter_object, + data = data + ) + + # Ensure that available data have associated outcome data. + data <- filter_missing_outcome(data = data) + + logger_message( + paste0( + "Hyperparameter optimisation: Starting hyperparameter optimisation for the \"", + object@learner, "\" learner with the \"", + object@vimp_method, "\" variable importance method for run ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + + # Compute hyperparameters. Function arguments to optimise_hyperparameters + # are passed from the calling function. + hyperparameter_object <- optimise_hyperparameters( + object = hyperparameter_object, + data = data, + user_list = hyperparameters, + verbose = verbose, + message_indent = message_indent + 1L, + save_in_place = FALSE, + is_vimp = FALSE, + cl = cl, + ... + ) + + if (object@use_vimp != "return_hpo_vimp") { + # Variable importance should not be passed using the hyperparameter + # object, which means that any subsequent learner task will use the cached + # variable importance tables instead. + hyperparameter_object@vimp_table <- NULL + } + + # Set familiar version. + hyperparameter_object <- add_package_version(hyperparameter_object) + + if (!is.na(object@file)) { + saveRDS(hyperparameter_object, file = object@file) + } + + if (return_results) { + return(hyperparameter_object) + } + + return(TRUE) + } +) + + + +..run_learner_computation_hyperparameters <- function( + tasks, + settings, + cl, + message_indent = 0L, + verbose, + ... +) { + logger_message( + paste0( + "Hyperparameter optimisation: Starting parameter optimisation for learners." + ), + indent = message_indent, + verbose = verbose + ) + + # Determine how parallel processing takes place. + if (settings$hpo$do_parallel %in% c("TRUE", "inner")) { + cl_inner <- cl + cl_outer <- NULL + + } else if (settings$hpo$do_parallel %in% c("outer")) { + cl_inner <- NULL + cl_outer <- cl + + if (!is.null(cl_outer)) { + logger_message( + paste0( + "Hyperparameter optimisation: Load-balanced parallel processing ", + "is done in the outer loop. No progress can be displayed." + ), + indent = message_indent, + verbose = verbose + ) + } + + } else { + cl_inner <- cl_outer <- NULL + } + + # Iterate over data subsets for which parameters have not yet been set. + fam_mapply_lb( + cl = cl_outer, + assign = "all", + FUN = .perform_task, + progress_bar = !is.null(cl_outer), + object = tasks, + MoreArgs = list( + "cl" = cl_inner, + "data" = NULL, + "settings" = settings, + "vimp_aggregation_method" = settings$vimp$aggregation, + "vimp_rank_threshold" = settings$vimp$aggr_rank_threshold, + "metric" = settings$hpo$hpo_metric, + "hyperparameters" = settings$mb$param, + "optimisation_function" = settings$hpo$hpo_optimisation_function, + "acquisition_function" = settings$hpo$hpo_acquisition_function, + "grid_initialisation_method" = settings$hpo$hpo_grid_initialisation_method, + "n_random_sets" = settings$hpo$hpo_n_grid_initialisation_samples, + "exploration_method" = settings$hpo$hpo_exploration_method, + "determine_vimp" = settings$hpo$hpo_determine_vimp, + "measure_time" = TRUE, + "hyperparameter_learner" = settings$hpo$hpo_hyperparameter_learner, + "n_max_bootstraps" = settings$hpo$hpo_max_bootstraps, + "n_initial_bootstraps" = settings$hpo$hpo_initial_bootstraps, + "n_intensify_step_bootstraps" = settings$hpo$hpo_bootstraps, + "n_max_optimisation_steps" = settings$hpo$hpo_smbo_iter_max, + "n_max_intensify_steps" = settings$hpo$hpo_intensify_max_iter, + "intensify_stop_p_value" = settings$hpo$hpo_alpha, + "convergence_tolerance" = settings$hpo$hpo_convergence_tolerance, + "convergence_stopping" = settings$hpo$hpo_conv_stop, + "time_limit" = settings$hpo$hpo_time_limit, + "message_indent" = message_indent + 1L, + "verbose" = verbose && is.null(cl_outer), + "return_results" = FALSE, + ... + ) + ) + + logger_message( + paste0( + "Hyperparameter optimisation: Completed parameter optimisation for learners.", + "\n" + ), + indent = message_indent, + verbose = verbose + ) + + return(invisible(TRUE)) +} diff --git a/R/TaskMain.R b/R/TaskMain.R new file mode 100644 index 00000000..dc04d7ae --- /dev/null +++ b/R/TaskMain.R @@ -0,0 +1,356 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + +# .file_exists (generic task) -------------------------------------------------- +setMethod( + ".file_exists", + signature(object = "familiarTask"), + function(object, ...) { + if (is.na(object@file) || is.null(object@file)) return(FALSE) + + return(file.exists(object@file)) + } +) + + + +# .get_current_run_table (generic task) ---------------------------------------- +setMethod( + ".get_current_run_table", + signature(object = "familiarTask"), + function(object, ...) { + if (is_empty(object@run_table)) return(NULL) + if (is.na(object@data_id) || is.na(object@run_id)) return(NULL) + + run_table <- object@run_table[[paste0(object@data_id, ".", object@run_id)]] + if (!data.table::is.data.table(run_table)) return(NULL) + + return(run_table) + } +) + + + +# .get_feature_info_list (general task) ---------------------------------------- +setMethod( + ".get_feature_info_list", + signature(object = "familiarTask"), + function(object, feature_info_list, ...) { + # Suppress NOTES due to non-standard evaluation in data.table + can_pre_process <- NULL + + # Attempt to get the feature info list from the backend. + if (is.null(feature_info_list) && !is.null(object@run_table)) { + # Find the last entry that is available for pre-processing + run_table <- object@run_table[[paste0(object@data_id, ".", object@run_id)]] + pre_processing_run <- tail(run_table[can_pre_process == TRUE, ], n = 1L) + + feature_info_list <- tryCatch( + get_feature_info_from_backend( + data_id = pre_processing_run$data_id[1L], + run_id = pre_processing_run$run_id[1L] + ), + error = NULL + ) + } + + # If no feature list is present on the backend, check other options. + if (is.null(feature_info_list) && is.na(object@feature_info_file)) { + # Check that a feature info list is provided, otherwise create an ad-hoc + # list as an template. + + # Set up task, and explicitly don't write to file. + generic_feature_info_task <- methods::new( + "familiarTaskFeatureInfo", + project_id = object@project_id, + file = NA_character_ + ) + + # Execute the task. + feature_info_list <- .perform_task( + object = generic_feature_info_task, + ... + ) + + } else if (is.null(feature_info_list)) { + # Assume that the feature info file attribute contains the path to the + # file containing feature info. + if (!file.exists(object@feature_info_file)) { + ..error(paste0("feature info file does not exist at location: ", object@feature_info_file)) + } + feature_info_list <- readRDS(object@feature_info_file) + feature_info_list <- update_object(feature_info_list) + + } else if (is.character(feature_info_list)) { + # If the feature info list is a string, interpret this as a path to the + # file containing the feature info. + if (!file.exists(feature_info_list)) { + ..error(paste0("feature info file does not exist at location: ", feature_info_list)) + } + feature_info_list <- readRDS(feature_info_list) + feature_info_list <- update_object(feature_info_list) + } + + if (!rlang::is_bare_list(feature_info_list)) { + ..error("no feature info objects were found.") + } + + return(feature_info_list) + } +) + + + +# .get_variable_importance_table (general task) -------------------------------- +setMethod( + ".get_variable_importance_table", + signature(object = "familiarTask"), + function( + object, + vimp_table, + experiment_data = NULL, + feature_info_list = NULL, + file_paths = NULL, + ... + ) { + # Suppress NOTES due to non-standard evaluation in data.table + vimp <- main_data_id <- data_id <- run_id <- NULL + + if (is.null(vimp_table) && !is.null(object@run_table)) { + # This routine loads variable importances from disk, and is used when an + # experiment is run using summon_familiar. + + # This check exists to make sure that the standard workflow passes the + # correct objects. + if (is.null(file_paths)) { + ..error_reached_unreachable_code("file_paths was expected, but not provided.") + } + + # Find the data and run ids corresponding to variable importance tables + # relevant to the current run. First we will figure out the data id and + # run id for ALL variable importance tables. + + # Check that the variable importance stage actually exists --> this may be + # lacking if variable importance is determined during hyperparameter + # optimisation. + if (all(!experiment_data@experiment_setup$vimp)) { + if (object@vimp_method %in% c( + .get_available_random_vimp_methods(), + .get_available_none_vimp_methods(), + .get_available_signature_only_vimp_methods() + )) { + return(NULL) + } + + ..error_reached_unreachable_code("Cannot form variable importance tables. Something is wrong.") + } + + vimp_data_id <- experiment_data@experiment_setup[vimp == TRUE, ]$main_data_id[1L] + vimp_run_ids <- seq_len(experiment_data@experiment_setup[main_data_id == vimp_data_id, ]$n_runs[1L]) + + # Select all run tables related to variable importance computation. + vimp_run_tables <- object@run_table[paste(vimp_data_id, vimp_run_ids, sep = ".")] + + # Get the run table for training. + train_run_table <- object@run_table[[paste0(object@data_id, ".", object@run_id)]] + + # Iterate backwards on data ids for the train run table to find matching + # vimp run tables. + matching <- logical(length(vimp_run_tables)) + train_data_chain_ids <- rev(train_run_table$data_id) + ii <- 1L + + while (!any(matching)) { + current_data_id <- train_data_chain_ids[ii] + current_run_id <- train_run_table[data_id == current_data_id, ]$run_id[1L] + + for (jj in seq_along(matching)) { + matching[jj] <- !is_empty(vimp_run_tables[[jj]][data_id == current_data_id & run_id == current_run_id]) + } + ii <- ii + 1L + } + + # Select matching variable importance run tables. + vimp_run_tables <- vimp_run_tables[matching] + vimp_run_ids <- sapply(vimp_run_tables, function(x) (tail(x, n = 1L)$run_id), simplify = TRUE, USE.NAMES = FALSE) + + # Get variable importance tables from disk. + vimp_table <- list() + for (ii in seq_along(vimp_run_ids)) { + vimp_table_file <- get_object_file_name( + project_id = object@project_id, + data_id = vimp_data_id, + run_id = vimp_run_ids[ii], + vimp_method = object@vimp_method, + object_type = "vimpTable", + dir_path = file_paths$vimp_dir + ) + + if (file.exists(vimp_table_file)) { + vimp_table[[ii]] <- update_object(readRDS(vimp_table_file)) + + } else { + ..error(paste0( + "A variable importance table object was expected on disk but was not found: ", + vimp_table_file + )) + } + } + } + + if (is.null(vimp_table) && is.na(object@vimp_table_file)) { + # Create an ad-hoc list of variable importances. + + # Set up task, and explicitly don't write to file. + vimp_task <- methods::new( + "familiarTaskVimp", + project_id = object@project_id, + vimp_method = object@vimp_method, + file = NA_character_ + ) + + # Execute the task. + vimp_table <- .perform_task( + object = vimp_task, + feature_info_list = feature_info_list, + ... + ) + + } else if (is.null(vimp_table)) { + # Assume that the vimp_table_file attribute contains the path to the + # file containing the variable importance table. + if (!file.exists(object@vimp_table_file)) { + ..error(paste0("variable importance table file does not exist at location: ", object@vimp_table_file)) + } + vimp_table <- update_object(readRDS(object@vimp_table_file)) + + } else if (is.character(vimp_table)) { + # If hyperparameters is a string, interpret this as a path to the + # file containing the vimp method hyperparameters. + if (!file.exists(vimp_table)) { + ..error(paste0("variable importance table file does not exist at location: ", vimp_table)) + } + vimp_table <- update_object(readRDS(vimp_table)) + } + + if (!(rlang::is_bare_list(vimp_table) || is(vimp_table, "vimpTable"))) { + ..error("No variable importance table was found.") + } + + return(vimp_table) + } +) + + + +.generate_learner_data_preprocessing_tasks <- function( + experiment_data, + file_paths +) { + + # Suppress NOTES due to non-standard evaluation in data.table + train <- can_pre_process <- perturbation_level <- main_data_id <- NULL + + # Find the data_id related to training. + train_data_id <- experiment_data@experiment_setup[train == TRUE, ]$main_data_id[1L] + if (is_empty(train_data_id)) return(NULL) + + # Determine which parts of the experimental setup are used by training. + run_table <- .get_run_table_from_experiment_setup( + data_id = train_data_id, + experiment_setup = experiment_data@experiment_setup + ) + + # Find the data_id and run_ids for preprocessing. + pre_process_data_id <- tail(run_table[main_data_id <= train_data_id & can_pre_process == TRUE], n = 1L)$main_data_id[1L] + pre_process_run_ids <- seq_len(run_table[main_data_id == pre_process_data_id]$n_runs[1L]) + + # Set up tasks. + task_list <- .generate_data_preprocessing_tasks( + data_ids = pre_process_data_id, + run_ids = pre_process_run_ids, + file_paths = file_paths, + project_id = experiment_data@project_id + ) + + return(task_list) +} + + + +.generate_vimp_data_preprocessing_tasks <- function( + experiment_data, + file_paths +) { + # Suppress NOTES due to non-standard evaluation in data.table + vimp <- can_pre_process <- main_data_id <- NULL + + # Find the data_id related to computing variable importance. + vimp_data_id <- experiment_data@experiment_setup[vimp == TRUE, ]$main_data_id[1L] + if (is_empty(vimp_data_id)) return(NULL) + + # Determine which parts of the experimental setup are used for assessing + # variable importance.. + run_table <- .get_run_table_from_experiment_setup( + data_id = vimp_data_id, + experiment_setup = experiment_data@experiment_setup + ) + + # Find the data_id and run_ids for preprocessing. + pre_process_data_id <- tail(run_table[main_data_id <= vimp_data_id & can_pre_process == TRUE], n = 1L)$main_data_id[1L] + pre_process_run_ids <- seq_len(run_table[main_data_id == pre_process_data_id]$n_runs[1L]) + + # Set up tasks. + task_list <- .generate_data_preprocessing_tasks( + data_ids = pre_process_data_id, + run_ids = pre_process_run_ids, + file_paths = file_paths, + project_id = experiment_data@project_id + ) + + return(task_list) +} + + + +.sort_tasks <- function(task_list) { + # Select unique tasks. + duplicate_tasks <- duplicated(sapply(task_list, FUN = .get_task_descriptor)) + task_list <- task_list[!duplicate_tasks] + + # Determine class of tasks. + task_class <- sapply(task_list, class) + + task_list <- list( + "generic_feature_info" = task_list[task_class == "familiarTaskGenericFeatureInfo"], + "feature_info" = task_list[task_class == "familiarTaskFeatureInfo"], + "hyperparameters_vimp" = task_list[task_class == "familiarTaskVimpHyperparameters"], + "vimp" = task_list[task_class == "familiarTaskVimp"], + "hyperparameters_learner" = task_list[task_class == "familiarTaskLearnerHyperparameters"], + "train" = task_list[task_class == "familiarTaskTrain"], + "evaluate" = task_list[task_class == "familiarTaskEvaluate"], + "collect" = task_list[task_class == "familiarTaskCollect"] + ) + + # Update task_id and n_tasks attribute of the tasks. + task_list <- lapply( + task_list, + function(x) { + lapply( + seq_along(x), + function(ii, x, n) { + object <- x[[ii]] + object@task_id <- ii + object@n_tasks <- n + return(object) + }, + x = x, + n = length(x) + ) + } + ) + + return(task_list) +} diff --git a/R/TaskNoveltyDetector.R b/R/TaskNoveltyDetector.R new file mode 100644 index 00000000..5b65083e --- /dev/null +++ b/R/TaskNoveltyDetector.R @@ -0,0 +1,363 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# familiarTaskTrainNovelty ----------------------------------------------------- +setClass( + "familiarTaskTrainNovelty", + contains = "familiarTask", + slots = list( + "vimp_method" = "character", + "learner" = "character", + "vimp_table_file" = "character", + "hyperparameter_file" = "character", + "feature_info_file" = "character" + ), + prototype = methods::prototype( + vimp_method = "none", + learner = NA_character_, + vimp_table_file = NA_character_, + hyperparameter_file = NA_character_, + feature_info_file = NA_character_, + task_name = "train_novelty_detector" + ) +) + + + +# .get_task_descriptor (train task) -------------------------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskTrainNovelty"), + function(object, ...) { + return(paste0( + object@task_name, "_", + object@data_id, "_", + object@run_id, "_", + object@vimp_method, "_", + object@learner + )) + } +) + + + +# .perform_task (train task , NULL) -------------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskTrainNovelty", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("experiment_data is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Find the run list. + run_list <- .get_run_list( + iteration_list = experiment_data@iteration_list, + data_id = object@data_id, + run_id = object@run_id + ) + + # Select unique samples. + sample_identifiers <- .get_sample_identifiers( + run = run_list, + train_or_validate = "train" + ) + sample_identifiers <- unique(sample_identifiers) + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(sample_identifiers = sample_identifiers), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + +# .perform_task (train task, dataObject) --------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskTrainNovelty", + data = "dataObject" + ), + function( + object, + data, + selected_features = NULL, + vimp_aggregation_method = NULL, + vimp_rank_threshold = NULL, + settings = NULL, + feature_info_list = NULL, + vimp_table = NULL, + hyperparameters = NULL, + message_indent = 0L, + verbose = FALSE, + cl = NULL, + return_results = TRUE, + ... + ) { + logger_message( + paste0( + "Training: Starting training for the \"", object@learner, + "\" out-of-distribution detector and the \"", object@vimp_method, + "\" variable importance method for run ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + + # Check and retrieve feature info list. + feature_info_list <- .get_feature_info_list( + object = object, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # Set vimp aggregation method and vimp_rank_threshold based on settings. + if (!is.null(settings)) { + if (is.null(vimp_aggregation_method)) { + vimp_aggregation_method <- settings$vimp$aggregation + } + if (is.null(vimp_rank_threshold)) { + vimp_rank_threshold <- settings$vimp$aggr_rank_threshold + } + } + + # Check and retrieve hyperparameters. We do this prior to retrieving the + # variable importance tables, as these may be attached to hyperparameter + # object. + hyperparameters <- .get_hyperparameters( + object = object, + selected_features = selected_features, + hyperparameters = hyperparameters, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # If selected features are not provided, create the variable importance + # table. + if (is.null(selected_features)) { + if (is_empty(hyperparameters$vimp_table)) { + # Check and retrieve variable importances from the drive, or generate in + # place, if the hyperparameter object did not contain a variable + # importance table. + vimp_table <- .get_variable_importance_table( + object = object, + vimp_table = vimp_table, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + } else { + vimp_table <- hyperparameters$vimp_table + } + + } else { + vimp_table <- NULL + } + + # Create the raw model object for training. + model_object <- methods::new( + "familiarNoveltyDetector", + hyperparameters = hyperparameters$hyperparameters, + learner = object@learner, + vimp_method = object@vimp_method, + vimp_table = vimp_table, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + feature_info = feature_info_list, + data_id = object@data_id, + run_id = object@run_id, + run_table = .get_current_run_table(object = object), + project_id = object@project_id + ) + + # Promote to the correct type of detector. + model_object <- promote_detector(object = model_object) + + # Select features based on variable importances. + model_object <- set_model_features( + object = model_object, + minimise_footprint = FALSE, + signature_features = selected_features + ) + + # Process data, if required. + data <- process_input_data( + object = model_object, + data = data, + stop_at = "clustering", + force_check = TRUE + ) + + # Train the novelty detector. + model_object <- .train( + object = model_object, + data = data, + get_additional_info = TRUE, + ... + ) + + # Add model name + model_object <- set_object_name(model_object) + + if (!is.na(object@file)) { + saveRDS(model_object, file = object@file) + } + + if (return_results) { + return(model_object) + } + + return(TRUE) + } +) + + + +# .get_hyperparameters (train task) -------------------------------------------- +setMethod( + ".get_hyperparameters", + signature(object = "familiarTaskTrainNovelty"), + function( + object, + hyperparameters, + file_paths = NULL, + ... + ) { + # Suppress NOTES due to non-standard evaluation in data.table + can_pre_process <- NULL + + hyperparameter_object <- NULL + if (is.null(hyperparameters) && !is.null(object@run_table)) { + # This routine loads hyperparameters from disk, and is used when an + # experiment is run using summon_familiar. + + # This check exists to make sure that the standard workflow passes the + # correct objects. + if (is.null(file_paths)) { + ..error_reached_unreachable_code("file_paths was expected, but not provided.") + } + + # Find the last entry on the run table that is marked as available for + # pre-processing. This is what hyperparameters are based on. + hyperparameter_run <- tail( + object@run_table[[paste0(object@data_id, ".", object@run_id)]][can_pre_process == TRUE, ], + n = 1L + ) + + # Find the file name. + hyperparameter_file <- get_object_file_name( + project_id = object@project_id, + data_id = hyperparameter_run$data_id[1L], + run_id = hyperparameter_run$run_id[1L], + learner = object@learner, + vimp_method = object@vimp_method, + object_type = "hyperparametersNoveltyDetector", + dir_path = file_paths$mb_dir + ) + + if (file.exists(hyperparameter_file)) { + hyperparameter_object <- update_object(readRDS(hyperparameter_file)) + } + } + + + if (is.null(hyperparameter_object) && is.na(object@hyperparameter_file)) { + # Create an ad-hoc list of hyperparameters + + # Set up task, and explicitly don't write to file. + hyperparameter_task <- methods::new( + "familiarTaskNoveltyDetectorHyperparameters", + project_id = object@project_id, + vimp_method = object@vimp_method, + learner = object@learner, + file = NA_character_ + ) + + # Execute the task. + hyperparameter_object <- .perform_task( + object = hyperparameter_task, + hyperparameters = hyperparameters, + ... + ) + + } else if (is.null(hyperparameter_object)) { + # Assume that the hyperparameter_file attribute contains the path to the + # file containing the vimp method hyperparameters. + if (!file.exists(object@hyperparameter_file)) { + ..error(paste0("hyperparameter file does not exist at location: ", object@hyperparameter_file)) + } + hyperparameter_object <- update_object(readRDS(object@hyperparameter_file)) + + } else if (is.character(hyperparameters)) { + # If hyperparameters is a string, interpret this as a path to the + # file containing the vimp method hyperparameters. + if (!file.exists(hyperparameters)) { + ..error(paste0("hyperparameter file does not exist at location: ", hyperparameters)) + } + hyperparameter_object <- update_object(readRDS(hyperparameters)) + } + + if (is(hyperparameter_object, "familiarNoveltyDetector")) { + hyperparameters <- list( + "hyperparameters" = hyperparameter_object@hyperparameters, + "hyperparameter_data" = hyperparameter_object@hyperparameter_data, + "vimp_table" = hyperparameter_object@vimp_table + ) + + } else { + hyperparameters <- list("hyperparameters" = hyperparameters) + } + + return(hyperparameters) + } +) diff --git a/R/TaskNoveltyDetectorHyperparameters.R b/R/TaskNoveltyDetectorHyperparameters.R new file mode 100644 index 00000000..7198b983 --- /dev/null +++ b/R/TaskNoveltyDetectorHyperparameters.R @@ -0,0 +1,269 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# familiarTaskNoveltyDetectorHyperparameters ----------------------------------- +setClass( + "familiarTaskNoveltyDetectorHyperparameters", + contains = "familiarTask", + slots = list( + "learner" = "character", + "vimp_method" = "character", + "use_vimp" = "character", + "feature_info_file" = "character", + "vimp_table_file" = "character" + ), + prototype = methods::prototype( + learner = NA_character_, + vimp_method = NA_character_, + use_vimp = "use_hpo_vimp", + feature_info_file = NA_character_, + vimp_table_file = NA_character_, + task_name = "set_novelty_detector_hyperparameters" + ) +) + + + +# .get_task_descriptor (novelty detector hyperparameters task) ----------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskNoveltyDetectorHyperparameters"), + function(object, ...) { + return(paste0( + object@task_name, "_", + object@data_id, "_", + object@run_id, "_", + object@vimp_method, "_", + object@learner + )) + } +) + + + +# .perform_task (novelty detector hyperparameters task , NULL) ----------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskNoveltyDetectorHyperparameters", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("experiment_data is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Find the run list. + run_list <- .get_run_list( + iteration_list = experiment_data@iteration_list, + data_id = object@data_id, + run_id = object@run_id + ) + + # Select unique samples. + sample_identifiers <- .get_sample_identifiers( + run = run_list, + train_or_validate = "train" + ) + sample_identifiers <- unique(sample_identifiers) + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(sample_identifiers = sample_identifiers), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + +# .perform_task (novelty detectors hyperparameters task, dataObject) ----------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskNoveltyDetectorHyperparameters", + data = "dataObject" + ), + function( + object, + data, + vimp_aggregation_method = NULL, + vimp_rank_threshold = NULL, + selected_features = NULL, + settings = NULL, + feature_info_list = NULL, + vimp_table = NULL, + hyperparameters = NULL, + message_indent = 0L, + verbose = FALSE, + cl = NULL, + return_results = TRUE, + ... + ) { + logger_message( + paste0( + "Hyperparameter optimisation: Starting hyperparameter optimisation for the \"", + object@learner, "\" novelty detector with the \"", + object@vimp_method, "\" variable importance method for run ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + + # Check and retrieve feature info list. + feature_info_list <- .get_feature_info_list( + object = object, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # If selected features are not provided, attempt to set the variable + # importance table. + if (is.null(selected_features)) { + # Check and retrieve variable importances. + if (object@use_vimp == "use_main_vimp") { + vimp_table <- .get_variable_importance_table( + object = object, + vimp_table = vimp_table, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + } else if (object@use_vimp %in% c("use_hpo_vimp", "return_hpo_vimp")) { + vimp_table <- NULL + + } else { + ..error_reached_unreachable_code(paste0("use_vimp attribute has an unrecognised ")) + } + } + + # Get user-provided hyperparameters. + if (is.null(hyperparameters)) { + hyperparameters <- settings$mb$detector_parameters[[object@learner]] + + } else if (rlang::is_bare_list(hyperparameters)) { + if (object@learner %in% names(hyperparameters)) { + hyperparameters <- hyperparameters[[object@learner]] + } + } + + # Set vimp aggregation method and vimp_rank_threshold based on settings. + if (!is.null(settings)) { + if (is.null(vimp_aggregation_method)) { + vimp_aggregation_method <- settings$vimp$aggregation + } + if (is.null(vimp_rank_threshold)) { + vimp_rank_threshold <- settings$vimp$aggr_rank_threshold + } + } + + # Create the novelty detector object to set hyperparameters. + hyperparameter_object <- promote_detector( + object = methods::new( + "familiarNoveltyDetector", + hyperparameters = NULL, + learner = object@learner, + vimp_method = object@vimp_method, + vimp_table = vimp_table, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + feature_info = feature_info_list, + data_id = object@data_id, + run_id = object@run_id, + run_table = .get_current_run_table(object = object), + project_id = object@project_id + ) + ) + + # Find required features. + required_features <- get_required_features( + x = feature_info_list, + features = selected_features, + exclude_signature = FALSE, + exclude_novelty = FALSE + ) + + # Limit to required features. This removes signature features which are not + # assessed through variable importance. + feature_info_list <- feature_info_list[required_features] + hyperparameter_object@required_features <- required_features + hyperparameter_object@feature_info <- feature_info_list + + # Make sure the input data is processed. + data <- process_input_data( + object = hyperparameter_object, + data = data + ) + + # Compute hyperparameters. Function arguments to optimise_hyperparameters + # are passed from the calling function. + hyperparameter_object <- optimise_hyperparameters( + object = hyperparameter_object, + data = data, + user_list = hyperparameters, + verbose = verbose, + message_indent = message_indent + 1L, + save_in_place = FALSE, + is_vimp = FALSE, + cl = cl, + ... + ) + + if (object@use_vimp != "return_hpo_vimp") { + # Variable importance should not be passed using the hyperparameter + # object, which means that any subsequent learner task will use the cached + # variable importance tables instead. + hyperparameter_object@vimp_table <- NULL + } + + # Set familiar version. + hyperparameter_object <- add_package_version(hyperparameter_object) + + if (!is.na(object@file)) { + saveRDS(hyperparameter_object, file = object@file) + } + + if (return_results) { + return(hyperparameter_object) + } + + return(TRUE) + } +) diff --git a/R/TaskVimp.R b/R/TaskVimp.R new file mode 100644 index 00000000..5510429a --- /dev/null +++ b/R/TaskVimp.R @@ -0,0 +1,618 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# familiarTaskVimp ------------------------------------------------------------- +setClass( + "familiarTaskVimp", + contains = "familiarTask", + slots = list( + "vimp_method" = "character", + "hyperparameter_file" = "character", + "feature_info_file" = "character" + ), + prototype = methods::prototype( + vimp_method = NA_character_, + hyperparameter_file = NA_character_, + feature_info_file = NA_character_, + task_name = "compute_variable_importance" + ) +) + + + +# .set_file_name (vimp task) --------------------------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskVimp"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + # Generate file name of variable importance table + object@file <- get_object_file_name( + object_type = "vimpTable", + data_id = object@data_id, + run_id = object@run_id, + vimp_method = object@vimp_method, + project_id = object@project_id, + dir_path = file_paths$vimp_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (vimp task) --------------------------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskVimp"), + function(object, ...) { + return(paste0(object@task_name, "_", object@data_id, "_", object@run_id, "_", object@vimp_method)) + } +) + + + +# .perform_task (vimp task , NULL) --------------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskVimp", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("experiment_data is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Find the run list. + run_list <- .get_run_list( + iteration_list = experiment_data@iteration_list, + data_id = object@data_id, + run_id = object@run_id + ) + + # Select unique samples. + sample_identifiers <- .get_sample_identifiers( + run = run_list, + train_or_validate = "train" + ) + sample_identifiers <- unique(sample_identifiers) + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(sample_identifiers = sample_identifiers), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + +# .perform_task (vimp task, dataObject) ---------------------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskVimp", + data = "dataObject" + ), + function( + object, + data, + vimp_aggregation_method = NULL, + vimp_rank_threshold = NULL, + experiment_data = NULL, + settings = NULL, + feature_info_list = NULL, + hyperparameters = NULL, + message_indent = 0L, + verbose = FALSE, + cl = NULL, + return_results = TRUE, + ... + ) { + + # Check if the desired data already exist elsewhere. + results_exist <- FALSE + if (is(experiment_data, "experimentData")) { + if (!is_empty(experiment_data@vimp_table_list)) { + # Identify if the intended vimp_table already exists. Variable + # importance tables are stored in a flat list in the vimp_table_list + # attribute. The intended variable importance table must match the + # variable importance method (vimp_method), data_id and run_id of the + # current task. + matching <- sapply( + experiment_data@vimp_table_list, + function(x, vimp_method, data_id, run_id) { + if (x@vimp_method != vimp_method) return(FALSE) + + run_data <- tail(x@run_table, n = 1L) + if (run_data$data_id != data_id) return(FALSE) + if (run_data$run_id != run_id) return(FALSE) + + return(TRUE) + }, + vimp_method = object@vimp_method, + data_id = object@data_id, + run_id = object@run_id, + simplify = TRUE, + USE.NAMES = FALSE + ) + + if (any(matching)) { + vimp_table <- experiment_data@vimp_table_list[matching][[1L]] + results_exist <- TRUE + } + } + } + + if (file.exists(object@file)) { + vimp_table <- update_object(object = readRDS(object@file)) + results_exist <- TRUE + } + + if (results_exist) { + if (!is.na(object@file)) { + saveRDS(vimp_table, file = object@file) + } + + if (return_results) { + return(vimp_table) + } + + return(invisible(TRUE)) + } + + # Check that outcome_info is present on data + if (!is(data@outcome_info, "outcomeInfo")) { + ..error_reached_unreachable_code( + "outcome_info attribute of data (dataObject) does not contain an outcomeInfo object" + ) + } + + # Set vimp aggregation method and vimp_rank_threshold based on settings. + if (!is.null(settings)) { + if (is.null(vimp_aggregation_method)) { + vimp_aggregation_method <- settings$vimp$aggregation + } + if (is.null(vimp_rank_threshold)) { + vimp_rank_threshold <- settings$vimp$aggr_rank_threshold + } + } + + # Check and retrieve feature info list. + feature_info_list <- .get_feature_info_list( + object = object, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # Check and retrieve hyperparameters. + hyperparameters <- .get_hyperparameters( + object = object, + hyperparameters = hyperparameters, + feature_info_list = feature_info_list, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # Create the variable importance method object or familiar model object to + # compute variable importance with. + vimp_object <- methods::new( + "familiarVimpMethod", + outcome_type = data@outcome_type, + hyperparameters = hyperparameters, + vimp_method = object@vimp_method, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + outcome_info = data@outcome_info, + run_table = .get_current_run_table(object = object), + project_id = object@project_id + ) + + # Promote to the correct subclass. + vimp_object <- promote_vimp_method(object = vimp_object) + + # Set multivariate methods. + if (is(vimp_object, "familiarModel")) is_multivariate <- TRUE + if (is(vimp_object, "familiarVimpMethod")) is_multivariate <- vimp_object@multivariate + + # Find required features. Exclude the signature features at this point, as + # these will have been dropped from the variable importance table. + required_features <- get_required_features( + x = data, + feature_info_list = feature_info_list, + exclude_signature = !is_multivariate + ) + + # Limit to required features. + vimp_object@required_features <- required_features + vimp_object@feature_info <- feature_info_list[required_features] + + # Make sure the input data is processed. + data <- process_input_data( + object = vimp_object, + data = data + ) + + logger_message( + paste0( + "Variable importance: Starting variable importance computation using the \"", + object@vimp_method, "\" method for run ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + + # Compute variable importance. + vimp_table <- .vimp( + object = vimp_object, + data = data + ) + + # Set data id and run id. + vimp_table@data_id <- object@data_id + vimp_table@run_id <- object@run_id + + if (!is.na(object@file)) { + saveRDS(vimp_table, file = object@file) + } + + if (return_results) { + return(vimp_table) + } + + return(invisible(TRUE)) + } +) + + + +# .get_hyperparameters (vimp task) --------------------------------------------- +setMethod( + ".get_hyperparameters", + signature(object = "familiarTaskVimp"), + function( + object, + hyperparameters, + file_paths = NULL, + ... + ) { + # Suppress NOTES due to non-standard evaluation in data.table + can_pre_process <- NULL + + if (is.null(hyperparameters) && !is.null(object@run_table)) { + # This routine loads hyperparameters from disk, and is used when an + # experiment is run using summon_familiar. + + # This check exists to make sure that the standard workflow passes the + # correct objects. + if (is.null(file_paths)) { + ..error_reached_unreachable_code("file_paths was expected, but not provided.") + } + + # Find the last entry on the run table that is marked as available for + # pre-processing. This is what hyperparameters are based on. + hyperparameter_run <- tail( + object@run_table[[paste0(object@data_id, ".", object@run_id)]][can_pre_process == TRUE, ], + n = 1L + ) + + # Find the file name. + hyperparameter_file <- get_object_file_name( + project_id = object@project_id, + data_id = hyperparameter_run$data_id[1L], + run_id = hyperparameter_run$run_id[1L], + vimp_method = object@vimp_method, + object_type = "hyperparametersVimp", + dir_path = file_paths$vimp_dir + ) + + if (file.exists(hyperparameter_file)) { + hyperparameter_object <- update_object(readRDS(hyperparameter_file)) + hyperparameters <- hyperparameter_object@hyperparameters + } + } + + + if (is.null(hyperparameters) && is.na(object@hyperparameter_file)) { + # Create an ad-hoc list of hyperparameters + + # Set up task, and explicitly don't write to file. + hyperparameter_task <- methods::new( + "familiarTaskVimpHyperparameters", + project_id = object@project_id, + vimp_method = object@vimp_method, + file = NA_character_ + ) + + # Execute the task. + hyperparameter_object <- .perform_task( + object = hyperparameter_task, + ... + ) + + hyperparameters <- hyperparameter_object@hyperparameters + + } else if (is.null(hyperparameters)) { + # Assume that the hyperparameter_file attribute contains the path to the + # file containing the vimp method hyperparameters. + if (!file.exists(object@hyperparameter_file)) { + ..error(paste0("hyperparameter file does not exist at location: ", object@hyperparameter_file)) + } + hyperparameter_object <- update_object(readRDS(object@hyperparameter_file)) + hyperparameters <- hyperparameter_object@hyperparameters + + } else if (is.character(hyperparameters)) { + # If hyperparameters is a string, interpret this as a path to the + # file containing the vimp method hyperparameters. + if (!file.exists(hyperparameters)) { + ..error(paste0("hyperparameter file does not exist at location: ", hyperparameters)) + } + hyperparameter_object <- update_object(readRDS(hyperparameters)) + hyperparameters <- hyperparameter_object@hyperparameters + } + + if (!(rlang::is_bare_list(hyperparameters))) { + ..error("No hyperparameters were found.") + } + + return(hyperparameters) + } +) + + + +# .get_variable_importance_table (vimp task) ----------------------------------- +setMethod( + ".get_variable_importance_table", + signature(object = "familiarTaskVimp"), + function( + object, + ... + ) { + ..error_reached_unreachable_code(".get_variable_importance_table does not exist for this task") + } +) + + + + +.generate_vimp_tasks <- function( + experiment_data, + vimp_methods, + file_paths, + skip_existing = FALSE +) { + # Suppress NOTES due to non-standard evaluation in data.table + vimp <- main_data_id <- can_pre_process <- NULL + + # Find the data_id related to computing variable importance. + data_id <- experiment_data@experiment_setup[vimp == TRUE, ]$main_data_id[1L] + if (is.na(data_id)) return(NULL) + + # Initialise empty list. + task_list <- list() + ii <- 1L + run_tables <- .collect_run_tables(iteration_list = experiment_data@iteration_list) + + # vimp tasks ----------------------------------------------------------------- + + # Get run ids. + run_ids <- seq_len(experiment_data@experiment_setup[main_data_id == data_id]$n_runs[1L]) + + # Set up variable importance computation task. + for (vimp_method in vimp_methods) { + for (run_id in run_ids) { + + # Create task to generate run-specific feature info. + vimp_task <- methods::new( + "familiarTaskVimp", + data_id = data_id, + run_id = run_id, + vimp_method = vimp_method, + run_table = run_tables, + project_id = experiment_data@project_id + ) + + # Add file names. + vimp_task <- .set_file_name( + object = vimp_task, + file_paths = file_paths + ) + + # Add to list, if the file does not exist on disk. + if (!skip_existing || !.file_exists(vimp_task)) { + task_list[[ii]] <- vimp_task + ii <- ii + 1L + } + } + } + + # Check if any vimp-related tasks are required. + if (length(task_list) == 0L) return(NULL) + + # vimp hyperparameter tasks -------------------------------------------------- + + # Identify which data id corresponds to computing hyperparameters. + vimp_run_table <- .get_run_table_from_experiment_setup( + data_id = data_id, + experiment_setup = experiment_data@experiment_setup + ) + + vimp_hyperparameter_data_id <- tail( + vimp_run_table[main_data_id <= data_id & can_pre_process == TRUE, ], + n = 1L + )$main_data_id[1L] + + # Get run ids. + run_ids <- seq_len(vimp_run_table[main_data_id == vimp_hyperparameter_data_id, ]$n_runs[1L]) + + for (vimp_method in vimp_methods) { + for (run_id in run_ids) { + # Create task to generate run-specific feature info. + vimp_hyperparameter_task <- methods::new( + "familiarTaskVimpHyperparameters", + data_id = vimp_hyperparameter_data_id, + run_id = run_id, + vimp_method = vimp_method, + run_table = run_tables, + project_id = experiment_data@project_id + ) + + # Add file names. + vimp_hyperparameter_task <- .set_file_name( + object = vimp_hyperparameter_task, + file_paths = file_paths + ) + + # Add to list, if the file does not exist on disk. + if (!skip_existing || !.file_exists(vimp_hyperparameter_task)) { + task_list[[ii]] <- vimp_hyperparameter_task + ii <- ii + 1L + } + } + } + + # Add tasks related to data processing for vimp methods. + task_list <- c( + task_list, + .generate_vimp_data_preprocessing_tasks( + experiment_data = experiment_data, + file_paths = file_paths + ) + ) + + return(task_list) +} + + + +.run_variable_importance_computation <- function( + cl, + tasks, + message_indent = 0L, + verbose, + ... +) { + + # Check that any tasks are available for processing. + if (is_empty(tasks$hyperparameters_vimp) || is_empty(tasks$vimp)) return(invisible(FALSE)) + + # Determine which variable importance hyperparameters need to be found. + finished_tasks <- sapply(tasks$hyperparameters_vimp, .file_exists) + unfinished_tasks <- tasks$hyperparameters_vimp[!finished_tasks] + finished_tasks <- tasks$hyperparameters_vimp[finished_tasks] + + # Process any unfinished tasks. + if (length(unfinished_tasks) > 0L) { + ..run_variable_importance_computation_hyperparameters( + cl = cl, + tasks = unfinished_tasks, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + # Determine which variable importance tasks are required. + finished_tasks <- sapply(tasks$vimp, .file_exists) + unfinished_tasks <- tasks$vimp[!finished_tasks] + finished_tasks <- tasks$vimp[finished_tasks] + + # Process any unfinished tasks. + if (length(unfinished_tasks) > 0L) { + ..run_variable_importance_computation( + cl = cl, + tasks = unfinished_tasks, + message_indent = message_indent, + verbose = verbose, + ... + ) + } + + return(invisible(TRUE)) +} + + + +..run_variable_importance_computation <- function( + tasks, + cl, + message_indent = 0L, + verbose, + ... +) { + + # Message that variable importances computation is starting. + logger_message( + paste0( + "Variable importance: Starting variable importance computation." + ), + indent = message_indent, + verbose = verbose + ) + + fam_mapply_lb( + cl = cl, + assign = "all", + FUN = .perform_task, + progress_bar = FALSE, + object = tasks, + MoreArgs = list( + "data" = NULL, + "return_results" = FALSE, + "message_indent" = message_indent + 1L, + "verbose" = verbose, + ... + ) + ) + + # Message that variable importances have been computed. + logger_message( + paste0( + "Variable importance: Variable importances have been computed.\n" + ), + indent = message_indent, + verbose = verbose + ) +} diff --git a/R/TaskVimpHyperparameters.R b/R/TaskVimpHyperparameters.R new file mode 100644 index 00000000..e77bac22 --- /dev/null +++ b/R/TaskVimpHyperparameters.R @@ -0,0 +1,411 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# familiarTaskVimpHyperparameters ---------------------------------------------- +setClass( + "familiarTaskVimpHyperparameters", + contains = "familiarTask", + slots = list( + "vimp_method" = "character", + "feature_info_file" = "character" + ), + prototype = methods::prototype( + vimp_method = NA_character_, + feature_info_file = NA_character_, + task_name = "set_variable_importance_hyperparameters" + ) +) + + + +# .set_file_name (vimp hyperparameters task) ----------------------------------- +setMethod( + ".set_file_name", + signature(object = "familiarTaskVimpHyperparameters"), + function(object, file_paths = NULL) { + if (is.null(file_paths)) return(object) + + # Generate file name of variable importance table + object@file <- get_object_file_name( + object_type = "hyperparametersVimp", + data_id = object@data_id, + run_id = object@run_id, + vimp_method = object@vimp_method, + project_id = object@project_id, + dir_path = file_paths$vimp_dir + ) + + return(object) + } +) + + + +# .get_task_descriptor (vimp hyperparameters task) ----------------------------- +setMethod( + ".get_task_descriptor", + signature(object = "familiarTaskVimpHyperparameters"), + function(object, ...) { + return(paste0(object@task_name, "_", object@data_id, "_", object@run_id, "_", object@vimp_method)) + } +) + + + +# .perform_task (vimp hyperparameters task , NULL) ----------------------------- +setMethod( + ".perform_task", + signature( + object = "familiarTaskVimpHyperparameters", + data = "NULL" + ), + function( + object, + data, + experiment_data = NULL, + outcome_info = NULL, + ... + ) { + # This method is called when "data" is expected to be available somewhere in + # the backend. + + if (is.null(experiment_data)) { + ..error_reached_unreachable_code("experiment_data is required for retrieving data from the backend.") + } + if (is.null(outcome_info)) { + ..error_reached_unreachable_code("outcome_info is required.") + } + + # Find the run list. + run_list <- .get_run_list( + iteration_list = experiment_data@iteration_list, + data_id = object@data_id, + run_id = object@run_id + ) + + # Select unique samples. + sample_identifiers <- .get_sample_identifiers( + run = run_list, + train_or_validate = "train" + ) + sample_identifiers <- unique(sample_identifiers) + + # Create a dataObject. + data <- methods::new( + "dataObject", + data = get_data_from_backend(sample_identifiers = sample_identifiers), + preprocessing_level = "none", + outcome_type = outcome_info@outcome_type, + outcome_info = outcome_info + ) + + # Pass to method that dispatches with dataObject for further processing. + return(.perform_task( + object = object, + data = data, + experiment_data = experiment_data, + ... + )) + } +) + + +# .perform_task (vimp hyperparameters task, dataObject) ------------------------ +setMethod( + ".perform_task", + signature( + object = "familiarTaskVimpHyperparameters", + data = "dataObject" + ), + function( + object, + data, + vimp_aggregation_method = NULL, + vimp_rank_threshold = NULL, + settings = NULL, + experiment_data = NULL, + feature_info_list = NULL, + hyperparameters = NULL, + message_indent = 0L, + verbose = FALSE, + cl = NULL, + return_results = TRUE, + ... + ) { + logger_message( + paste0( + "Hyperparameter optimisation: Starting hyperparameter optimisation for the \"", + object@vimp_method, "\" method for run ", + object@task_id, " of ", + object@n_tasks, "." + ), + indent = message_indent, + verbose = verbose + ) + + # Check if the desired data already exist elsewhere. + results_exist <- FALSE + if (is(experiment_data, "experimentData")) { + if (!is_empty(experiment_data@vimp_hyperparameter_list)) { + # Identify if the intended hyperparameter object already exists. + # Hyperparameters are stored in a flat list in the + # vimp_hyperparameter_list attribute. The intended hyperparameters must + # match the variable importance method (vimp_method), data_id and run_id + # of the current task. + matching <- sapply( + experiment_data@vimp_hyperparameter_list, + function(x, vimp_method, data_id, run_id) { + if (x@vimp_method != vimp_method) return(FALSE) + + run_data <- tail(x@run_table, n = 1L) + if (run_data$data_id != data_id) return(FALSE) + if (run_data$run_id != run_id) return(FALSE) + + return(TRUE) + }, + vimp_method = object@vimp_method, + data_id = object@data_id, + run_id = object@run_id, + simplify = TRUE, + USE.NAMES = FALSE + ) + + if (any(matching)) { + hyperparameter_object <- experiment_data@vimp_hyperparameter_list[matching][[1L]] + results_exist <- TRUE + } + } + } + + # Check if the associated file already exists. + if (file.exists(object@file)) { + hyperparameter_object <- update_object(object = readRDS(object@file)) + results_exist <- TRUE + } + + # If results exists, exit the routine. + if (results_exist) { + if (!is.na(object@file)) { + saveRDS(hyperparameter_object, file = object@file) + } + + if (return_results) { + return(hyperparameter_object) + } + + return(TRUE) + } + + # Check that outcome_info is present on data + if (!is(data@outcome_info, "outcomeInfo")) { + ..error_reached_unreachable_code( + "outcome_info attribute of data (dataObject) does not contain an outcomeInfo object" + ) + } + + # Set vimp aggregation method and vimp_rank_threshold based on settings. + if (!is.null(settings)) { + if (is.null(vimp_aggregation_method)) { + vimp_aggregation_method <- settings$vimp$aggregation + } + if (is.null(vimp_rank_threshold)) { + vimp_rank_threshold <- settings$vimp$aggr_rank_threshold + } + } + + # Check and retrieve feature info list. + feature_info_list <- .get_feature_info_list( + object = object, + feature_info_list = feature_info_list, + data = data, + settings = settings, + message_indent = message_indent, + verbose = verbose, + cl = cl, + ... + ) + + # Get user-provided hyperparameters. + if (is.null(hyperparameters)) { + hyperparameters <- settings$vimp$param[[object@vimp_method]] + + } else if (rlang::is_bare_list(hyperparameters)) { + if (object@vimp_method %in% names(hyperparameters)) { + hyperparameters <- hyperparameters[[object@vimp_method]] + } + } + + # Create a variable importance object to set hyperparameters. + hyperparameter_object <- promote_vimp_method( + object = methods::new( + "familiarVimpMethod", + outcome_type = data@outcome_type, + hyperparameters = NULL, + vimp_method = object@vimp_method, + vimp_aggregation_method = vimp_aggregation_method, + vimp_rank_threshold = vimp_rank_threshold, + outcome_info = data@outcome_info, + run_table = .get_current_run_table(object = object), + project_id = object@project_id + ) + ) + + # Set multivariate methods. + if (is(hyperparameter_object, "familiarModel")) is_multivariate <- TRUE + if (is(hyperparameter_object, "familiarVimpMethod")) is_multivariate <- hyperparameter_object@multivariate + + # Find required features. + required_features <- get_required_features( + x = feature_info_list, + exclude_signature = !is_multivariate + ) + + # Limit to required features. This removes signature features which are not + # assessed through variable importance. + feature_info_list <- feature_info_list[required_features] + hyperparameter_object@required_features <- required_features + hyperparameter_object@feature_info <- feature_info_list + + # Make sure the input data is processed. + data <- process_input_data( + object = hyperparameter_object, + data = data + ) + + # Compute hyperparameters. Function arguments to optimise_hyperparameters + # are passed from the calling function. + hyperparameter_object <- optimise_hyperparameters( + object = hyperparameter_object, + data = data, + user_list = hyperparameters, + verbose = verbose, + message_indent = message_indent + 1L, + save_in_place = FALSE, + is_vimp = TRUE, + cl = cl, + ... + ) + + # Set familiar version. + hyperparameter_object <- add_package_version(hyperparameter_object) + + if (!is.na(object@file)) { + saveRDS(hyperparameter_object, file = object@file) + } + + if (return_results) { + return(hyperparameter_object) + } + + return(TRUE) + } +) + + + +# .get_variable_importance_table (vimp hyperparameters task) ------------------- +setMethod( + ".get_variable_importance_table", + signature(object = "familiarTaskVimpHyperparameters"), + function( + object, + ... + ) { + ..error_reached_unreachable_code(".get_variable_importance_table does not exist for this task") + } +) + + + + +..run_variable_importance_computation_hyperparameters <- function( + tasks, + settings, + cl, + message_indent = 0L, + verbose, + ... +) { + logger_message( + paste0( + "Hyperparameter optimisation: Starting parameter optimisation for variable importance methods." + ), + indent = message_indent, + verbose = verbose + ) + + # Determine how parallel processing takes place. + if (settings$hpo$do_parallel %in% c("TRUE", "inner")) { + cl_inner <- cl + cl_outer <- NULL + + } else if (settings$hpo$do_parallel %in% c("outer")) { + cl_inner <- NULL + cl_outer <- cl + + if (!is.null(cl_outer)) { + logger_message( + paste0( + "Hyperparameter optimisation: Load-balanced parallel processing ", + "is done in the outer loop. No progress can be displayed." + ), + indent = message_indent, + verbose = verbose + ) + } + + } else { + cl_inner <- cl_outer <- NULL + } + + # Iterate over data subsets for which parameters have not yet been set. + fam_mapply_lb( + cl = cl_outer, + assign = "all", + FUN = .perform_task, + progress_bar = !is.null(cl_outer), + object = tasks, + MoreArgs = list( + "cl" = cl_inner, + "data" = NULL, + "settings" = settings, + "metric" = settings$hpo$hpo_metric, + "hyperparameters" = settings$vimp$param, + "optimisation_function" = settings$hpo$hpo_optimisation_function, + "acquisition_function" = settings$hpo$hpo_acquisition_function, + "grid_initialisation_method" = settings$hpo$hpo_grid_initialisation_method, + "n_random_sets" = settings$hpo$hpo_n_grid_initialisation_samples, + "exploration_method" = settings$hpo$hpo_exploration_method, + "determine_vimp" = settings$hpo$hpo_determine_vimp, + "measure_time" = TRUE, + "hyperparameter_learner" = settings$hpo$hpo_hyperparameter_learner, + "n_max_bootstraps" = settings$hpo$hpo_max_bootstraps, + "n_initial_bootstraps" = settings$hpo$hpo_initial_bootstraps, + "n_intensify_step_bootstraps" = settings$hpo$hpo_bootstraps, + "n_max_optimisation_steps" = settings$hpo$hpo_smbo_iter_max, + "n_max_intensify_steps" = settings$hpo$hpo_intensify_max_iter, + "intensify_stop_p_value" = settings$hpo$hpo_alpha, + "convergence_tolerance" = settings$hpo$hpo_convergence_tolerance, + "convergence_stopping" = settings$hpo$hpo_conv_stop, + "time_limit" = settings$hpo$hpo_time_limit, + "message_indent" = message_indent + 1L, + "verbose" = verbose && is.null(cl_outer), + "return_results" = FALSE, + ... + ) + ) + + logger_message( + paste0( + "Hyperparameter optimisation: Completed parameter optimisation for variable importance methods.", + "\n" + ), + indent = message_indent, + verbose = verbose + ) + + return(invisible(TRUE)) +} diff --git a/R/TestDataCreators.R b/R/TestDataCreators.R index fb4b0129..8b578021 100644 --- a/R/TestDataCreators.R +++ b/R/TestDataCreators.R @@ -1,186 +1,142 @@ -test_data_package_installed <- function(outcome_type) { - run_test <- TRUE +test_create_good_data <- function( + outcome_type, + to_data_object = TRUE, + seed = 1844L, + rstream_object = NULL, + one_relevant_feature = FALSE, + two_groups = FALSE +) { - data_packages <- list( - "survival" = "survival", - "multinomial" = "datasets", - "binomial" = "MASS", - "continuous" = "Ecdat", - "count" = "MASS" - ) + # Create random stream object so that the same numbers are produced every + # time. + if (is.null(rstream_object)) { + r <- .start_random_number_stream(seed = seed) + } else { + r <- rstream_object + } - if (!is_package_installed(data_packages[[outcome_type]])) run_test <- FALSE - if (!rlang::is_installed(data_packages[[outcome_type]])) run_test <- FALSE + n_series_instances <- 150L - if (!run_test) { - rlang::inform( - message = paste0( - "Cannot run test because the ", - data_packages[[outcome_type]], - " package is not installed."), - class = "familiar_message_inform_no_test" - ) + # Draw random numbers for four features. + feature_1 <- fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r) + feature_2a <- fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r) + feature_2b <- feature_2a + fam_runif(n = n_series_instances, min = -0.05, max = 0.05, rstream_object = r) + feature_3a <- fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r) + feature_3b <- feature_3a + fam_runif(n = n_series_instances, min = -0.20, max = 0.20, rstream_object = r) + feature_4 <- fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r) + + # Determine the raw outcome. + if (one_relevant_feature) { + # Only one feature is relevant. + outcome_raw <- feature_1 + } else { + # More than one feature is relevant (default). + outcome_raw <- feature_1 + 0.1 * feature_2a + 0.3 * feature_3a + 0.1 * feature_4 } - return(run_test) -} - - -test_create_good_data <- function(outcome_type, to_data_object = TRUE) { - # Suppress NOTES due to non-standard evaluation in data.table - etype <- median_house_value <- NULL - - if (outcome_type == "survival") { - # Load colon dataset from the survival package. - data <- data.table::as.data.table(survival::colon) - - # Focus on recurrence. - data <- data[etype == 1] - data$adhere <- factor( - x = data$adhere, - levels = c(0, 1), - labels = c(FALSE, TRUE), - ordered = TRUE) - - # Limit to 150 samples - data <- data[1:150, ] - - # update sample identifier. - data[, ":="("id" = .I)] - - if (to_data_object) { - data <- as_data_object( - data = data, - sample_id_column = "id", - outcome_column = c("time", "status"), - outcome_type = outcome_type, - include_features = c("nodes", "rx", "adhere")) - } + + if (outcome_type == "binomial") { + # Because outcome_raw is strongly correlated with feature 1, this may lead to + # numerical issues. To prevent this, we add some noise to the outcome. + outcome_raw <- outcome_raw + fam_rnorm(n = n_series_instances, mean = 0.0, sd = 0.1, rstream_object = r) + + # Convert to 0, 1 + outcome_value <- outcome_raw > 0.75 + outcome_value <- factor( + x = outcome_value, + levels = c(FALSE, TRUE), + labels = c("red", "green") + ) } else if (outcome_type == "multinomial") { - # Load iris data set. - data <- data.table::as.data.table(datasets::iris) - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Convert to a data object. - if (to_data_object) { - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "Species", - outcome_type = outcome_type) - } + outcome_value <- numeric(n_series_instances) - } else if (outcome_type == "binomial") { - # Load the cancer breast biopsy data set. - data <- data.table::as.data.table(MASS::biopsy) - - # Rename columns. - data.table::setnames( - x = data, - old = c("ID", "V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "class"), - new = c( - "id", "clump_thickness", "cell_size_uniformity", "cell_shape_uniformity", - "marginal_adhesion", "epithelial_cell_size", "bare_nuclei", - "bland_chromatin", "normal_nucleoli", "mitoses", "cell_malignancy")) - - # Keep unique samples. Some samples have the same id, but a different - # outcome. - data <- unique(data, by = "id") - - # Limit to 150 samples - data <- data[1:150, ] - - # update sample identifier. - data[, ":="("id" = .I)] - - # Convert to a data object. Exclude cell_size_uniformity, as these are - # correlated and make it difficult to stable establish variable importance. - if (to_data_object) { - data <- as_data_object( - data = data, - sample_id_column = "id", - outcome_column = "cell_malignancy", - outcome_type = outcome_type, - exclude_features = "cell_size_uniformity", - class_levels = c("benign", "malignant")) - } + # Convert to 0 (x < 0.58), 1 (0.58 < x < 0.92), 2 (0.92 < x < 1.5) + outcome_value[outcome_raw < 0.58] <- 0.0 + outcome_value[outcome_raw >= 0.58 & outcome_raw < 0.92] <- 1.0 + outcome_value[outcome_raw >= 0.92] <- 2.0 + + outcome_value <- factor( + x = outcome_value, + levels = c(0.0, 1.0, 2.0), + labels = c("red", "green", "blue") + ) } else if (outcome_type == "continuous") { - # Load the California Test Score Data Set - data <- data.table::data.table(Ecdat::Caschool) - - # Drop distcod, district, county, readscr, mathscr - data[, ":="( - "distcod" = NULL, - "district" = NULL, - "county" = NULL, - "readscr" = NULL, - "mathscr" = NULL)] - - # Limit to 150 samples - data <- data[271:420, ] - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Convert to a data object. Exclude mealpct, as this feature is correlated - # to avginc. - if (to_data_object) { - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "testscr", - outcome_type = outcome_type, - exclude_features = "mealpct") - } + outcome_value <- outcome_raw + + } else if (outcome_type == "survival") { + # Simulate event times using exponential function and lambda = 0.5 + outcome_time <- - log(fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r)) / + (0.5 * exp(3.0 * (outcome_raw - mean(outcome_raw)))) + + # Simulate censoring times using exponential function and lambda = 0.1 + censor_time <- - log(fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r)) / 0.1 + outcome_event <- rep_len(1L, length.out = n_series_instances) + outcome_event[censor_time < outcome_time] <- 0L + outcome_time[outcome_event == 0L] <- censor_time[outcome_event == 0L] - } else if (outcome_type == "count") { - # Load the Boston Housing data set - data <- data.table::as.data.table(MASS::Boston) - - # Rename columns - data.table::setnames(data, - old = c( - "crim", "zn", "indus", "chas", "nox", "rm", "age", "dis", "rad", - "tax", "ptratio", "black", "lstat", "medv"), - new = c( - "per_capita_crime", "large_residence_proportion", "industry", "by_charles_river", - "nox_concentration", "avg_rooms", "residence_before_1940_proportion", - "distance_to_employment_centres", "radial_highway_accessibility", "property_tax_rate", - "pupil_teacher_ratio", "african_american_metric", "lower_status_percentage", "median_house_value" - ) - ) - - # Convert by_charles_river to a factor. - data$by_charles_river <- factor( - x = data$by_charles_river, - levels = c(0, 1), - labels = c("no", "yes")) - - # Convert the median_house_value to the actual value. - data[, "median_house_value" := median_house_value * 1000.0] - - # Limit to 150 samples - data <- data[1:150, ] - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Convert to a data object. - if (to_data_object) { - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "median_house_value", - outcome_type = outcome_type) - } } else { ..error_outcome_type_not_implemented(outcome_type) } - + + # Create basic table. + data <- data.table::data.table( + "batch_id" = "basic", + "sample_id" = paste0("sample_", seq_len(n_series_instances)), + "series_id" = 1L, + "feature_1" = feature_1, + "feature_2a" = feature_2a, + "feature_2b" = feature_2b, + "feature_3a" = cut( + x = feature_3a, + breaks = c(0.0, 0.5, 1.0), + labels = c("round", "square") + ), + "feature_3b" = cut( + x = feature_3b, + breaks = c(-1.0, 0.5, 2.0), + labels = c("sphere", "cube") + ), + "feature_4" = cut( + x = feature_4, + breaks = c(0.0, 0.333, 0.667, 1.0), + labels = c("good", "better", "best"), + ordered_result = TRUE + ) + ) + + # Add outcome. + if (outcome_type %in% "survival") { + data[, ":="( + "outcome_time" = outcome_time, + "outcome_event" = outcome_event + )] + outcome_column <- c("outcome_time", "outcome_event") + + } else { + data[, ":="("outcome" = outcome_value)] + outcome_column <- "outcome" + } + + # Update batch_id + if (two_groups) { + data[1L:75L, "batch_id" := "group_a"] + data[76L:150L, "batch_id" := "group_b"] + } + + # Convert to a data object. + if (to_data_object) { + data <- as_data_object( + data = data, + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = outcome_column, + outcome_type = outcome_type + ) + } + return(data) } @@ -193,32 +149,35 @@ test_create_small_good_data <- function(outcome_type) { # Now select a subset of the data. data@data <- data@data[fam_sample( seq_len(nrow(data@data)), - size = 30, + size = 30L, replace = FALSE, - seed = 1844)] + seed = 1844L + )] return(data) } +test_create_reverse_column_order_data <- function(outcome_type) { + # Create good dataset with reversed column order. + data <- test_create_good_data(outcome_type = outcome_type) + + # Reverse column order. + column_names <- colnames(data@data) + data.table::setcolorder(x = data@data, neworder = rev(column_names)) + + return(data) +} + + + test_create_invariant_good_data <- function(outcome_type) { # Create good dataset with one invariant feature. # Create good dataset first and work from there. data <- test_create_good_data(outcome_type = outcome_type) - - if (outcome_type == "survival") { - data@data[, "nodes" := 4.0] - } else if (outcome_type == "binomial") { - data@data[, "clump_thickness" := 4.0] - } else if (outcome_type == "multinomial") { - data@data[, "Sepal_Length" := 3.0] - } else if (outcome_type == "continuous") { - data@data[, "calwpct" := 5.0] - } else if (outcome_type == "count") { - data@data[, "industry" := 3.0] - } + data@data[, "feature_2a" := 0.5] return(data) } @@ -234,7 +193,7 @@ test_create_good_data_without_censoring <- function(outcome_type) { data <- test_create_good_data(outcome_type = outcome_type) # Set all data to event. - data@data[, "outcome_event" := 1] + data@data[, "outcome_event" := 1L] return(data) } @@ -250,10 +209,10 @@ test_create_good_data_one_censored <- function(outcome_type) { data <- test_create_good_data(outcome_type = outcome_type) # Set all data to event. - data@data[, "outcome_event" := 1] + data@data[, "outcome_event" := 1L] # Set one instance to censored. - data@data[1L, "outcome_event" := 0] + data@data[1L, "outcome_event" := 0L] return(data) } @@ -268,10 +227,10 @@ test_create_good_data_few_censored <- function(outcome_type) { data <- test_create_good_data(outcome_type = outcome_type) # Set all data to event. - data@data[, "outcome_event" := 1] + data@data[, "outcome_event" := 1L] # Set a few instances to censored. - data@data[seq_len(4), "outcome_event" := 0] + data@data[seq_len(4L), "outcome_event" := 0L] return(data) } @@ -281,8 +240,9 @@ test_create_good_data_few_censored <- function(outcome_type) { test_create_good_data_random_missing <- function( outcome_type, n_missing_frac = 0.05, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Some data points are NA, but not instances. if (!is.null(seed) && is.null(rstream_object)) { rstream_object <- .start_random_number_stream(seed = seed) @@ -304,12 +264,15 @@ test_create_good_data_random_missing <- function( seq_len(n_rows), size = n_randomise, replace = TRUE, - rstream_object = rstream_object), + rstream_object = rstream_object + ), "feature" = fam_sample( feature_columns, size = n_randomise, replace = TRUE, - rstream_object = rstream_object)) + rstream_object = rstream_object + ) + ) # Select only unique data points. random_data <- unique(random_data) @@ -318,7 +281,8 @@ test_create_good_data_random_missing <- function( random_data <- split( random_data, by = "feature", - drop = TRUE) + drop = TRUE + ) # Update feature columns. for (feature in feature_columns) { @@ -336,54 +300,72 @@ test_create_good_data_random_missing <- function( } + +test_create_single_relevant_feature_data <- function(outcome_type) { + # Multiple features, but only one relevant. + + # Create dataset. + data <- test_create_good_data( + outcome_type = outcome_type, + one_relevant_feature = TRUE + ) + + return(data) +} + + + test_create_empty_data <- function(outcome_type) { # Create good dataset first and work from there. data <- test_create_good_data(outcome_type = outcome_type) # Now empty the data. - data@data <- head(data@data, n = 0) + data@data <- head(data@data, n = 0L) return(data) } -test_create_data_without_feature <- function(outcome_type) { +test_create_data_without_feature <- function(outcome_type, to_data_object = TRUE) { # Create good dataset first and work from there. data <- test_create_good_data(outcome_type) # Remove features. data@data <- data@data[, mget(get_non_feature_columns(outcome_type))] + if (!to_data_object) data <- data@data + return(data) } -test_create_bootstrapped_data <- function(outcome_type, to_data_object = TRUE) { +test_create_bootstrapped_data <- function(outcome_type, seed = 1844L, to_data_object = TRUE) { # Suppress NOTES due to non-standard evaluation in data.table sample_id <- NULL # Create good dataset first and work from there. data <- test_create_good_data( outcome_type = outcome_type, - to_data_object = to_data_object) + to_data_object = to_data_object + ) # Now keep only the first sample. if (to_data_object) { - data@data <- data@data[ - fam_sample(seq_len(nrow(data@data)), + data@data <- data@data[fam_sample( + seq_len(nrow(data@data)), size = nrow(data@data), replace = TRUE, - seed = 1844 + seed = seed )][order(sample_id)] } else { - data@data <- data[ - fam_sample(seq_len(nrow(data)), + data@data <- data[fam_sample( + seq_len(nrow(data)), size = nrow(data), replace = TRUE, - seed = 1844 + seed = seed )][order(sample_id)] } @@ -396,13 +378,14 @@ test_create_one_sample_data <- function(outcome_type, to_data_object = TRUE) { # Create good dataset first and work from there. data <- test_create_good_data( outcome_type = outcome_type, - to_data_object = to_data_object) + to_data_object = to_data_object + ) # Now keep only the first sample. if (to_data_object) { - data@data <- head(data@data, n = 1) + data@data <- head(data@data, n = 1L) } else { - data <- head(data, n = 1) + data <- head(data, n = 1L) } return(data) @@ -415,13 +398,13 @@ test_create_all_identical_data <- function(outcome_type) { data <- test_create_good_data(outcome_type = outcome_type) # Now keep only the first sample. - data@data <- head(data@data, n = 1) + data@data <- head(data@data, n = 1L) # Fill the dataset with the same sample. - data@data <- data@data[rep.int(1L, 10)] + data@data <- data@data[rep.int(1L, 10L)] # Set unique subject ids. - data@data[, "sample_id" := .I] + data@data[, "sample_id" := paste0("sample_", seq_len(nrow(data@data)))] return(data) } @@ -429,143 +412,16 @@ test_create_all_identical_data <- function(outcome_type) { test_create_single_feature_data <- function(outcome_type) { - # Suppress NOTES due to non-standard evaluation in data.table - etype <- median_house_value <- NULL - - if (outcome_type == "survival") { - # Load colon dataset from the survival package - data <- data.table::as.data.table(survival::colon) - - # Recurrence - data <- data[etype == 1] - - # Limit to 150 samples - data <- data[1:150, ] - - # update sample identifier. - data[, ":="("id" = .I)] - - # Keep only first 150 samples for speed and only id, nodes, rx, extent, - # adhere and outcome. - data <- as_data_object( - data = data, - sample_id_column = "id", - outcome_column = c("time", "status"), - outcome_type = outcome_type, - include_features = c("nodes")) - - } else if (outcome_type == "multinomial") { - # Load iris data set. - data <- data.table::as.data.table(datasets::iris) - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "Species", - outcome_type = outcome_type, - include_features = c("Petal.Length")) - - } else if (outcome_type == "binomial") { - # Load the cancer breast biopsy data set. - data <- data.table::as.data.table(MASS::biopsy) - - # Rename columns. - data.table::setnames(data, - old = c("ID", "V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "class"), - new = c( - "id", "clump_thickness", "cell_size_uniformity", "cell_shape_uniformity", - "marginal_adhesion", "epithelial_cell_size", "bare_nuclei", - "bland_chromatin", "normal_nucleoli", "mitoses", "cell_malignancy" - ) - ) - - # Keep unique samples. Some samples have the same id, but a different - # outcome. - data <- unique(data, by = "id") - - # Limit to 150 samples - data <- data[1:150, ] - - # update sample identifier. - data[, ":="("id" = .I)] - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "id", - outcome_column = "cell_malignancy", - outcome_type = outcome_type, - class_levels = c("benign", "malignant"), - include_features = "cell_size_uniformity" - ) - } else if (outcome_type == "continuous") { - # Load the California Test Score Data Set - data <- data.table::data.table(Ecdat::Caschool) - - # Drop distcod, district, county, readscr, mathscr - data[, ":="( - "distcod" = NULL, - "district" = NULL, - "county" = NULL, - "readscr" = NULL, - "mathscr" = NULL)] - - # Limit to 150 samples - data <- data[271:420, ] - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "testscr", - outcome_type = outcome_type, - include_features = "avginc") - - } else if (outcome_type == "count") { - # Load the Boston Housing data set - data <- data.table::as.data.table(MASS::Boston) - - # Rename columns - data.table::setnames(data, - old = c( - "crim", "zn", "indus", "chas", "nox", "rm", "age", "dis", "rad", - "tax", "ptratio", "black", "lstat", "medv"), - new = c( - "per_capita_crime", "large_residence_proportion", "industry", "by_charles_river", - "nox_concentration", "avg_rooms", "residence_before_1940_proportion", - "distance_to_employment_centres", "radial_highway_accessibility", "property_tax_rate", - "pupil_teacher_ratio", "african_american_metric", "lower_status_percentage", "median_house_value")) - - # Convert by_charles_river to a factor. - data$by_charles_river <- factor(x = data$by_charles_river, levels = c(0, 1), labels = c("no", "yes")) - - # Convert the median_house_value to the actual value. - data[, "median_house_value" := median_house_value * 1000.0] - - # Limit to 150 samples - data <- data[1:150, ] - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "median_house_value", - outcome_type = outcome_type, - include_features = "lower_status_percentage") - - } else { - ..error_outcome_type_not_implemented(outcome_type) - } + # Create good dataset first and work from there. + data <- test_create_good_data(outcome_type = outcome_type) + + data@data[, ":="( + "feature_2a" = NULL, + "feature_2b" = NULL, + "feature_3a" = NULL, + "feature_3b" = NULL, + "feature_4" = NULL + )] return(data) } @@ -577,7 +433,7 @@ test_create_single_feature_one_sample_data <- function(outcome_type) { data <- test_create_single_feature_data(outcome_type = outcome_type) # Now keep only the first sample. - data@data <- head(data@data, n = 1) + data@data <- head(data@data, n = 1L) return(data) } @@ -592,7 +448,7 @@ test_create_single_feature_invariant_data <- function(outcome_type) { feature_column <- get_feature_columns(data) # Set the feature to a fixed value. - data@data[, (feature_column) := data@data[[feature_column]][1]] + data@data[, (feature_column) := data@data[[feature_column]][1L]] return(data) } @@ -618,290 +474,27 @@ test_create_single_feature_two_values_data <- function(outcome_type) { test_create_wide_data <- function(outcome_type) { - # Suppress NOTES due to non-standard evaluation in data.table - etype <- median_house_value <- NULL - # Create random stream object so that the same numbers are produced every # time. - r <- .start_random_number_stream(seed = 1844) - - if (outcome_type == "survival") { - # Load colon dataset from the survival package - data <- data.table::as.data.table(survival::colon) - - # Recurrence - data <- data[etype == 1] - - # Remove superfluous columns - data[, ":="("study" = NULL, "node4" = NULL, "etype" = NULL)] - - # Refactor columns - data$sex <- factor( - x = data$sex, - levels = c(0, 1), - labels = c("female", "male")) - data$obstruct <- factor( - x = data$obstruct, - levels = c(0, 1), - labels = c(FALSE, TRUE)) - data$perfor <- factor( - x = data$perfor, - levels = c(0, 1), - labels = c(FALSE, TRUE)) - data$adhere <- factor( - x = data$adhere, - levels = c(0, 1), - labels = c(FALSE, TRUE)) - data$differ <- factor( - x = data$differ, - levels = c(1, 2, 3), - labels = c("well", "moderate", "poor"), - ordered = TRUE) - data$extent <- factor( - x = data$extent, - levels = c(1, 2, 3, 4), - labels = c("submucosa", "muscle", "serosa", "contiguous_structures"), - ordered = TRUE) - data$surg <- factor( - x = data$surg, - levels = c(0, 1), - labels = c("short", "long")) - - # Make the dataset small and wide (10 features) - data <- data[1:5, ] - data$status <- 1 - - # update sample identifier. - data[, ":="("id" = .I)] - - # Add twenty random features - random_data <- lapply( - seq_len(20), - function(ii, n, r) fam_rnorm(n = n, rstream_object = r), - n = nrow(data), - r = r) - names(random_data) <- paste0("random_", seq_len(20)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Keep only first 100 samples for speed and only id, nodes, rx, extent and - # outcome. - data <- as_data_object( - data = data, - sample_id_column = "id", - outcome_column = c("time", "status"), - outcome_type = outcome_type) - - } else if (outcome_type == "multinomial") { - # Load iris data set. - data <- data.table::as.data.table(datasets::iris) - - # Squeeze data - data <- data[c(1, 2, 3, 80, 81, 82, 148, 149, 150)] - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Add twenty random features - random_data <- lapply( - seq_len(20), - function(ii, n, r) fam_rnorm(n = n, rstream_object = r), - n = nrow(data), - r = r) - names(random_data) <- paste0("random_", seq_len(20)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Add another 3 random features - random_data <- lapply( - seq_len(3), - function(ii, n, r) { - return(factor(fam_sample( - c("red", "green", "blue"), - size = n, - replace = TRUE, - rstream_object = r))) - }, - n = nrow(data), - r = r) - names(random_data) <- paste0("random_categorical_", seq_len(3)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "Species", - outcome_type = outcome_type) - - } else if (outcome_type == "binomial") { - # Load the cancer breast biopsy data set. - data <- data.table::as.data.table(MASS::biopsy) - - # Rename columns. - data.table::setnames(data, - old = c( - "ID", "V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "class"), - new = c( - "id", "clump_thickness", "cell_size_uniformity", "cell_shape_uniformity", - "marginal_adhesion", "epithelial_cell_size", "bare_nuclei", - "bland_chromatin", "normal_nucleoli", "mitoses", "cell_malignancy") - ) + r <- .start_random_number_stream(seed = 1844L) - # Keep unique samples. Some samples have the same id, but a different - # outcome. - data <- unique(data, by = "id") - - # Limit to 10 samples - data <- data[11:20, ] - - # update sample identifier. - data[, ":="("id" = .I)] - - # Add twenty random features - random_data <- lapply( - seq_len(20), - function(ii, n, r) fam_rnorm(n = n, rstream_object = r), - n = nrow(data), - r = r) - names(random_data) <- paste0("random_", seq_len(20)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Add another 3 random features - random_data <- lapply( - seq_len(3), - function(ii, n, r) { - return(factor(fam_sample( - c("red", "green", "blue"), - size = n, - replace = TRUE, - rstream_object = r))) - }, - n = nrow(data), - r = r) - names(random_data) <- paste0("random_categorical_", seq_len(3)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "id", - outcome_column = "cell_malignancy", - outcome_type = outcome_type, - class_levels = c("benign", "malignant")) - - } else if (outcome_type == "continuous") { - # Load the California Test Score Data Set - data <- data.table::data.table(Ecdat::Caschool) + data <- test_create_good_data( + outcome_type = outcome_type, + rstream_object = r + ) + + # Add twenty random features + random_data <- lapply( + seq_len(20L), + function(ii, n, r) fam_rnorm(n = n, rstream_object = r), + n = nrow(data@data), + r = r + ) + names(random_data) <- paste0("random_feature_", seq_len(20L)) + + # Add to dataset + data@data <- cbind(data@data, data.table::as.data.table(random_data)) - # Drop distcod, district, county, readscr, mathscr - data[, ":="( - "distcod" = NULL, - "district" = NULL, - "county" = NULL, - "readscr" = NULL, - "mathscr" = NULL)] - - # Limit to 10 samples - data <- data[411:420, ] - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Add twenty random features - random_data <- lapply( - seq_len(20), - function(ii, n, r) fam_rnorm(n = n, rstream_object = r), - n = nrow(data), - r = r) - names(random_data) <- paste0("random_", seq_len(20)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "testscr", - outcome_type = outcome_type) - - } else if (outcome_type == "count") { - # Load the Boston Housing data set - data <- data.table::as.data.table(MASS::Boston) - - # Rename columns - data.table::setnames(data, - old = c( - "crim", "zn", "indus", "chas", "nox", "rm", "age", "dis", "rad", - "tax", "ptratio", "black", "lstat", "medv"), - new = c( - "per_capita_crime", "large_residence_proportion", "industry", "by_charles_river", - "nox_concentration", "avg_rooms", "residence_before_1940_proportion", - "distance_to_employment_centres", "radial_highway_accessibility", "property_tax_rate", - "pupil_teacher_ratio", "african_american_metric", "lower_status_percentage", "median_house_value")) - - # Convert by_charles_river to a factor. - data$by_charles_river <- factor( - x = data$by_charles_river, - levels = c(0, 1), - labels = c("no", "yes")) - - # Convert the median_house_value to the actual value. - data[, "median_house_value" := median_house_value * 1000.0] - - # Limit to 10 samples - data <- data[1:10, ] - - # Add sample identifier. - data[, ":="("sample_id" = .I)] - - # Add twenty random features - random_data <- lapply( - seq_len(20), - function(ii, n, r) fam_rnorm(n = n, rstream_object = r), - n = nrow(data), - r = r) - names(random_data) <- paste0("random_", seq_len(20)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Add another 3 random features - random_data <- lapply( - seq_len(3), - function(ii, n, r) { - return(factor(fam_sample( - c("red", "green", "blue"), - size = n, - replace = TRUE, - rstream_object = r))) - }, - n = nrow(data), - r = r) - names(random_data) <- paste0("random_categorical_", seq_len(3)) - - # Add to dataset - data <- cbind(data, data.table::as.data.table(random_data)) - - # Convert to a data object. - data <- as_data_object( - data = data, - sample_id_column = "sample_id", - outcome_column = "median_house_value", - outcome_type = outcome_type) - - } else { - ..error_outcome_type_not_implemented(outcome_type) - } return(data) } @@ -922,13 +515,13 @@ test_create_bad_data <- function(outcome_type, add_na_data = FALSE) { if (outcome_type == "survival") { # For survival data it would be really bad if all data are censored. - data@data[, "outcome_event" := 0] + data@data[, "outcome_event" := 0L] } else if (outcome_type == "multinomial") { # For multinomial data, having not all classes is bad. if (add_na_data) { - # Assign NA to the rows containing the virginica class. + # Assign NA to the rows containing the "red" class. # Identify the feature columns. feature_columns <- get_feature_columns(data) @@ -936,21 +529,21 @@ test_create_bad_data <- function(outcome_type, add_na_data = FALSE) { # Update feature columns. for (feature in feature_columns) { if (is.factor(data@data[[feature]])) { - data@data[outcome == "virginica", (feature) := NA] + data@data[outcome == "red", (feature) := NA] } else { - data@data[outcome == "virginica", (feature) := NA_real_] + data@data[outcome == "red", (feature) := NA_real_] } } } else { - # Select 2 of 3 classes by leaving virginica out. - data@data <- data@data[outcome %in% c("setosa", "versicolor"), ] + # Select 2 of 3 classes by leaving red out. + data@data <- data@data[outcome %in% c("blue", "green"), ] } } else if (outcome_type == "binomial") { # For binomial data, having a single class is bad. if (add_na_data) { - # Assign NA to the rows containing the malignant class. + # Assign NA to the rows containing the red class. # Identify the feature columns. feature_columns <- get_feature_columns(data) @@ -958,23 +551,19 @@ test_create_bad_data <- function(outcome_type, add_na_data = FALSE) { # Update feature columns. for (feature in feature_columns) { if (is.factor(data@data[[feature]])) { - data@data[outcome == "malignant", (feature) := NA] + data@data[outcome == "red", (feature) := NA] } else { - data@data[outcome == "malignant", (feature) := NA_real_] + data@data[outcome == "red", (feature) := NA_real_] } } } else { - # Assign everything to the benign class. - data@data[, "outcome" := "benign"] + # Assign everything to the green class. + data@data[, "outcome" := "green"] } } else if (outcome_type == "continuous") { # For continuous data, it would be bad if all outcome values are invariant. - data@data[, "outcome" := 500.0] - - } else if (outcome_type == "count") { - # For count data it would be bad if all outcome values are invariant - data@data[, "outcome" := 50000] + data@data[, "outcome" := 1.0] } else { ..error_outcome_type_not_implemented(outcome_type) @@ -989,10 +578,12 @@ test_create_small_bad_data <- function(outcome_type) { data <- test_create_bad_data(outcome_type = outcome_type) # Now select a subset of the data. - data@data <- data@data[fam_sample(seq_len(nrow(data@data)), - size = 30, + data@data <- data@data[fam_sample( + seq_len(nrow(data@data)), + size = 30L, replace = FALSE, - seed = 1844)] + seed = 1844L + )] return(data) } @@ -1005,9 +596,14 @@ test_create_prospective_data <- function(outcome_type) { data <- test_create_good_data(outcome_type = outcome_type) if (outcome_type %in% c("survival", "competing_risk")) { - data@data[, ":="( - "outcome_time" = NA, - "outcome_event" = NA)] + data@data[ + , + ":="( + "outcome_time" = NA, + "outcome_event" = NA_integer_ + ) + ] + } else { data@data[, ":="("outcome" = NA)] } @@ -1023,11 +619,16 @@ test_create_partially_prospective_data <- function(outcome_type) { data <- test_create_good_data(outcome_type = outcome_type) if (outcome_type %in% c("survival", "competing_risk")) { - data@data[c(1, 2), ":="( - "outcome_time" = NA, - "outcome_event" = NA)] + data@data[ + c(1L, 2L), + ":="( + "outcome_time" = NA, + "outcome_event" = NA_integer_ + ) + ] + } else { - data@data[c(1, 2), ":="("outcome" = NA)] + data@data[c(1L, 2L), ":="("outcome" = NA)] } return(data) @@ -1044,11 +645,16 @@ test_create_mostly_prospective_data <- function(outcome_type) { data <- test_create_good_data(outcome_type = outcome_type) if (outcome_type %in% c("survival", "competing_risk")) { - data@data[sample_id > 1L, ":="( - "outcome_time" = NA, - "outcome_event" = NA)] + data@data[ + sample_id != "sample_1", + ":="( + "outcome_time" = NA, + "outcome_event" = NA_integer_ + ) + ] + } else { - data@data[sample_id > 1L, ":="("outcome" = NA)] + data@data[sample_id != "sample_1", ":="("outcome" = NA)] } return(data) @@ -1058,14 +664,15 @@ test_create_mostly_prospective_data <- function(outcome_type) { test_create_synthetic_series_data <- function( outcome_type, - n_batch = 3, - n_samples = 10, - n_series = 3, - n_rep = 3, + n_batch = 3L, + n_samples = 10L, + n_series = 3L, + n_rep = 3L, n_numeric = 4L, rare_outcome = FALSE, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table batch_id <- feature_1 <- feature_2 <- feature_3 <- feature_4 <- NULL @@ -1080,7 +687,7 @@ test_create_synthetic_series_data <- function( # Determine the number of series instances. n_series_instances <- n_batch * n_samples * n_series - # Draw random numbers for three features. + # Draw random numbers for four features. feature_1 <- fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r) feature_2 <- fam_runif(n = n_series_instances, min = 0.0, max = 2.0, rstream_object = r) feature_3 <- fam_runif(n = n_series_instances, min = 0.0, max = 2.0, rstream_object = r) @@ -1095,7 +702,8 @@ test_create_synthetic_series_data <- function( outcome_value <- factor( x = outcome_value, levels = c(FALSE, TRUE), - labels = c("0", "1")) + labels = c("0", "1") + ) } else if (outcome_type == "multinomial") { outcome_value <- numeric(n_series_instances) @@ -1110,25 +718,24 @@ test_create_synthetic_series_data <- function( outcome_value <- factor( x = outcome_value, levels = c(0.0, 1.0, 2.0, 3.0), - labels = c("0", "1", "2", "3")) + labels = c("0", "1", "2", "3") + ) } else { outcome_value <- factor( x = outcome_value, levels = c(0.0, 1.0, 2.0), - labels = c("0", "1", "2")) + labels = c("0", "1", "2") + ) } } else if (outcome_type == "continuous") { outcome_value <- outcome_raw - } else if (outcome_type == "count") { - outcome_value <- round(outcome_raw * 100) - } else if (outcome_type == "survival") { # Outcome follows an exponential distribution. outcome_time <- exp(outcome_raw) - outcome_event <- rep_len(1, length.out = n_series_instances) + outcome_event <- rep_len(1L, length.out = n_series_instances) } else { ..error_outcome_type_not_implemented(outcome_type) @@ -1143,13 +750,15 @@ test_create_synthetic_series_data <- function( "feature_1" = feature_1, "feature_2" = feature_2, "feature_3" = feature_3, - "feature_4" = feature_4) + "feature_4" = feature_4 + ) # Add outcome. if (outcome_type %in% "survival") { data[, ":="( "outcome_time" = outcome_time, - "outcome_event" = outcome_event)] + "outcome_event" = outcome_event + )] outcome_column <- c("outcome_time", "outcome_event") } else { @@ -1162,10 +771,11 @@ test_create_synthetic_series_data <- function( "feature_1" = feature_1 + batch_id - 1.0, "feature_2" = feature_2 + batch_id - 1.0, "feature_3" = feature_3 + batch_id - 1.0, - "feature_4" = feature_4 + batch_id - 1.0)] + "feature_4" = feature_4 + batch_id - 1.0 + )] # Create repetitions. - if (n_rep > 1) { + if (n_rep > 1L) { repeated_rows <- rep(seq_len(n_series_instances), each = n_rep) data <- data[repeated_rows, ] @@ -1174,7 +784,8 @@ test_create_synthetic_series_data <- function( "feature_1" = feature_1 + fam_rnorm(n = n_rep * n_series_instances, mean = 0.0, sd = 0.125, rstream_object = r), "feature_2" = feature_2 + fam_rnorm(n = n_rep * n_series_instances, mean = 0.0, sd = 0.125, rstream_object = r), "feature_3" = feature_3 + fam_rnorm(n = n_rep * n_series_instances, mean = 0.0, sd = 0.125, rstream_object = r), - "feature_4" = feature_4 + fam_rnorm(n = n_rep * n_series_instances, mean = 0.0, sd = 0.125, rstream_object = r))] + "feature_4" = feature_4 + fam_rnorm(n = n_rep * n_series_instances, mean = 0.0, sd = 0.125, rstream_object = r) + )] data[feature_1 <= 0.0, "feature_1" := 0.01] data[feature_2 <= 0.0, "feature_2" := 0.01] @@ -1182,10 +793,10 @@ test_create_synthetic_series_data <- function( data[feature_4 <= 0.0, "feature_4" := 0.01] } - if (n_numeric < 4) data$feature_1 <- factor(floor(data$feature_1)) - if (n_numeric < 3) data$feature_2 <- factor(floor(data$feature_2)) - if (n_numeric < 2) data$feature_3 <- factor(floor(data$feature_3)) - if (n_numeric < 1) data$feature_4 <- factor(floor(data$feature_4)) + if (n_numeric < 4L) data$feature_1 <- factor(floor(data$feature_1)) + if (n_numeric < 3L) data$feature_2 <- factor(floor(data$feature_2)) + if (n_numeric < 2L) data$feature_3 <- factor(floor(data$feature_3)) + if (n_numeric < 1L) data$feature_4 <- factor(floor(data$feature_4)) # Convert to a data object. data <- as_data_object( @@ -1205,21 +816,23 @@ test_create_synthetic_series_data <- function( test_create_synthetic_series_one_outcome <- function( outcome_type, n_numeric = 4L, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Create test data. data <- test_create_synthetic_series_data( outcome_type = outcome_type, n_numeric = n_numeric, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) if (outcome_type %in% c("binomial", "multinomial")) { data@data[, "outcome" := "0"] - } else if (outcome_type %in% c("count", "continuous")) { - data@data[, "outcome" := 1] + } else if (outcome_type %in% c("continuous")) { + data@data[, "outcome" := 1L] } else if (outcome_type == "survival") { - data@data[, ":="("outcome_time" = 1.25, "outcome_event" = 1)] + data@data[, ":="("outcome_time" = 1.25, "outcome_event" = 1L)] } else { ..error_outcome_type_not_implemented(outcome_type) } @@ -1232,14 +845,16 @@ test_create_synthetic_series_one_outcome <- function( test_create_synthetic_series_one_sample_data <- function( outcome_type, n_numeric = 4L, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Create test data. data <- test_create_synthetic_series_data( outcome_type = outcome_type, n_numeric = n_numeric, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Select the first instance data@data <- head(data@data, n = 1L) @@ -1252,20 +867,22 @@ test_create_synthetic_series_one_sample_data <- function( test_create_synthetic_series_invariant_feature_data <- function( outcome_type, n_numeric = 4L, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Create test data. data <- test_create_synthetic_series_data( outcome_type = outcome_type, n_numeric = n_numeric, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Select the first instance - data@data$feature_1 <- data@data$feature_1[1] - data@data$feature_2 <- data@data$feature_2[1] - data@data$feature_3 <- data@data$feature_3[1] - data@data$feature_4 <- data@data$feature_4[1] + data@data$feature_1 <- data@data$feature_1[1L] + data@data$feature_2 <- data@data$feature_2[1L] + data@data$feature_3 <- data@data$feature_3[1L] + data@data$feature_4 <- data@data$feature_4[1L] return(data) } @@ -1275,17 +892,19 @@ test_create_synthetic_series_invariant_feature_data <- function( test_create_synthetic_series_one_feature_invariant_data <- function( outcome_type, n_numeric = 4L, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Create test data. data <- test_create_synthetic_series_data( outcome_type = outcome_type, n_numeric = n_numeric, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Select the first instance for feature 2. - data@data$feature_2 <- data@data$feature_2[1] + data@data$feature_2 <- data@data$feature_2[1L] return(data) } @@ -1296,8 +915,9 @@ test_create_synthetic_series_na_data <- function( outcome_type, n_numeric = 4L, n_missing_frac = 0.1, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Some instances are completely NA. # Create test data. @@ -1305,15 +925,18 @@ test_create_synthetic_series_na_data <- function( outcome_type = outcome_type, n_numeric = n_numeric, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Select which rows will be updated. n_rows <- nrow(data@data) - na_rows <- fam_sample(seq_len(n_rows), + na_rows <- fam_sample( + seq_len(n_rows), size = ceiling(n_missing_frac * n_rows), replace = FALSE, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Identify the feature columns. feature_columns <- get_feature_columns(data) @@ -1336,8 +959,9 @@ test_create_synthetic_series_random_na_data <- function( outcome_type, n_numeric = 4L, n_missing_frac = 0.1, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Some data points are NA, but not instances. if (!is.null(seed) && is.null(rstream_object)) { @@ -1363,11 +987,13 @@ test_create_synthetic_series_random_na_data <- function( "row_id" = fam_sample(seq_len(n_rows), size = n_randomise, replace = TRUE, - rstream_object = rstream_object), + rstream_object = rstream_object + ), "feature" = fam_sample(feature_columns, size = n_randomise, replace = TRUE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) ) # Select only unique data points. @@ -1396,8 +1022,9 @@ test_create_synthetic_series_random_na_data <- function( test_create_synthetic_series_one_feature_all_na_data <- function( outcome_type, n_numeric = 4L, - seed = 1844, - rstream_object = NULL) { + seed = 1844L, + rstream_object = NULL +) { # Suppress NOTES due to non-standard evaluation in data.table feature_2 <- NULL @@ -1406,7 +1033,8 @@ test_create_synthetic_series_one_feature_all_na_data <- function( outcome_type = outcome_type, n_numeric = n_numeric, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Set the first feature column to NA. if (is.factor(data@data[["feature_2"]])) { @@ -1430,7 +1058,9 @@ test_create_multiple_synthetic_series <- function(outcome_type) { # Find new feature columns for the correlated features new_feature_columns <- paste0( - "feature_", seq_along(original_feature_columns) + length(original_feature_columns)) + "feature_", + seq_along(original_feature_columns) + length(original_feature_columns) + ) # Add in correlated features. for (ii in seq_along(original_feature_columns)) { @@ -1444,8 +1074,9 @@ test_create_multiple_synthetic_series <- function(outcome_type) { data_1 <- test_create_synthetic_series_data( outcome_type = outcome_type, n_numeric = 3L, - n_samples = 20, - seed = 1) + n_samples = 20L, + seed = 1L + ) # Add correlated features. data_1 <- ..extend_feature_set(data_1) @@ -1454,16 +1085,18 @@ test_create_multiple_synthetic_series <- function(outcome_type) { data_2 <- test_create_synthetic_series_data( outcome_type = outcome_type, n_numeric = 3L, - n_samples = 20, - seed = 2) + n_samples = 20L, + seed = 2L + ) # Do not add correlated features to dataset 2. # Draw a third dataset. data_3 <- test_create_synthetic_series_data( outcome_type = outcome_type, n_numeric = 3L, - n_samples = 20, - seed = 3) + n_samples = 20L, + seed = 3L + ) # Add correlated features, but remove the original features. data_3 <- ..extend_feature_set(data_3) @@ -1471,14 +1104,15 @@ test_create_multiple_synthetic_series <- function(outcome_type) { "feature_1" = NULL, "feature_2" = NULL, "feature_3" = NULL, - "feature_4" = NULL)] + "feature_4" = NULL + )] # Draw a fourth dataset that cannot be used for training, e.g. contains just # one sample. data_4 <- test_create_synthetic_series_one_outcome( outcome_type = outcome_type, n_numeric = 3L, - seed = 4 + seed = 4L ) # Add correlated features. @@ -1488,7 +1122,8 @@ test_create_multiple_synthetic_series <- function(outcome_type) { "set_1" = data_1, "set_2" = data_2, "set_3" = data_3, - "set_4" = data_4)) + "set_4" = data_4 + )) } @@ -1496,11 +1131,12 @@ test_create_multiple_synthetic_series <- function(outcome_type) { test_create_synthetic_correlated_data <- function( ..., - seed = 1844, + seed = 1844L, rstream_object = NULL, - cluster_size = c(1, 1, 1, 1), + cluster_size = c(1L, 1L, 1L, 1L), mix_feature_types = TRUE, - allow_anti_correlation = TRUE) { + allow_anti_correlation = TRUE +) { # Create random stream object so that the same numbers are produced every # time. if (is.null(rstream_object)) { @@ -1514,10 +1150,12 @@ test_create_synthetic_correlated_data <- function( test_create_synthetic_series_data, args = c( list("rstream_object" = r), - list(...))) + list(...) + ) + ) if (length(cluster_size) != get_n_features(base_data)) { - stop(paste0("The cluster_size argument should match the number of features.")) + ..error(paste0("The cluster_size argument should match the number of features.")) } # Get feature names prior to extending the dataset. @@ -1529,7 +1167,7 @@ test_create_synthetic_correlated_data <- function( for (ii in seq_along(cluster_size)) { # Skip if no clusters are required. - if (cluster_size[ii] == 1) next() + if (cluster_size[ii] == 1L) next # Isolate feature data. Force reading this data just in case. x <- base_data@data[[original_feature_names[ii]]] @@ -1539,13 +1177,14 @@ test_create_synthetic_correlated_data <- function( # Create the name of the new feature. new_feature_name <- paste0(original_feature_names[ii], "_", LETTERS[jj]) - if (jj == 1) { + if (jj == 1L) { # The first feature should just be renamed. data.table::setnames(data@data, old = original_feature_names[ii], - new = new_feature_name) + new = new_feature_name + ) - } else if (jj == 2 && is.factor(x) && mix_feature_types) { + } else if (jj == 2L && is.factor(x) && mix_feature_types) { # Add numeric feature when mixing data types. data@data[, (new_feature_name) := as.numeric(x) * 1.1] @@ -1553,11 +1192,15 @@ test_create_synthetic_correlated_data <- function( # For categorical features, remix the levels. y <- factor(x, levels = levels(x), - labels = levels(x)[fam_sample( - seq_along(levels(x)), - size = length(levels(x)), - replace = FALSE, - rstream_object = r)]) + labels = levels(x)[ + fam_sample( + seq_along(levels(x)), + size = nlevels(x), + replace = FALSE, + rstream_object = r + ) + ] + ) # Set feature. data@data[, (new_feature_name) := y] @@ -1566,7 +1209,7 @@ test_create_synthetic_correlated_data <- function( # For numerical features, introduce an offset and scaling. We scale # between 0.5 and 1.5 or -0.5 and -1.5 to avoid multiplying by 0. The # negative values are used for strong anti-correlation, which - if (jj %% 2 == 0 || !allow_anti_correlation) { + if (jj %% 2L == 0L || !allow_anti_correlation) { r_scale <- fam_runif(n = 1L, min = 0.5, max = 1.5, rstream_object = r) } else { r_scale <- fam_runif(n = 1L, min = -1.5, max = -0.5, rstream_object = r) @@ -1586,7 +1229,9 @@ test_create_synthetic_correlated_data <- function( x = data@data, neworder = c( get_non_feature_columns(data), - sort(get_feature_columns(data)))) + sort(get_feature_columns(data)) + ) + ) return(data) } @@ -1595,19 +1240,22 @@ test_create_synthetic_correlated_data <- function( test_create_synthetic_correlated_one_feature_invariant_data <- function( ..., - cluster_size = c(1, 1, 1, 1)) { + cluster_size = c(1L, 1L, 1L, 1L) +) { # Set the size of the second cluster to 1, always. - cluster_size[2] <- 1 + cluster_size[2L] <- 1L # Create test data. data <- do.call( test_create_synthetic_correlated_data, args = c( list("cluster_size" = cluster_size), - list(...))) + list(...) + ) + ) # Select the first instance for feature 2. - data@data$feature_2 <- data@data$feature_2[1] + data@data$feature_2 <- data@data$feature_2[1L] return(data) } @@ -1618,7 +1266,8 @@ test_create_synthetic_correlated_one_sample_data <- function(...) { # Create test data. data <- do.call( test_create_synthetic_correlated_data, - args = list(...)) + args = list(...) + ) # Select the first instance data@data <- head(data@data, n = 1L) @@ -1630,21 +1279,24 @@ test_create_synthetic_correlated_one_sample_data <- function(...) { test_create_synthetic_correlated_one_outcome_data <- function( ..., - outcome_type) { + outcome_type +) { # Create test data. data <- do.call( test_create_synthetic_correlated_data, args = c( list("outcome_type" = outcome_type), - list(...))) + list(...) + ) + ) if (outcome_type %in% c("binomial", "multinomial")) { data@data[, "outcome" := "0"] - } else if (outcome_type %in% c("count", "continuous")) { - data@data[, "outcome" := 1] + } else if (outcome_type %in% c("continuous")) { + data@data[, "outcome" := 1.0] } else if (outcome_type == "survival") { - data@data[, ":="("outcome_time" = 1.25, "outcome_event" = 1)] + data@data[, ":="("outcome_time" = 1.25, "outcome_event" = 1L)] } else { ..error_outcome_type_not_implemented(outcome_type) } @@ -1656,20 +1308,23 @@ test_create_synthetic_correlated_one_outcome_data <- function( test_create_synthetic_correlated_bad_outcome_data <- function( ..., - outcome_type) { + outcome_type +) { # Create test data. data <- do.call( test_create_synthetic_correlated_data, args = c( list("outcome_type" = outcome_type), - list(...))) + list(...) + ) + ) if (outcome_type %in% c("binomial", "multinomial")) { data@data[, "outcome" := "0"] - } else if (outcome_type %in% c("count", "continuous")) { - data@data[, "outcome" := 1] + } else if (outcome_type %in% c("continuous")) { + data@data[, "outcome" := 1.0] } else if (outcome_type == "survival") { - data@data[, ":="("outcome_event" = 0)] + data@data[, ":="("outcome_event" = 0L)] } else { ..error_outcome_type_not_implemented(outcome_type) } diff --git a/R/TestFeatureInfo.R b/R/TestFeatureInfo.R new file mode 100644 index 00000000..ae230692 --- /dev/null +++ b/R/TestFeatureInfo.R @@ -0,0 +1,59 @@ +test_create_generic_info <- function( + data +) { + # Setup feature info task. + feature_info_task <- methods::new( + "familiarTaskGenericFeatureInfo" + ) + + # Feature information objects are created from the bypass dataset. + feature_info <- .perform_task( + object = feature_info_task, + data = data + ) + + return(feature_info) +} + + + +test_create_feature_info <- function( + data, + signature = NULL, + ... +) { + # This creates a list of featureInfo objects, with processing, based on data. + # This code is primarily used within unit tests. + + # Reconstitute settings from the data. + settings <- extract_settings_from_data(data = data) + + # Update some missing settings that can be fixed within this method. + settings$data$train_cohorts <- unique(data@data[[get_id_columns(single_column = "batch")]]) + + # Parse the remaining settings that are important. + settings <- do.call( + .parse_general_settings, + args = c( + list( + "settings" = settings, + "data" = data@data + ), + list(...) + ) + ) + + # Setup feature info task. + feature_info_task <- methods::new( + "familiarTaskFeatureInfo" + ) + + # Feature information objects are created from the bypass dataset. + feature_info <- .perform_task( + object = feature_info_task, + data = data, + settings = settings + ) + + return(feature_info) +} diff --git a/R/TestFunctions.R b/R/TestFunctions.R index 64ea3362..833f0ce4 100644 --- a/R/TestFunctions.R +++ b/R/TestFunctions.R @@ -1,45 +1,24 @@ -test_object_package_installed <- function(x) { - run_test <- TRUE - if (!is.null(x$error)) { - if (any(grepl("following package has to be installed", x$error, fixed = TRUE))) { - run_test <- FALSE - } else if (any(grepl("following packages have to be installed", x$error, fixed = TRUE))) { - run_test <- FALSE - } else { - stop(x$error) - } - } - - if (!run_test) { - rlang::inform( - message = x$error, - class = "familiar_message_inform_no_test" - ) - } - - return(run_test) -} - - test_all_learners_available <- function(learners) { # Create placeholder flags. learner_available <- logical(length(learners)) names(learner_available) <- learners - + # Iterate over learners. for (learner in learners) { # Determine if the learner is available for any outcome. for (outcome_type in c( - "count", "continuous", "binomial", "multinomial", "survival", "competing_risk")) { + "continuous", "binomial", "multinomial", "survival", "competing_risk" + )) { # Create a familiarModel object. object <- methods::new( "familiarModel", outcome_type = outcome_type, - learner = learner) - + learner = learner + ) + # Promote the learner to the right class. object <- promote_learner(object = object) - + # Check if the learner is available for the outcome. if (is_available(object)) { learner_available[learner] <- TRUE @@ -47,7 +26,7 @@ test_all_learners_available <- function(learners) { } } } - + # Iterate over learners for (learner in learners) { testthat::test_that( @@ -65,95 +44,94 @@ test_all_learners_train_predict_vimp <- function( learners, hyperparameter_list = NULL, except_train = NULL, + except_train_partial_prospective = NULL, except_naive = NULL, except_predict = NULL, except_predict_survival = NULL, has_vimp = TRUE, can_trim = TRUE, - debug = FALSE) { + debug = FALSE +) { if (debug) { test_fun <- debug_test_that } else { test_fun <- testthat::test_that } - + # Iterate over the outcome type. - for (outcome_type in c("count", "continuous", "binomial", "multinomial", "survival")) { - - if (!test_data_package_installed(outcome_type)) next - + for (outcome_type in c("continuous", "binomial", "multinomial", "survival")) { # Obtain data. full_data <- test_create_good_data(outcome_type) + full_data_reordered <- test_create_reverse_column_order_data(outcome_type) full_one_sample_data <- test_create_one_sample_data(outcome_type) one_feature_data <- test_create_single_feature_data(outcome_type) one_feature_one_sample_data <- test_create_single_feature_one_sample_data(outcome_type) empty_data <- test_create_empty_data(outcome_type) no_feature_data <- test_create_data_without_feature(outcome_type) bad_data <- test_create_bad_data(outcome_type) - + # Prospective datasets with (partially) missing outcomes fully_prospective_data <- test_create_prospective_data(outcome_type) mostly_prospective_data <- test_create_mostly_prospective_data(outcome_type) partially_prospective_data <- test_create_partially_prospective_data(outcome_type) - + # Iterate over learners. for (learner in learners) { # Create a familiarModel object. object <- methods::new( "familiarModel", outcome_type = outcome_type, - learner = learner) - + learner = learner + ) + # Promote the learner to the right class. object <- promote_learner(object = object) - + # Test if the learner is available for the current outcome_type if (!is_available(object)) next - + # Parse hyperparameter list hyperparameters <- c( hyperparameter_list[[outcome_type]], - list("sign_size" = get_n_features(full_data))) - + list("sign_size" = get_n_features(full_data)) + ) + # Find required hyperparameters learner_hyperparameters <- .get_preset_hyperparameters( learner = learner, outcome_type = outcome_type, - names_only = TRUE) - + names_only = TRUE + ) + # Select hyperparameters that are being used, and are present in the input # list of hyperparameters. hyperparameters <- hyperparameters[intersect(learner_hyperparameters, names(hyperparameters))] - + + # Full dataset ----------------------------------------------------------- - + # Train the model. - model <- do.call_with_handlers( - test_train, - args = list( - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = learner, - time_max = 1832, - trim_model = FALSE - ) - ) - if (!test_object_package_installed(model)) next - model <- model$value + model <- suppressWarnings(test_train( + data = full_data, + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = learner, + time_max = 3.5, + trim_model = FALSE + )) # Create a trimmed model -- this is the only instance were we do that # without setting the time-out to infinite to test whether the timeout # handler returns it correctly. trimmed_model <- trim_model(model) - + # Generate a file name to save the model to. file_name <- tempfile(fileext = ".rds") - + # Save file. saveRDS(trimmed_model, file = file_name) - + # Read file contents as a reloaded model. reloaded_model <- readRDS(file = file_name) @@ -165,11 +143,11 @@ test_all_learners_train_predict_vimp <- function( paste0("Model for ", outcome_type, " created using ", learner, " can be trimmed."), { if (can_trim) { - testthat::expect_equal(trimmed_model@is_trimmed, TRUE) - testthat::expect_equal(reloaded_model@is_trimmed, TRUE) + testthat::expect_true(trimmed_model@is_trimmed) + testthat::expect_true(reloaded_model@is_trimmed) } else { - testthat::expect_equal(trimmed_model@is_trimmed, FALSE) - testthat::expect_equal(reloaded_model@is_trimmed, FALSE) + testthat::expect_false(trimmed_model@is_trimmed) + testthat::expect_false(reloaded_model@is_trimmed) } } ) @@ -178,7 +156,8 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Model for ", outcome_type, " can be created using ", - learner, " using a complete dataset."), + learner, " using a complete dataset." + ), { # Test that the model was successfully created. testthat::expect_equal( @@ -188,7 +167,7 @@ test_all_learners_train_predict_vimp <- function( if (outcome_type == "survival") { # Calibration info is present - testthat::expect_equal(has_calibration_info(model), TRUE) + testthat::expect_true(has_calibration_info(model)) } } ) @@ -197,45 +176,84 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a complete dataset."), + learner, " for a complete dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict(model, data = full_data)) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") + testthat::expect_s4_class(prediction_table, "predictionTableClassification") # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) + + } else if (outcome_type == "continuous") { + testthat::expect_s4_class(prediction_table, "predictionTableRegression") + + } else if (outcome_type %in% c("survival")) { + testthat::expect_s4_class(prediction_table, "predictionTableSurvival") + + # Check prediction of survival probability. + testthat::expect_s4_class( + suppressWarnings(.predict(model, data = full_data, type = "survival_probability")), + "predictionTableSurvivalProbability" + ) + + # Check prediction of risk groups. + testthat::expect_s4_class( + suppressWarnings(.predict(model, data = full_data, type = "risk_stratification")), + "predictionTableRiskGroups" + ) + } else { + ..error_outcome_type_not_implemented(outcome_type) } # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = full_data)) + data = full_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect that the reloaded model produces the same predictions. prediction_table_reloaded <- suppressWarnings(.predict( reloaded_model, - data = full_data)) + data = full_data + )) testthat::expect_equal( prediction_table, prediction_table_reloaded, - ignore_attr = TRUE) + ignore_attr = TRUE + ) + + # Expect that a dataset with different column order produces the same + # predictions. + prediction_table_reordered <- suppressWarnings(.predict( + model, + data = full_data_reordered + )) + + testthat::expect_equal( + prediction_table, + prediction_table_reordered, + ignore_attr = TRUE + ) } ) @@ -243,47 +261,52 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a one-sample dataset."), + learner, " for a one-sample dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = full_one_sample_data)) + data = full_one_sample_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = full_one_sample_data)) + data = full_one_sample_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect that the trimmed model produces the same predictions. prediction_table_reloaded <- suppressWarnings(.predict( reloaded_model, - data = full_one_sample_data)) + data = full_one_sample_data + )) testthat::expect_equal( prediction_table, prediction_table_reloaded, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -291,17 +314,17 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can not be made using ", - learner, " for an empty dataset."), + learner, " for an empty dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = empty_data)) + data = empty_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - FALSE) + testthat::expect_false(any_predictions_valid(prediction_table)) } ) @@ -310,158 +333,184 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample survival predictions for ", outcome_type, - " can be made using ", learner, " for a complete dataset."), + " can be made using ", learner, " for a complete dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = full_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict, except_predict_survival)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict, except_predict_survival) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = full_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect that the reloaded model produces the same predictions. prediction_table_reloaded <- suppressWarnings(.predict( reloaded_model, data = full_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_reloaded, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Predict stratification. prediction_table <- suppressWarnings(.predict( model, data = full_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = full_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect that the reloaded model produces the same predictions. prediction_table_reloaded <- suppressWarnings(.predict( reloaded_model, data = full_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_reloaded, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) test_fun( paste0( "Sample survival predictions for ", outcome_type, - " can be made using ", learner, " for a one-sample dataset."), + " can be made using ", learner, " for a one-sample dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = full_one_sample_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict, except_predict_survival)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict, except_predict_survival) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = full_one_sample_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect that the reloaded model produces the same predictions. prediction_table_reloaded <- suppressWarnings(.predict( reloaded_model, data = full_one_sample_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_reloaded, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = full_one_sample_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = full_one_sample_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect that the reloaded model produces the same predictions. prediction_table_reloaded <- suppressWarnings(.predict( reloaded_model, data = full_one_sample_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_reloaded, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) } @@ -470,55 +519,47 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Model has variable importance for ", outcome_type, " and ", - learner, " for the complete dataset."), + learner, " for the complete dataset." + ), { # Extract the variable importance table. vimp_table <- suppressWarnings(get_vimp_table(.vimp( model, - data = full_data))) + data = full_data + ))) # Extract the variable importance table for the trimmed model. vimp_table_trim <- suppressWarnings(get_vimp_table(.vimp( trimmed_model, - data = full_data))) + data = full_data + ))) # Extract the variable importance table for the reloaded model. vimp_table_reloaded <- suppressWarnings(get_vimp_table(.vimp( reloaded_model, - data = full_data))) + data = full_data + ))) if (has_vimp) { # Get the number of features n_features <- get_n_features(full_data) # Expect that the vimp table has two rows. - testthat::expect_equal( - nrow(vimp_table) > 0 && nrow(vimp_table) <= n_features, - TRUE) - testthat::expect_equal( - nrow(vimp_table_trim) > 0 && nrow(vimp_table_trim) <= n_features, - TRUE) - testthat::expect_equal( - nrow(vimp_table_reloaded) > 0 && nrow(vimp_table_reloaded) <= n_features, - TRUE) + testthat::expect_true(nrow(vimp_table) > 0L && nrow(vimp_table) <= n_features) + testthat::expect_true(nrow(vimp_table_trim) > 0L && nrow(vimp_table_trim) <= n_features) + testthat::expect_true(nrow(vimp_table_reloaded) > 0L && nrow(vimp_table_reloaded) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(full_data)), - TRUE) - testthat::expect_equal( - all(vimp_table_trim$name %in% get_feature_columns(full_data)), - TRUE) - testthat::expect_equal( - all(vimp_table_reloaded$name %in% get_feature_columns(full_data)), - TRUE) + testthat::expect_true(all(vimp_table$name %in% get_feature_columns(full_data))) + testthat::expect_true(all(vimp_table_trim$name %in% get_feature_columns(full_data))) + testthat::expect_true(all(vimp_table_reloaded$name %in% get_feature_columns(full_data))) } else { # Expect that the vimp table has no rows. - testthat::expect_equal(is_empty(vimp_table), TRUE) - testthat::expect_equal(is_empty(vimp_table_trim), TRUE) - testthat::expect_equal(is_empty(vimp_table_reloaded), TRUE) + testthat::expect_true(is_empty(vimp_table)) + testthat::expect_true(is_empty(vimp_table_trim)) + testthat::expect_true(is_empty(vimp_table_reloaded)) } } ) @@ -531,24 +572,24 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832, + time_max = 3.5, create_bootstrap = TRUE, - trim_model = FALSE)) - + trim_model = FALSE + )) + # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " can be created using ", - learner, " using a complete dataset."), + learner, " using a complete dataset." + ), { # Test that the model was successfully created. - testthat::expect_equal( - model_is_trained(model), - !learner %in% except_train) + testthat::expect_equal(model_is_trained(model), !learner %in% except_train) if (outcome_type == "survival") { # Calibration info is present - testthat::expect_equal(has_calibration_info(model), TRUE) + testthat::expect_true(has_calibration_info(model)) } } ) @@ -561,39 +602,43 @@ test_all_learners_train_predict_vimp <- function( experimental_design = "fs+mb", cluster_method = "none", imputation_method = "simple", - fs_method = "no_features", + vimp_method = "no_features", learner = learner, hyperparameter = hyperparameters, parallel = FALSE, - verbose = debug)) + verbose = debug + )) test_fun( paste0( "Naive predictions for ", outcome_type, " can be made using ", - learner, " for a complete dataset."), + learner, " for a complete dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = full_data)) + data = full_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_naive)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_naive) + ) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") + testthat::expect_true(is.factor(.complete(prediction_table)@data$predicted_class)) # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) - } else if (outcome_type %in% c("count", "continuous", "survival", "competing_risk")) { + } else if (outcome_type %in% c("continuous", "survival", "competing_risk")) { # Expect that the predicted outcome is valid. - testthat::expect_equal(is.numeric(prediction_table$predicted_outcome), TRUE) + testthat::expect_true(is.numeric(.complete(prediction_table)@data$predicted_outcome)) } if (outcome_type %in% c("survival", "competing_risk")) { @@ -602,12 +647,14 @@ test_all_learners_train_predict_vimp <- function( model, data = full_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_naive)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_naive) + ) } } ) @@ -620,25 +667,25 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) + time_max = 3.5 + )) # Create a trimmed model. trimmed_model <- trim_model(model, timeout = Inf) - + # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " can be created using ", - learner, " using a one-feature dataset."), + learner, " using a one-feature dataset." + ), { # Test that the model was successfully created. - testthat::expect_equal( - model_is_trained(model), - !learner %in% except_train) + testthat::expect_equal(model_is_trained(model), !learner %in% except_train) if (outcome_type == "survival") { # Calibration info is present - testthat::expect_equal(has_calibration_info(model), TRUE) + testthat::expect_true(has_calibration_info(model)) } } ) @@ -647,37 +694,40 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a one-feature dataset."), + learner, " for a one-feature dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_feature_data)) + data = one_feature_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = one_feature_data)) + data = one_feature_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -685,37 +735,40 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a one-feature, one-sample dataset."), + learner, " for a one-feature, one-sample dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_feature_one_sample_data)) + data = one_feature_one_sample_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = one_feature_one_sample_data)) + data = one_feature_one_sample_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -724,110 +777,128 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample survival predictions for ", outcome_type, - " can be made using ", learner, " for a one-feature dataset."), + " can be made using ", learner, " for a one-feature dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = one_feature_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = one_feature_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict, except_predict_survival)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict, except_predict_survival) + ) # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = one_feature_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = one_feature_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) } ) test_fun( paste0( "Sample survival predictions for ", outcome_type, - " can be made using ", learner, " for a one-feature, one-sample dataset."), + " can be made using ", learner, " for a one-feature, one-sample dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = one_feature_one_sample_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict, except_predict_survival)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict, except_predict_survival) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = one_feature_one_sample_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = one_feature_one_sample_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = one_feature_one_sample_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) } @@ -840,51 +911,50 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) - + time_max = 3.5 + )) + # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " can not be created using ", - learner, " using a bad dataset."), + learner, " using a bad dataset." + ), { # Test that the model was successfully created. - testthat::expect_equal(model_is_trained(model), FALSE) + testthat::expect_false(model_is_trained(model)) if (outcome_type == "survival") { - # Calibration info is absent. - testthat::expect_equal(has_calibration_info(model), TRUE) + # Calibration info is present. + testthat::expect_true(has_calibration_info(model)) } } ) - + # Bad dataset without features ------------------------------------------- - # Train the model. - model <- suppressWarnings(test_train( - data = no_feature_data, - data_bypass = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = learner, - time_max = 1832)) - - # Test that models can be created. - test_fun( - paste0( - "Model for ", outcome_type, " can not be created using ", - learner, " using a dataset for ."), - { - # Test that the model could not be successfully created. - testthat::expect_equal(model_is_trained(model), FALSE) - } + + # Note that since version 2.0.0, the training process can no longer be + # forced with a feature-less dataset -- the discrepancy between the + # expected full dataset and the training data (no_feature_data) is picked + # up when trying to process the data. + testthat::expect_error( + suppressWarnings(test_train( + data = no_feature_data, + data_bypass = full_data, + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = learner, + time_max = 3.5 + )), + "Not all features were found in the data set" ) # Dataset without censored instances ------------------------------------- if (outcome_type %in% c("survival", "competing_risk")) { # Set up non-censoring dataset. no_censoring_data <- test_create_good_data_without_censoring(outcome_type) - + # Train the model. model <- suppressWarnings(test_train( data = no_censoring_data, @@ -892,25 +962,25 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) - + time_max = 3.5 + )) + # Create a trimmed model. trimmed_model <- trim_model(model, timeout = Inf) - + # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " can be created using ", - learner, " using a dataset without censoring."), + learner, " using a dataset without censoring." + ), { # Test that the model was successfully created. - testthat::expect_equal( - model_is_trained(model), - !learner %in% except_train) + testthat::expect_equal(model_is_trained(model), !learner %in% except_train) if (outcome_type == "survival") { # Calibration info is present - testthat::expect_equal(has_calibration_info(model), TRUE) + testthat::expect_true(has_calibration_info(model)) } } ) @@ -919,27 +989,32 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a dataset without censoring."), + learner, " for a dataset without censoring." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = no_censoring_data)) + data = no_censoring_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = no_censoring_data)) + data = no_censoring_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -947,55 +1022,64 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample survival predictions for ", outcome_type, - " can be made using ", learner, " for a dataset without censoring."), + " can be made using ", learner, " for a dataset without censoring." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = no_censoring_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = no_censoring_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict, except_predict_survival)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict, except_predict_survival) + ) # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = no_censoring_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = no_censoring_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) } ) } @@ -1012,25 +1096,25 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) - + time_max = 3.5 + )) + # Create a trimmed model. trimmed_model <- trim_model(model, timeout = Inf) - + # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " can be created using ", - learner, " using a dataset with one censored sample."), + learner, " using a dataset with one censored sample." + ), { # Test that the model was successfully created. - testthat::expect_equal( - model_is_trained(model), - !learner %in% except_train) + testthat::expect_equal(model_is_trained(model), !learner %in% except_train) if (outcome_type == "survival") { # Calibration info is present - testthat::expect_equal(has_calibration_info(model), TRUE) + testthat::expect_true(has_calibration_info(model)) } } ) @@ -1039,26 +1123,32 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a dataset with one censored sample."), + learner, " for a dataset with one censored sample." + ), { # Expect predictions to be made. - prediction_table <- suppressWarnings(.predict(model, - data = one_censoring_data)) + prediction_table <- suppressWarnings(.predict( + model, + data = one_censoring_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = one_censoring_data)) + data = one_censoring_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -1066,55 +1156,64 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample survival predictions for ", outcome_type, - " can be made using ", learner, " for a dataset with one censored sample."), + " can be made using ", learner, " for a dataset with one censored sample." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = one_censoring_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = one_censoring_data, type = "survival_probability", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict, except_predict_survival)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict, except_predict_survival) + ) # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = one_censoring_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = one_censoring_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) } ) } @@ -1132,8 +1231,9 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) - + time_max = 3.5 + )) + # Create a trimmed model. trimmed_model <- trim_model(model, timeout = Inf) @@ -1141,16 +1241,15 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Model for ", outcome_type, " can be created using ", learner, - " using a dataset with few censored samples."), + " using a dataset with few censored samples." + ), { # Test that the model was successfully created. - testthat::expect_equal( - model_is_trained(model), - !learner %in% except_train) + testthat::expect_equal(model_is_trained(model), !learner %in% except_train) if (outcome_type == "survival") { # Calibration info is present - testthat::expect_equal(has_calibration_info(model), TRUE) + testthat::expect_true(has_calibration_info(model)) } } ) @@ -1159,27 +1258,32 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a dataset with few censored samples."), + learner, " for a dataset with few censored samples." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = few_censoring_data)) + data = few_censoring_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = few_censoring_data)) + data = few_censoring_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -1187,14 +1291,15 @@ test_all_learners_train_predict_vimp <- function( test_fun( paste0( "Sample survival predictions for ", outcome_type, - " can be made using ", learner, " for a dataset with few censored samples."), + " can be made using ", learner, " for a dataset with few censored samples." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = few_censoring_data, type = "survival_probability", - time = 1000 + time = 2.5 )) # Expect that the trimmed model produces the same predictions. @@ -1202,7 +1307,7 @@ test_all_learners_train_predict_vimp <- function( trimmed_model, data = few_censoring_data, type = "survival_probability", - time = 1000 + time = 2.5 )) testthat::expect_equal( @@ -1213,22 +1318,25 @@ test_all_learners_train_predict_vimp <- function( # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict, except_predict_survival)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict, except_predict_survival) + ) # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, data = few_censoring_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) # Expect that the trimmed model produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, data = few_censoring_data, type = "risk_stratification", - time = 1000)) + time = 2.5 + )) testthat::expect_equal( prediction_table, @@ -1238,8 +1346,9 @@ test_all_learners_train_predict_vimp <- function( # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - !learner %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !learner %in% c(except_train, except_predict) + ) } ) } @@ -1255,21 +1364,23 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) - + time_max = 3.5 + )) + # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " cannot be created using ", - learner, " for a fully prospective dataset."), + learner, " for a fully prospective dataset." + ), { # Test that the model was not created. - testthat::expect_equal(model_is_trained(model), FALSE) + testthat::expect_false(model_is_trained(model)) } ) # Mostly prospective dataset --------------------------------------------- - + # Train the model. model <- suppressWarnings(test_train( data = mostly_prospective_data, @@ -1278,21 +1389,23 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) - + time_max = 3.5 + )) + # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " cannot be created using ", learner, - " for an almost fully prospective dataset, where outcome is known for just a single sample."), + " for an almost fully prospective dataset, where outcome is known for just a single sample." + ), { # Test that the model was not created. - testthat::expect_equal(model_is_trained(model), FALSE) + testthat::expect_false(model_is_trained(model)) } ) # Partially prospective dataset ------------------------------------------ - + # Train the model. model <- suppressWarnings(test_train( data = partially_prospective_data, @@ -1300,18 +1413,18 @@ test_all_learners_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832)) + time_max = 3.5 + )) # Test that models can be created. test_fun( paste0( "Model for ", outcome_type, " can be created using ", learner, - " for a partially prospective dataset, where outcome is known for most samples."), + " for a partially prospective dataset, where outcome is known for most samples." + ), { # Test that the model was successfully created. - testthat::expect_equal( - model_is_trained(model), - !learner %in% except_train) + testthat::expect_equal(model_is_trained(model), !learner %in% c(except_train, except_train_partial_prospective)) } ) } @@ -1323,54 +1436,55 @@ test_all_learners_train_predict_vimp <- function( test_all_learners_parallel_train_predict_vimp <- function( learners, hyperparameter_list = NULL, - has_vimp = TRUE) { + has_vimp = TRUE +) { # This function serves to test whether packages are loaded correctly for model # training, variable importance and so forth. # Disable randomForestSRC OpenMP core use. - options(rf.cores = as.integer(1)) + options(rf.cores = 1L) on.exit(options(rf.cores = -1L), add = TRUE) - + # Disable multithreading on data.table to prevent reduced performance due to # resource collisions with familiar parallelisation. data.table::setDTthreads(1L) on.exit(data.table::setDTthreads(0L), add = TRUE) - + # Iterate over the outcome type. - for (outcome_type in c("count", "continuous", "binomial", "multinomial", "survival")) { - - if (!test_data_package_installed(outcome_type)) next - + for (outcome_type in c("continuous", "binomial", "multinomial", "survival")) { # Obtain data. full_data <- test_create_good_data(outcome_type) - + # Iterate over learners. for (learner in learners) { if (!.check_learner_outcome_type( learner = learner, outcome_type = outcome_type, - as_flag = TRUE)) { + as_flag = TRUE + )) { next } - + # Parse hyperparameter list hyperparameters <- c( hyperparameter_list[[outcome_type]], - list("sign_size" = get_n_features(full_data))) - + list("sign_size" = get_n_features(full_data)) + ) + # Find required hyperparameters learner_hyperparameters <- .get_preset_hyperparameters( learner = learner, outcome_type = outcome_type, - names_only = TRUE) - + names_only = TRUE + ) + # Select hyperparameters that are being used, and are present in the input # list of hyperparameters. hyperparameters <- hyperparameters[intersect(learner_hyperparameters, names(hyperparameters))] - + # Train models ----------------------------------------------------------- cl_train <- .test_start_cluster(n_cores = 2L) - + # Train the models. model_list <- parallel::parLapply( cl = cl_train, @@ -1380,98 +1494,92 @@ test_all_learners_parallel_train_predict_vimp <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = learner, - time_max = 1832, - trim_model = FALSE) - + time_max = 3.5, + trim_model = FALSE + ) + # Test that models can be created. testthat::test_that( paste0( "Model for ", outcome_type, " can be created using ", - learner, " using a complete dataset."), + learner, " using a complete dataset." + ), { # Test that the model was successfully created. - testthat::expect_equal(model_is_trained(model_list[[1]]), TRUE) - testthat::expect_equal(model_is_trained(model_list[[2]]), TRUE) + testthat::expect_true(model_is_trained(model_list[[1L]])) + testthat::expect_true(model_is_trained(model_list[[2L]])) } ) # Terminate cluster. cl_train <- .terminate_cluster(cl_train) - + # Variable importance ---------------------------------------------------- cl_vimp <- .test_start_cluster(n_cores = 2L) - + # Extract variable importance objects. vimp_table_list <- parallel::parLapply( cl = cl_vimp, model_list, .vimp, - data = full_data) - + data = full_data + ) + # Extract the variable importance tables themselves. vimp_table_list <- lapply(vimp_table_list, get_vimp_table) - + # Test that the model has variable importance. testthat::test_that( paste0( "Model has variable importance for ", outcome_type, " and ", - learner, " for the complete dataset."), + learner, " for the complete dataset." + ), { if (has_vimp) { # Get the number of features n_features <- get_n_features(full_data) # Expect that the vimp table has two rows. - testthat::expect_equal( - nrow(vimp_table_list[[1]]) > 0 && nrow(vimp_table_list[[1]]) <= n_features, - TRUE) - testthat::expect_equal( - nrow(vimp_table_list[[2]]) > 0 && nrow(vimp_table_list[[2]]) <= n_features, - TRUE) + testthat::expect_true(nrow(vimp_table_list[[1L]]) > 0L && nrow(vimp_table_list[[1L]]) <= n_features) + testthat::expect_true(nrow(vimp_table_list[[2L]]) > 0L && nrow(vimp_table_list[[2L]]) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table_list[[1]]$name %in% get_feature_columns(full_data)), - TRUE) - testthat::expect_equal( - all(vimp_table_list[[2]]$name %in% get_feature_columns(full_data)), - TRUE) + testthat::expect_in(vimp_table_list[[1L]]$name, get_feature_columns(full_data)) + testthat::expect_in(vimp_table_list[[2L]]$name, get_feature_columns(full_data)) } else { # Expect that the vimp table has no rows. - testthat::expect_equal(is_empty(vimp_table_list[[1]]), TRUE) - testthat::expect_equal(is_empty(vimp_table_list[[2]]), TRUE) + testthat::expect_true(is_empty(vimp_table_list[[1L]])) + testthat::expect_true(is_empty(vimp_table_list[[2L]])) } } ) - + # Terminate cluster. cl_vimp <- .terminate_cluster(cl_vimp) - + # Predictions ------------------------------------------------------------ cl_predict <- .test_start_cluster(n_cores = 2L) - + # Extract predictions. prediction_list <- parallel::parLapply( cl = cl_predict, model_list, .predict, - data = full_data) - + data = full_data + ) + # Test that models can be used to predict the outcome. testthat::test_that( paste0( "Sample predictions for ", outcome_type, " can be made using ", - learner, " for a complete dataset."), + learner, " for a complete dataset." + ), { # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_list[[1]], outcome_type), - TRUE) - testthat::expect_equal( - any_predictions_valid(prediction_list[[2]], outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_list[[1L]])) + testthat::expect_true(any_predictions_valid(prediction_list[[2L]])) } ) @@ -1487,29 +1595,30 @@ test_all_novelty_detectors_available <- function(detectors) { # Create placeholder flags. detector_available <- logical(length(detectors)) names(detector_available) <- detectors - + # Iterate over learners. for (detector in detectors) { # Create a familiarModel object. object <- methods::new( "familiarNoveltyDetector", - learner = detector) - + learner = detector + ) + # Promote the learner to the right class. object <- promote_detector(object = object) - + # Check if the learner is available for the outcome. if (is_available(object)) { detector_available[detector] <- TRUE } } - + # Iterate over learners for (detector in detectors) { testthat::test_that( paste0(detector, " is available."), { - testthat::expect_equal(unname(detector_available[detector]), TRUE) + testthat::expect_true(unname(detector_available[detector])) } ) } @@ -1524,17 +1633,16 @@ test_all_novelty_detectors <- function( except_predict = NULL, except_predict_survival = NULL, can_trim = TRUE, - debug = FALSE) { + debug = FALSE +) { if (debug) { test_fun <- debug_test_that } else { test_fun <- testthat::test_that } - + # Outcome type is not important, but set to get suitable datasets. outcome_type <- "continuous" - - if (!test_data_package_installed(outcome_type)) testthat::skip() # Obtain data. full_data <- test_create_good_data(outcome_type) @@ -1543,47 +1651,43 @@ test_all_novelty_detectors <- function( one_feature_one_sample_data <- test_create_single_feature_one_sample_data(outcome_type) empty_data <- test_create_empty_data(outcome_type) no_feature_data <- test_create_data_without_feature(outcome_type) - + # Iterate over learners. for (detector in detectors) { # Create a familiarNoveltyDetector object. object <- methods::new( "familiarNoveltyDetector", - learner = detector) - + learner = detector + ) + # Promote the novelty detector to the right class. object <- promote_detector(object = object) - + # Test if the detector is available. if (!is_available(object)) next - + # Full dataset ------------------------------------------------------------- - + # Train the novelty detector. - model <- do.call_with_handlers( - test_train_novelty_detector, - args = list( - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameter_list, - detector = detector - ) - ) - if (!test_object_package_installed(model)) next - model <- model$value - + model <- suppressWarnings(test_train_novelty_detector( + data = full_data, + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameter_list, + detector = detector + )) + # Create a trimmed detector. trimmed_model <- trim_model(model, timeout = Inf) - + # Check that the the novelty detector can be trimmed. test_fun( paste0("Detector created using the ", detector, " algorithm can be trimmed."), { if (can_trim) { - testthat::expect_equal(trimmed_model@is_trimmed, TRUE) + testthat::expect_true(trimmed_model@is_trimmed) } else { - testthat::expect_equal(trimmed_model@is_trimmed, FALSE) + testthat::expect_false(trimmed_model@is_trimmed) } } ) @@ -1592,85 +1696,96 @@ test_all_novelty_detectors <- function( test_fun( paste0( "Detector can be created using the ", detector, - " algorithm using a complete dataset."), + " algorithm using a complete dataset." + ), { # Test that the novelty detector was successfully created. testthat::expect_equal( model_is_trained(model), - !detector %in% except_train) + !detector %in% except_train + ) } ) - + # Test that the novelty detector can be used to predict the outcome. test_fun( paste0( "Novely predictions can be made using the ", detector, - " algorithm for a complete dataset."), + " algorithm for a complete dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = full_data)) + data = full_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, type = "novelty"), - !detector %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !detector %in% c(except_train, except_predict) + ) # Expect that the trimmed novelty detector produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = full_data)) + data = full_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) - + # Test that the novelty detector can be used to predict the outcome. test_fun( paste0( "Novelty predictions can be made using the ", detector, - " algorithm for a one-sample dataset."), + " algorithm for a one-sample dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = full_one_sample_data)) + data = full_one_sample_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, type = "novelty"), - !detector %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !detector %in% c(except_train, except_predict) + ) # Expect that the trimmed novelty detector produces the same predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = full_one_sample_data)) + data = full_one_sample_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) # Test that the novelty detector cannot predict for empty datasets. - test_fun(paste0( - "Novelty predictions can not be made using the ", detector, - " algorithm for an empty dataset."), + test_fun( + paste0( + "Novelty predictions can not be made using the ", detector, + " algorithm for an empty dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = empty_data)) - - # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, type = "novelty"), - FALSE) + data = empty_data + )) + testthat::expect_false(any_predictions_valid(prediction_table)) } ) @@ -1681,7 +1796,8 @@ test_all_novelty_detectors <- function( cluster_method = "none", imputation_method = "simple", hyperparameter_list = hyperparameter_list, - detector = detector)) + detector = detector + )) # Create a trimmed novelty detector. trimmed_model <- trim_model(model, timeout = Inf) @@ -1690,12 +1806,14 @@ test_all_novelty_detectors <- function( test_fun( paste0( "Detector can be created using the ", detector, - " algorithm using a one-feature dataset."), + " algorithm using a one-feature dataset." + ), { # Test that the novelty detector was successfully created. testthat::expect_equal( model_is_trained(model), - !detector %in% except_train) + !detector %in% except_train + ) } ) @@ -1703,28 +1821,33 @@ test_all_novelty_detectors <- function( test_fun( paste0( "Novelty predictions can be made using the ", detector, - " algorithm for a one-feature dataset."), + " algorithm for a one-feature dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_feature_data)) + data = one_feature_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, type = "novelty"), - !detector %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !detector %in% c(except_train, except_predict) + ) # Expect that the trimmed novelty detector produces the same # predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = one_feature_data)) + data = one_feature_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -1732,28 +1855,33 @@ test_all_novelty_detectors <- function( test_fun( paste0( "Novelty predictions can be made using the ", detector, - " algorithm for a one-feature, one-sample dataset."), + " algorithm for a one-feature, one-sample dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_feature_one_sample_data)) + data = one_feature_one_sample_data + )) # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_table, type = "novelty"), - !detector %in% c(except_train, except_predict)) + any_predictions_valid(prediction_table), + !detector %in% c(except_train, except_predict) + ) # Expect that the trimmed novelty detector produces the same # predictions. prediction_table_trim <- suppressWarnings(.predict( trimmed_model, - data = one_feature_one_sample_data)) + data = one_feature_one_sample_data + )) testthat::expect_equal( prediction_table, prediction_table_trim, - ignore_attr = TRUE) + ignore_attr = TRUE + ) } ) @@ -1765,37 +1893,36 @@ test_all_novelty_detectors <- function( cluster_method = "none", imputation_method = "simple", hyperparameter_list = hyperparameter_list, - detector = detector)) - + detector = detector + )) + # Test that the novelty detector can be created. test_fun( paste0( "Detector can not be created using the ", detector, - " algorithm using a bad dataset."), + " algorithm using a bad dataset." + ), { # Test that the novelty detector was successfully created. - testthat::expect_equal(model_is_trained(model), FALSE) + testthat::expect_false(model_is_trained(model)) } ) - # Bad dataset without features ----------------------------------------------- - # Train the novelty detector. - model <- suppressWarnings(test_train_novelty_detector( - data = no_feature_data, - data_bypass = full_data, - imputation_method = "simple", - hyperparameter_list = hyperparameter_list, - detector = detector)) + # Bad dataset without features --------------------------------------------- - # Test that the novelty detector can be created. - test_fun( - paste0( - "Detector can not be created using the ", detector, - " algorithm using a dataset without features."), - { - # Test that the novelty detector was successfully created. - testthat::expect_equal(model_is_trained(model), FALSE) - } + # Note that since version 2.0.0, the training process can no longer be + # forced with a feature-less dataset -- the discrepancy between the expected + # full dataset and the training data (no_feature_data) is picked up when + # trying to process the data. + testthat::expect_error( + suppressWarnings(test_train_novelty_detector( + data = no_feature_data, + data_bypass = full_data, + imputation_method = "simple", + hyperparameter_list = hyperparameter_list, + detector = detector + )), + "Not all features were found in the data set" ) } } @@ -1806,7 +1933,8 @@ test_all_novelty_detectors_parallel <- function( detectors, except_train = NULL, except_predict = NULL, - hyperparameter_list = NULL) { + hyperparameter_list = NULL +) { # This function serves to test whether packages are loaded correctly for # novelty detection. @@ -1818,8 +1946,6 @@ test_all_novelty_detectors_parallel <- function( # Outcome type is not important, but set to get suitable datasets. outcome_type <- "continuous" - if (!test_data_package_installed(outcome_type)) testthat::skip() - # Obtain data. full_data <- test_create_good_data(outcome_type) @@ -1827,7 +1953,8 @@ test_all_novelty_detectors_parallel <- function( for (detector in detectors) { if (!.check_novelty_detector_available( detector = detector, - as_flag = TRUE)) { + as_flag = TRUE + )) { next } @@ -1837,12 +1964,16 @@ test_all_novelty_detectors_parallel <- function( # Train the models. model_list <- parallel::parLapply( cl = cl_train, - list("1" = full_data, "2" = full_data), + list( + "1" = full_data, + "2" = full_data + ), test_train_novelty_detector, cluster_method = "none", imputation_method = "simple", detector = detector, - hyperparameter_list = hyperparameter_list) + hyperparameter_list = hyperparameter_list + ) # Test that models can be created. testthat::test_that( @@ -1850,11 +1981,13 @@ test_all_novelty_detectors_parallel <- function( { # Test that the model was successfully created. testthat::expect_equal( - model_is_trained(model_list[[1]]), - !detector %in% except_train) + model_is_trained(model_list[[1L]]), + !detector %in% except_train + ) testthat::expect_equal( - model_is_trained(model_list[[2]]), - !detector %in% except_train) + model_is_trained(model_list[[2L]]), + !detector %in% except_train + ) } ) @@ -1869,7 +2002,8 @@ test_all_novelty_detectors_parallel <- function( cl = cl_predict, model_list, .predict, - data = full_data) + data = full_data + ) # Test that models can be used to assess novelty. testthat::test_that( @@ -1877,11 +2011,13 @@ test_all_novelty_detectors_parallel <- function( { # Test that the predictions were successfully made. testthat::expect_equal( - any_predictions_valid(prediction_list[[1]], type = "novelty"), - !detector %in% c(except_train, except_predict)) + any_predictions_valid(prediction_list[[1L]]), + !detector %in% c(except_train, except_predict) + ) testthat::expect_equal( - any_predictions_valid(prediction_list[[2]], type = "novelty"), - !detector %in% c(except_train, except_predict)) + any_predictions_valid(prediction_list[[2L]]), + !detector %in% c(except_train, except_predict) + ) } ) @@ -1902,12 +2038,14 @@ test_all_vimp_methods_available <- function(vimp_methods) { for (vimp_method in vimp_methods) { # Determine if the learner is available for any outcome. for (outcome_type in c( - "count", "continuous", "binomial", "multinomial", "survival", "competing_risk")) { + "continuous", "binomial", "multinomial", "survival", "competing_risk" + )) { # Create a familiarModel object. object <- methods::new( "familiarVimpMethod", outcome_type = outcome_type, - vimp_method = vimp_method) + vimp_method = vimp_method + ) # Promote the learner to the right class. object <- promote_vimp_method(object = object) @@ -1925,7 +2063,7 @@ test_all_vimp_methods_available <- function(vimp_methods) { testthat::test_that( paste0(vimp_method, " is available."), { - testthat::expect_equal(unname(vimp_method_available[vimp_method]), TRUE) + testthat::expect_true(unname(vimp_method_available[vimp_method])) } ) } @@ -1936,18 +2074,16 @@ test_all_vimp_methods_available <- function(vimp_methods) { test_all_vimp_methods <- function( vimp_methods, hyperparameter_list = NULL, - debug = FALSE) { + debug = FALSE +) { if (debug) { test_fun <- debug_test_that } else { test_fun <- testthat::test_that } - + # Iterate over the outcome type. - for (outcome_type in c("count", "continuous", "binomial", "multinomial", "survival")) { - - if (!test_data_package_installed(outcome_type)) next - + for (outcome_type in c("continuous", "binomial", "multinomial", "survival")) { # Obtain data. full_data <- test_create_good_data(outcome_type) full_one_sample_data <- test_create_one_sample_data(outcome_type) @@ -1957,344 +2093,353 @@ test_all_vimp_methods <- function( one_feature_one_sample_data <- test_create_single_feature_one_sample_data(outcome_type) empty_data <- test_create_empty_data(outcome_type) bad_data <- test_create_bad_data(outcome_type) - + # Prospective datasets with (partially) missing outcomes fully_prospective_data <- test_create_prospective_data(outcome_type) mostly_prospective_data <- test_create_mostly_prospective_data(outcome_type) partially_prospective_data <- test_create_partially_prospective_data(outcome_type) - + # Iterate over variable importance methods. for (vimp_method in vimp_methods) { # Create a familiarVimpMethod object. object <- methods::new( "familiarVimpMethod", outcome_type = outcome_type, - vimp_method = vimp_method) - + vimp_method = vimp_method + ) + # Promote the learner to the right class. object <- promote_vimp_method(object = object) - + # Test if the learner is available for the current outcome_type if (!is_available(object)) next - + # Parse hyperparameter list hyperparameters <- c(hyperparameter_list[[outcome_type]]) - + # Find required hyperparameters vimp_method_hyperparameters <- .get_preset_hyperparameters( - fs_method = vimp_method, + vimp_method = vimp_method, outcome_type = outcome_type, - names_only = TRUE) - + names_only = TRUE + ) + # Select hyperparameters that are being used, and are present in the input # list of hyperparameters. hyperparameters <- hyperparameters[intersect(vimp_method_hyperparameters, names(hyperparameters))] - + # Full dataset ----------------------------------------------------------- - + # Process dataset. - vimp_object <- do.call_with_handlers( - prepare_vimp_object, - args = list( - data = full_data, - vimp_method = vimp_method, - vimp_method_parameter_list = hyperparameters, - outcome_type = outcome_type, - cluster_method = "none", - imputation_method = "simple" - ) + vimp_object <- test_create_vimp_method( + data = full_data, + vimp_method = vimp_method, + vimp_method_parameter_list = hyperparameters, + outcome_type = outcome_type, + cluster_method = "none", + imputation_method = "simple" ) - if (!test_object_package_installed(vimp_object)) next - vimp_object <- vimp_object$value test_fun( paste0( "Variable importance can be computed for ", outcome_type, " with the ", - vimp_method, " using a complete dataset."), + vimp_method, " using a complete dataset." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - full_data))) + full_data + ))) # Get the number of features n_features <- get_n_features(full_data) - # Expect that the vimp table is not empty.. - testthat::expect_equal( - nrow(vimp_table) > 0 && nrow(vimp_table) <= n_features, - TRUE) + # Expect that the vimp table is not empty. + testthat::expect_true(nrow(vimp_table) > 0L && nrow(vimp_table) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(full_data)), - TRUE) + testthat::expect_in(vimp_table$name, get_feature_columns(full_data)) + + # Expect that not all features have the same rank. + if (nrow(vimp_table) > 1L) { + testthat::expect_true(!all(vimp_table$rank == 1L)) + } } ) test_fun( paste0( - "Variable importance can be computed for ", outcome_type, " with the ", - vimp_method, " using a complete dataset with one invariant feature."), + "Variable importance can be computed for ", outcome_type, " with the ", + vimp_method, " using a complete dataset with one invariant feature." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - full_one_invariant_data))) + full_one_invariant_data + ))) # Get the number of features n_features <- get_n_features(full_one_invariant_data) - # Expect that the vimp table is not empty.. - testthat::expect_equal( - nrow(vimp_table) > 0 && nrow(vimp_table) <= n_features, - TRUE) + # Expect that the vimp table is not empty. + testthat::expect_true(nrow(vimp_table) > 0L && nrow(vimp_table) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(full_one_invariant_data)), - TRUE) + testthat::expect_in(vimp_table$name, get_feature_columns(full_one_invariant_data)) } ) test_fun( paste0( "Variable importance cannot be computed for ", outcome_type, - " with the ", vimp_method, " using an empty dataset."), + " with the ", vimp_method, " using an empty dataset." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - empty_data))) + empty_data + ))) # Expect that the vimp table has two rows. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) } ) test_fun( paste0( "Variable importance cannot be computed for ", outcome_type, - " with the ", vimp_method, " using a bad dataset."), + " with the ", vimp_method, " using a bad dataset." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - bad_data))) + bad_data + ))) # Expect that the vimp table has two rows. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) } ) test_fun( paste0( "Variable importance cannot be computed for ", outcome_type, - " with the ", vimp_method, " using a one-sample dataset."), + " with the ", vimp_method, " using a one-sample dataset." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - full_one_sample_data))) + full_one_sample_data + ))) # Expect that the vimp table has two rows. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) } ) # One-feature dataset ---------------------------------------------------- - + # Process dataset. - vimp_object <- prepare_vimp_object( + vimp_object <- test_create_vimp_method( data = one_feature_data, vimp_method = vimp_method, vimp_method_parameter_list = hyperparameters, outcome_type = outcome_type, cluster_method = "none", - imputation_method = "simple") - + imputation_method = "simple" + ) + test_fun( paste0( "Variable importance can be computed for ", outcome_type, " with the ", - vimp_method, " using a one-feature dataset."), + vimp_method, " using a one-feature dataset." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - one_feature_data))) + one_feature_data + ))) # Expect that the vimp table is not empty. - testthat::expect_equal(nrow(vimp_table), 1) + testthat::expect_equal(nrow(vimp_table), 1L) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(one_feature_data)), - TRUE) + testthat::expect_in(vimp_table$name, get_feature_columns(one_feature_data)) } ) - + test_fun( paste0( "Variable importance cannot be computed for ", outcome_type, " with the ", - vimp_method, " using a one-feature dataset with an invariant feature."), + vimp_method, " using a one-feature dataset with an invariant feature." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - one_feature_invariant_data))) + one_feature_invariant_data + ))) # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) } ) - + test_fun( paste0( "Variable importance cannot be computed for ", outcome_type, - " with the ", vimp_method, " using a one-feature, one-sample dataset."), + " with the ", vimp_method, " using a one-feature, one-sample dataset." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - one_feature_one_sample_data))) + one_feature_one_sample_data + ))) # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) } ) - + if (outcome_type %in% c("survival", "competing_risk")) { # Dataset without censored instances ----------------------------------- - + no_censoring_data <- test_create_good_data_without_censoring(outcome_type) - + # Process dataset. - vimp_object <- prepare_vimp_object( + vimp_object <- test_create_vimp_method( data = no_censoring_data, vimp_method = vimp_method, vimp_method_parameter_list = hyperparameters, outcome_type = outcome_type, cluster_method = "none", - imputation_method = "simple") - + imputation_method = "simple" + ) + test_fun( paste0( "Variable importance can be computed for ", outcome_type, " with the ", - vimp_method, " using a dataset without censoring."), + vimp_method, " using a dataset without censoring." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - no_censoring_data))) + no_censoring_data + ))) # Get the number of features n_features <- get_n_features(full_data) # Expect that the vimp table is not empty.. - testthat::expect_equal( - nrow(vimp_table) > 0 && nrow(vimp_table) <= n_features, - TRUE) + testthat::expect_true(nrow(vimp_table) > 0L && nrow(vimp_table) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(full_data)), - TRUE) + testthat::expect_in(vimp_table$name, get_feature_columns(full_data)) } ) # Dataset with one censored instance ----------------------------------- - + one_censored_data <- test_create_good_data_one_censored(outcome_type) - + # Process dataset. - vimp_object <- prepare_vimp_object( + vimp_object <- test_create_vimp_method( data = one_censored_data, vimp_method = vimp_method, vimp_method_parameter_list = hyperparameters, outcome_type = outcome_type, cluster_method = "none", - imputation_method = "simple") - + imputation_method = "simple" + ) + test_fun( paste0( "Variable importance can be computed for ", outcome_type, " with the ", - vimp_method, " using a dataset with one censored instance."), + vimp_method, " using a dataset with one censored instance." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - one_censored_data))) + one_censored_data + ))) # Get the number of features n_features <- get_n_features(full_data) # Expect that the vimp table is not empty.. - testthat::expect_equal( - nrow(vimp_table) > 0 && nrow(vimp_table) <= n_features, - TRUE) + testthat::expect_true(nrow(vimp_table) > 0L && nrow(vimp_table) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(full_data)), - TRUE) + testthat::expect_in(vimp_table$name, get_feature_columns(full_data)) } ) - + # Dataset with few censored instances ---------------------------------- few_censored_data <- test_create_good_data_few_censored(outcome_type) - + # Process dataset. - vimp_object <- prepare_vimp_object( + vimp_object <- test_create_vimp_method( data = few_censored_data, vimp_method = vimp_method, vimp_method_parameter_list = hyperparameters, outcome_type = outcome_type, cluster_method = "none", - imputation_method = "simple") - + imputation_method = "simple" + ) + test_fun( paste0( "Variable importance can be computed for ", outcome_type, " with the ", - vimp_method, " using a dataset with few censored instances."), + vimp_method, " using a dataset with few censored instances." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - few_censored_data))) + few_censored_data + ))) # Get the number of features n_features <- get_n_features(full_data) # Expect that the vimp table is not empty.. - testthat::expect_equal( - nrow(vimp_table) > 0 && nrow(vimp_table) <= n_features, - TRUE) + testthat::expect_true(nrow(vimp_table) > 0L && nrow(vimp_table) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(full_data)), - TRUE) + testthat::expect_in(vimp_table$name, get_feature_columns(full_data)) } ) } - + # Fully prospective dataset ---------------------------------------------- - + # Set up the vimp object. - vimp_object <- prepare_vimp_object( + vimp_object <- test_create_vimp_method( data = full_data, vimp_method = vimp_method, vimp_method_parameter_list = hyperparameters, outcome_type = outcome_type, cluster_method = "none", - imputation_method = "simple") - + imputation_method = "simple" + ) + test_fun( paste0( "Variable importance cannot be computed for ", outcome_type, " with the ", - vimp_method, " for a fully prospective dataset."), + vimp_method, " for a fully prospective dataset." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - fully_prospective_data))) + fully_prospective_data + ))) # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) } ) @@ -2303,41 +2448,41 @@ test_all_vimp_methods <- function( test_fun( paste0( "Variable importance cannot be computed for ", outcome_type, " with the ", vimp_method, - " for an almost fully prospective dataset, where outcome is known for just a single sample."), + " for an almost fully prospective dataset, where outcome is known for just a single sample." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - mostly_prospective_data))) + mostly_prospective_data + ))) # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) } ) - + # Partially prospective dataset ------------------------------------------ - + test_fun( paste0( "Variable importance can be computed for ", outcome_type, " with the ", vimp_method, - " for a partially prospective dataset, where outcome is known for most samples."), + " for a partially prospective dataset, where outcome is known for most samples." + ), { vimp_table <- suppressWarnings(get_vimp_table(.vimp( vimp_object, - partially_prospective_data))) + partially_prospective_data + ))) # Get the number of features n_features <- get_n_features(full_data) - # Expect that the vimp table is not empty.. - testthat::expect_equal( - nrow(vimp_table) > 0 && nrow(vimp_table) <= n_features, - TRUE) + # Expect that the vimp table is not empty. + testthat::expect_true(nrow(vimp_table) > 0L && nrow(vimp_table) <= n_features) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table$name %in% get_feature_columns(partially_prospective_data)), - TRUE) + testthat::expect_in(vimp_table$name, get_feature_columns(partially_prospective_data)) } ) } @@ -2348,106 +2493,112 @@ test_all_vimp_methods <- function( test_all_vimp_methods_parallel <- function( vimp_methods, - hyperparameter_list = NULL) { + hyperparameter_list = NULL +) { # This function serves to test whether packages are loaded correctly for # assessing variable importance. - + # Disable randomForestSRC OpenMP core use. - options(rf.cores = as.integer(1)) + options(rf.cores = 1L) on.exit(options(rf.cores = -1L), add = TRUE) - + # Disable multithreading on data.table to prevent reduced performance due to # resource collisions with familiar parallelisation. data.table::setDTthreads(1L) on.exit(data.table::setDTthreads(0L), add = TRUE) - + # Iterate over the outcome type. - for (outcome_type in c("count", "continuous", "binomial", "multinomial", "survival")) { - - if (!test_data_package_installed(outcome_type)) next - + for (outcome_type in c("continuous", "binomial", "multinomial", "survival")) { # Obtain data. full_data <- test_create_good_data(outcome_type) - + for (vimp_method in vimp_methods) { if (!.check_vimp_outcome_type( method = vimp_method, outcome_type = outcome_type, - as_flag = TRUE)) { + as_flag = TRUE + )) { next } - + # Parse hyperparameter list hyperparameters <- c(hyperparameter_list[[outcome_type]]) - + # Find required hyperparameters vimp_method_hyperparameters <- .get_preset_hyperparameters( - fs_method = vimp_method, + vimp_method = vimp_method, outcome_type = outcome_type, - names_only = TRUE) - + names_only = TRUE + ) + # Select hyperparameters that are being used, and are present in the input # list of hyperparameters. hyperparameters <- hyperparameters[intersect(vimp_method_hyperparameters, names(hyperparameters))] - + # Prepare vimp object ---------------------------------------------------- cl_train <- .test_start_cluster(n_cores = 2L) - + # Prepare the variable importance objects. vimp_object_list <- parallel::parLapply( cl = cl_train, - list("1" = full_data, "2" = full_data), - prepare_vimp_object, + list( + "1" = full_data, + "2" = full_data + ), + test_create_vimp_method, vimp_method = vimp_method, vimp_method_parameter_list = hyperparameters, outcome_type = outcome_type, cluster_method = "none", - imputation_method = "simple") - + imputation_method = "simple" + ) + # Terminate cluster. cl_train <- .terminate_cluster(cl_train) - + # Variable importance ---------------------------------------------------- cl_vimp <- .test_start_cluster(n_cores = 2L) - + # Extract variable importance data. vimp_table_list <- parallel::parLapply( cl = cl_vimp, vimp_object_list, .vimp, - data = full_data) - + data = full_data + ) + # Extract the actual tables. vimp_table_list <- lapply(vimp_table_list, get_vimp_table) - + # Test that the model has variable importance. testthat::test_that( paste0( "Variable importance method produces variable importance for ", - outcome_type, " and ", vimp_method, " for the complete dataset."), + outcome_type, " and ", vimp_method, " for the complete dataset." + ), { # Get the number of features n_features <- get_n_features(full_data) # Expect that the vimp table has two rows. - testthat::expect_equal( - nrow(vimp_table_list[[1]]) > 0 && nrow(vimp_table_list[[1]]) <= n_features, - TRUE) - testthat::expect_equal( - nrow(vimp_table_list[[2]]) > 0 && nrow(vimp_table_list[[2]]) <= n_features, - TRUE) + testthat::expect_true( + nrow(vimp_table_list[[1L]]) > 0L && nrow(vimp_table_list[[1L]]) <= n_features + ) + testthat::expect_true( + nrow(vimp_table_list[[2L]]) > 0L && nrow(vimp_table_list[[2L]]) <= n_features + ) # Expect that the names in the vimp table correspond to those of the # features. - testthat::expect_equal( - all(vimp_table_list[[1]]$name %in% get_feature_columns(full_data)), - TRUE) - testthat::expect_equal( - all(vimp_table_list[[2]]$name %in% get_feature_columns(full_data)), - TRUE) + testthat::expect_true( + all(vimp_table_list[[1L]]$name %in% get_feature_columns(full_data)) + ) + testthat::expect_true( + all(vimp_table_list[[2L]]$name %in% get_feature_columns(full_data)) + ) } ) - + # Terminate cluster. cl_vimp <- .terminate_cluster(cl_vimp) } @@ -2460,17 +2611,19 @@ test_all_metrics_available <- function(metrics) { # Create placeholder flags. metric_available <- logical(length(metrics)) names(metric_available) <- metrics - + # Iterate over metrics for (metric in metrics) { # Determine if the metric is available for any outcome. for (outcome_type in c( - "count", "continuous", "binomial", "multinomial", "survival", "competing_risk")) { + "continuous", "binomial", "multinomial", "survival", "competing_risk" + )) { # Create a metric object object <- as_metric( metric = metric, - outcome_type = outcome_type) - + outcome_type = outcome_type + ) + # Check if the learner is available for the outcome. if (is_available(object)) { metric_available[metric] <- TRUE @@ -2478,7 +2631,7 @@ test_all_metrics_available <- function(metrics) { } } } - + # Iterate over learners for (metric in metrics) { testthat::test_that( @@ -2497,18 +2650,16 @@ test_all_metrics <- function( not_available_single_sample = FALSE, not_available_all_samples_identical = FALSE, not_available_all_predictions_identical = FALSE, - debug = FALSE) { + debug = FALSE +) { if (debug) { test_fun <- debug_test_that } else { test_fun <- testthat::test_that } - + # Iterate over the outcome type. - for (outcome_type in c("count", "continuous", "binomial", "multinomial", "survival")) { - - if (!test_data_package_installed(outcome_type)) next - + for (outcome_type in c("continuous", "binomial", "multinomial", "survival")) { # Obtain data. full_data <- test_create_good_data(outcome_type) identical_sample_data <- test_create_all_identical_data(outcome_type) @@ -2518,36 +2669,39 @@ test_all_metrics <- function( one_feature_invariant_data <- test_create_single_feature_invariant_data(outcome_type) empty_data <- test_create_empty_data(outcome_type) bad_data <- test_create_bad_data(outcome_type) - + # Data with different degrees of censoring. no_censoring_data <- test_create_good_data_without_censoring(outcome_type) one_censored_data <- test_create_good_data_one_censored(outcome_type) few_censored_data <- test_create_good_data_few_censored(outcome_type) - + # Prospective datasets with (partially) missing outcomes fully_prospective_data <- test_create_prospective_data(outcome_type) mostly_prospective_data <- test_create_mostly_prospective_data(outcome_type) partially_prospective_data <- test_create_partially_prospective_data(outcome_type) - + # Set exceptions per outcome type. .not_available_single_sample <- not_available_single_sample if (is.character(.not_available_single_sample)) { .not_available_single_sample <- any( - .not_available_single_sample == outcome_type) + .not_available_single_sample == outcome_type + ) } - + .not_available_all_samples_identical <- not_available_all_samples_identical if (is.character(.not_available_all_samples_identical)) { .not_available_all_samples_identical <- any( - .not_available_all_samples_identical == outcome_type) + .not_available_all_samples_identical == outcome_type + ) } - + .not_available_all_predictions_identical <- not_available_all_predictions_identical if (is.character(.not_available_all_predictions_identical)) { .not_available_all_predictions_identical <- any( - .not_available_all_predictions_identical == outcome_type) + .not_available_all_predictions_identical == outcome_type + ) } - + # Iterate over metrics for (metric in metrics) { # Check if the metric is available for the current outcome type, and skip @@ -2555,171 +2709,147 @@ test_all_metrics <- function( if (!.check_metric_outcome_type( metric = metric, outcome_type = outcome_type, - as_flag = TRUE)) { + as_flag = TRUE + )) { break } - + # Parse hyperparameter list hyperparameters <- list( "sign_size" = get_n_features(full_data), "family" = switch( outcome_type, "continuous" = "gaussian", - "count" = "poisson", "binomial" = "logistic", "multinomial" = "multinomial", - "survival" = "cox")) - + "survival" = "cox" + ) + ) + # Parse hyperparameter list for glmnet test. hyperparameters_lasso <- list( "sign_size" = get_n_features(full_data), "family" = switch( outcome_type, "continuous" = "gaussian", - "count" = "poisson", "binomial" = "binomial", "multinomial" = "multinomial", - "survival" = "cox")) - + "survival" = "cox" + ) + ) + # Full dataset ----------------------------------------------------------- - + # Train the model. - model <- do.call_with_handlers( - test_train, - args = list( - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "glm", - time_max = 1832 - ) + model <- suppressWarnings(test_train( + data = full_data, + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = "glm", + time_max = 3.5 ) - if (!test_object_package_installed(model)) next - model <- model$value - + ) + # Create metric object metric_object <- as_metric( metric = metric, - object = model) - + outcome_type = outcome_type + ) + # Test that metric values can be computed for the full model. test_fun( paste0( "1A. Model performance for ", outcome_type, " outcomes can be assessed by the ", - metric_object@name, " (", metric_object@metric, ") metric for a complete dataset."), + metric_object@name, " (", metric_object@metric, ") metric for a complete dataset." + ), { # Expect predictions to be made. - prediction_table <- suppressWarnings(.predict( - model, - data = full_data)) + prediction_table <- suppressWarnings(.predict(model, data = full_data)) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - - # Expect that the class levels are the same - # as those in the model. + # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number. - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) # Expect that the objective score is a non-missing number in the range # [-1, 1]. - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } ) - + if (outcome_type %in% c("survival", "competing_risk")) { # Test that metric values can be computed for the full model, but with # data without censored instances. test_fun( paste0( - "1B. Model performance for ", outcome_type, " outcomes can be assessed by the ", - metric_object@name, " (", metric_object@metric, ") metric for a data set without censoring."), + "1B. Model performance for ", outcome_type, " outcomes can be assessed by the ", + metric_object@name, " (", metric_object@metric, ") metric for a data set without censoring." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = no_censoring_data)) - - # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) - - if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - - # Expect that the class levels are the same - # as those in the model. - testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) - } + data = no_censoring_data + )) # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number. - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) # Expect that the objective score is a non-missing number in the # range [-1, 1]. - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } ) @@ -2729,365 +2859,325 @@ test_all_metrics <- function( paste0( "1C. Model performance for ", outcome_type, " outcomes can be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a dataset ", - "with one censored instances."), + "with one censored instances." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_censored_data)) + data = one_censored_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) - - if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - - # Expect that the class levels are the same - # as those in the model. - testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) - } + testthat::expect_true(any_predictions_valid(prediction_table)) # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number. - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) # Expect that the objective score is a non-missing number in the # range [-1, 1]. - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } ) - + # Test that metric values can be computed for the full model, but with # data with few censored instances. test_fun( paste0( "1D. Model performance for ", outcome_type, " outcomes can be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a dataset ", - "with few censored samples."), + "with few censored samples." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = few_censored_data)) + data = few_censored_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) - - if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - - # Expect that the class levels are the same - # as those in the model. - testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) - } + testthat::expect_true(any_predictions_valid(prediction_table)) # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number. - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) # Expect that the objective score is a non-missing number in the # range [-1, 1]. - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } ) } - + # Test that metric values can be computed for the full model. test_fun( paste0( "1E. Model performance for ", outcome_type, " outcomes can be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a dataset ", - "with some missing outcome values."), + "with some missing outcome values." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = partially_prospective_data)) + data = partially_prospective_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number. - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) # Expect that the objective score is a non-missing number in the range # [-1, 1]. - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } ) - + # Test for a dataset with fully missing outcomes. test_fun( paste0( "1F. Model performance for ", outcome_type, " outcomes cannot be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a dataset ", - "that misses observed outcomes."), + "that misses observed outcomes." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = fully_prospective_data)) + data = fully_prospective_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is NA. - testthat::expect_equal(is.na(score), TRUE) - - # Expect that the objective score is a non-missing number in the range - # [-1, 1]. - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(score)) + testthat::expect_true(is.na(objective_score)) } ) - + # Test that metric values can/cannot be computed for a one-sample dataset. test_fun( paste0( "2A. Model performance for ", outcome_type, " outcomes ", ifelse(.not_available_single_sample, "cannot", "can"), " be assessed by the ", metric_object@name, - " (", metric_object@metric, ") metric for a one-sample data set."), + " (", metric_object@metric, ") metric for a one-sample data set." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = full_one_sample_data)) + data = full_one_sample_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number, and NA # otherwise. if (.not_available_single_sample) { - testthat::expect_equal(is.na(score), TRUE) + testthat::expect_true(is.na(score)) + } else { - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) } # Expect that the objective score is a non-missing number in the range # [-1, 1] and NA otherwise. if (.not_available_single_sample) { - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(objective_score)) } else { - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } } ) - + test_fun( paste0( "2B. Model performance for ", outcome_type, " outcomes ", ifelse(.not_available_single_sample, "cannot", "can"), " be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a dataset with only ", - "one instance with known outcomes."), + "one instance with known outcomes." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = mostly_prospective_data)) + data = mostly_prospective_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is - # a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number, and NA # otherwise. if (.not_available_single_sample) { - testthat::expect_equal(is.na(score), TRUE) + testthat::expect_true(is.na(score)) + } else { - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) } # Expect that the objective score is a non-missing number in the range # [-1, 1] and NA otherwise. if (.not_available_single_sample) { - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(objective_score)) + } else { - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } } ) @@ -3097,35 +3187,34 @@ test_all_metrics <- function( test_fun( paste0( "3. Model performance for ", outcome_type, " outcomes cannot be assessed by the ", - metric_object@name, " (", metric_object@metric, ") metric for an empty dataset."), + metric_object@name, " (", metric_object@metric, ") metric for an empty dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = empty_data)) + data = empty_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - FALSE) + testthat::expect_false(any_predictions_valid(prediction_table)) # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is NA. - testthat::expect_equal(is.na(score), TRUE) - - # Expect that the objective score is NA. - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(score)) + testthat::expect_true(is.na(objective_score)) } ) @@ -3136,55 +3225,54 @@ test_all_metrics <- function( ifelse(.not_available_all_samples_identical, "cannot", "can"), " be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a dataset ", - "with identical samples."), - { - # Expect predictions to be made. - prediction_table <- suppressWarnings(.predict( - model, - data = identical_sample_data)) - - # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) - - # Compute a score. - score <- compute_metric_score( - metric = metric_object, - data = prediction_table, - object = model) - - # Compute an objective score. - objective_score <- compute_objective_score( - metric = metric_object, - data = prediction_table, - object = model) - - # Expect that the score is a finite, non-missing number. - if (.not_available_all_samples_identical) { - testthat::expect_equal(is.na(score), TRUE) - } else { - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) - } - - # Expect that the objective score is a non-missing number in the range - # [-1, 1]. - if (.not_available_all_samples_identical) { - testthat::expect_equal(is.na(objective_score), TRUE) - } else { - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) - } + "with identical samples." + ), + { + # Expect predictions to be made. + prediction_table <- suppressWarnings(.predict( + model, + data = identical_sample_data + )) + + # Test that the predictions were successfully made. + testthat::expect_true(any_predictions_valid(prediction_table)) + + # Compute a score. + score <- compute_metric_score( + metric = metric_object, + data = prediction_table + ) + + # Compute an objective score. + objective_score <- compute_objective_score( + metric = metric_object, + data = prediction_table, + object = model + ) + + # Expect that the score is a finite, non-missing number. + if (.not_available_all_samples_identical) { + testthat::expect_true(is.na(score)) + } else { + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) } + + # Expect that the objective score is a non-missing number in the range + # [-1, 1]. + if (.not_available_all_samples_identical) { + testthat::expect_true(is.na(objective_score)) + } else { + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) + } + } ) # One-feature data set --------------------------------------------------- @@ -3195,138 +3283,136 @@ test_all_metrics <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = "glm", - time_max = 1832)) - + time_max = 3.5 + )) + # Create metric object metric_object <- as_metric( metric = metric, - object = model) + outcome_type = outcome_type + ) # Test that metric values can be computed for the one-feature model. test_fun( paste0( "5. Model performance for ", outcome_type, " outcomes can be assessed by the ", - metric_object@name, " (", metric_object@metric, ") metric for a one-feature dataset."), + metric_object@name, " (", metric_object@metric, ") metric for a one-feature dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_feature_data)) + data = one_feature_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number. - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) # Expect that the objective score is a non-missing number in the range # [-1, 1]. - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } ) - + # Test that metric values cannot be computed for a one-sample dataset. test_fun( paste0( "6. Model performance for ", outcome_type, " outcomes ", ifelse(.not_available_single_sample, "cannot", "can"), " be assessed by the ", metric_object@name, - " (", metric_object@metric, ") metric for a one-feature, one-sample dataset."), + " (", metric_object@metric, ") metric for a one-feature, one-sample dataset." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_feature_one_sample_data)) + data = one_feature_one_sample_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number, and NA # otherwise. if (.not_available_single_sample) { - testthat::expect_equal(is.na(score), TRUE) + testthat::expect_true(is.na(score)) + } else { - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) } # Expect that the objective score is a non-missing number in the range # [-1, 1] and NA otherwise. if (.not_available_single_sample) { - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(objective_score)) + } else { - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } } ) - + # Test that metric values can be computed for the one-feature model with # invariant predicted outcomes for all samples. test_fun( @@ -3335,68 +3421,67 @@ test_all_metrics <- function( ifelse(.not_available_all_predictions_identical, "can", "cannot"), " be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a ", - "one-feature dataset with identical predictions."), + "one-feature dataset with identical predictions." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = one_feature_invariant_data)) + data = one_feature_invariant_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - TRUE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is a finite, non-missing number, and NA # otherwise. if (.not_available_all_predictions_identical) { - testthat::expect_equal(is.na(score), TRUE) + testthat::expect_true(is.na(score)) + } else { - testthat::expect_equal( - data.table::between( - score, - lower = metric_object@value_range[1], - upper = metric_object@value_range[2]), - TRUE) + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) } # Expect that the objective score is a non-missing number in the range # [-1, 1] and NA otherwise. if (.not_available_all_predictions_identical) { - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(objective_score)) + } else { - testthat::expect_equal( - data.table::between( - objective_score, - lower = -1.0, - upper = 1.0), - TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } } ) - + # Bad dataset ------------------------------------------------------------ # Train the model. model <- suppressWarnings(test_train( @@ -3405,181 +3490,178 @@ test_all_metrics <- function( imputation_method = "simple", hyperparameter_list = hyperparameters, learner = "glm", - time_max = 1832)) - + time_max = 3.5 + )) + # Create metric object metric_object <- as_metric( metric = metric, - object = model) - + outcome_type = outcome_type + ) + # Test that metric values can be computed for the one-feature model with # invariant predicted outcomes for all samples. test_fun( paste0( "8. Model performance for ", outcome_type, " outcomes cannot be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a bad ", - "dataset where the model fails to train."), + "dataset where the model fails to train." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = bad_data)) + data = bad_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - FALSE) - - if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - - # Expect that the class levels are the same as those in the model. - testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) - } + testthat::expect_false(any_predictions_valid(prediction_table)) # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is NA. - testthat::expect_equal(is.na(score), TRUE) - - # Expect that the objective score is a non-missing number in the range - # [-1, 1]. - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(score)) + testthat::expect_true(is.na(objective_score)) } ) # Without any valid predictions ------------------------------------------ model <- suppressWarnings(test_train( - data = bad_data, + data = full_data, cluster_method = "none", imputation_method = "simple", hyperparameter_list = hyperparameters_lasso, learner = "lasso_test_all_fail", - time_max = 1832)) - + time_max = 3.5 + )) + # Create metric object metric_object <- as_metric( metric = metric, - object = model) - + outcome_type = outcome_type + ) + test_fun( paste0( "9. Model performance for ", outcome_type, " outcomes cannot be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a model ", - "that only produces invalid predictions."), + "that only produces invalid predictions." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = full_data)) + data = full_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - FALSE) + testthat::expect_false(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) # Expect that the score is NA. - testthat::expect_equal(is.na(score), TRUE) - - # Expect that the objective score is a non-missing number in the range - # [-1, 1]. - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(is.na(score)) + testthat::expect_true(is.na(objective_score)) } ) # With some invalid predictions ------------------------------------------ model <- suppressWarnings(test_train( - data = bad_data, + data = full_data, cluster_method = "none", imputation_method = "simple", hyperparameter_list = hyperparameters_lasso, learner = "lasso_test_some_fail", - time_max = 1832)) + time_max = 3.5 + )) # Create metric object metric_object <- as_metric( metric = metric, - object = model) + outcome_type = outcome_type + ) test_fun( paste0( - "10. Model performance for ", outcome_type, " outcomes cannot be assessed by the ", + "10. Model performance for ", outcome_type, " outcomes can be assessed by the ", metric_object@name, " (", metric_object@metric, ") metric for a model ", - "that produces some invalid predictions."), + "that produces some invalid predictions." + ), { # Expect predictions to be made. prediction_table <- suppressWarnings(.predict( model, - data = full_data)) + data = full_data + )) # Test that the predictions were successfully made. - testthat::expect_equal( - any_predictions_valid(prediction_table, outcome_type), - FALSE) + testthat::expect_true(any_predictions_valid(prediction_table)) if (outcome_type %in% c("binomial", "multinomial")) { - # Expect that the predicted_class column is a factor. - testthat::expect_s3_class(prediction_table$predicted_class, "factor") - # Expect that the class levels are the same as those in the model. testthat::expect_equal( - levels(prediction_table$predicted_class), - get_outcome_class_levels(model)) + get_outcome_class_levels(prediction_table), + get_outcome_class_levels(model) + ) } # Compute a score. score <- compute_metric_score( metric = metric_object, - data = prediction_table, - object = model) + data = prediction_table + ) # Compute an objective score. objective_score <- compute_objective_score( metric = metric_object, data = prediction_table, - object = model) + object = model + ) - # Expect that the score is NA. - testthat::expect_equal(is.na(score), TRUE) + # Expect that the score is a finite, non-missing number. + testthat::expect_true(data.table::between( + score, + lower = metric_object@value_range[1L], + upper = metric_object@value_range[2L] + )) # Expect that the objective score is a non-missing number in the range # [-1, 1]. - testthat::expect_equal(is.na(objective_score), TRUE) + testthat::expect_true(data.table::between( + objective_score, + lower = -1.0, + upper = 1.0 + )) } ) } @@ -3591,7 +3673,7 @@ test_all_metrics <- function( test_hyperparameter_optimisation <- function( vimp_methods = NULL, learners = NULL, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), not_available_no_samples = TRUE, n_max_bootstraps = 25L, n_max_optimisation_steps = 3L, @@ -3601,7 +3683,8 @@ test_hyperparameter_optimisation <- function( ..., test_specific_config = FALSE, debug = FALSE, - parallel = waiver()) { + parallel = waiver() +) { if (debug) { test_fun <- debug_test_that verbose <- TRUE @@ -3609,21 +3692,21 @@ test_hyperparameter_optimisation <- function( test_fun <- testthat::test_that verbose <- FALSE } - + # Set parallelisation. if (is.waive(parallel)) parallel <- !debug - + if (parallel) { # Set options. # Disable randomForestSRC OpenMP core use. - options(rf.cores = as.integer(1)) + options(rf.cores = 1L) on.exit(options(rf.cores = -1L), add = TRUE) - + # Disable multithreading on data.table to prevent reduced performance due to # resource collisions with familiar parallelisation. data.table::setDTthreads(1L) on.exit(data.table::setDTthreads(0L), add = TRUE) - + # Start local cluster in the overall process. cl <- .test_start_cluster(n_cores = 2L) on.exit(.terminate_cluster(cl), add = TRUE) @@ -3631,51 +3714,48 @@ test_hyperparameter_optimisation <- function( } else { cl <- NULL } - + # Clean up dots dots <- list(...) dots$cl <- NULL dots$verbose <- NULL - + if (is.null(learners)) { is_vimp <- TRUE method_pool <- vimp_methods - + if (is.null(learners)) learners <- "glm" } else { is_vimp <- FALSE method_pool <- learners - + if (is.null(vimp_methods)) vimp_methods <- "mim" } - + # Iterate over the outcome type. for (outcome_type in outcome_type_available) { - - if (!test_data_package_installed(outcome_type)) next - # Multi-feature data sets. full_data <- test_create_good_data(outcome_type) identical_sample_data <- test_create_all_identical_data(outcome_type) full_one_sample_data <- test_create_one_sample_data(outcome_type) empty_data <- test_create_empty_data(outcome_type) - + # One-feature data sets. one_feature_data <- test_create_single_feature_data(outcome_type) one_feature_one_sample_data <- test_create_single_feature_one_sample_data(outcome_type) one_feature_invariant_data <- test_create_single_feature_invariant_data(outcome_type) - + # Set exceptions per outcome type. .not_available_no_samples <- not_available_no_samples if (is.character(.not_available_no_samples)) { .not_available_no_samples <- any(.not_available_no_samples == outcome_type) } - + .not_available_invariant_data <- FALSE if (is.character(.not_available_invariant_data)) { .not_available_invariant_data <- any(.not_available_invariant_data == outcome_type) } - + # Iterate over learners or variable importance methods. for (current_method in method_pool) { if (is_vimp) { @@ -3685,45 +3765,91 @@ test_hyperparameter_optimisation <- function( learner <- current_method vimp_method <- vimp_methods } - + if (!.check_learner_outcome_type( learner = learner, outcome_type = outcome_type, - as_flag = TRUE)) { + as_flag = TRUE + )) { next } if (!.check_vimp_outcome_type( method = vimp_method, outcome_type = outcome_type, - as_flag = TRUE)) { + as_flag = TRUE + )) { next } # Full data set----------------------------------------------------------- - - # Create object - object <- .test_create_hyperparameter_object( - data = full_data, - vimp_method = vimp_method, - learner = learner, - is_vimp = is_vimp, - set_signature_feature = TRUE) - - # Check that object is available for the outcome. + + if (is_vimp) { + object <- promote_vimp_method( + methods::new( + "familiarVimpMethod", + outcome_type = outcome_type, + vimp_method = vimp_method + ) + ) + + task <- task <- methods::new( + "familiarTaskVimpHyperparameters", + vimp_method = vimp_method + ) + + } else { + object <- promote_learner( + methods::new( + "familiarModel", + outcome_type = outcome_type, + vimp_method = vimp_method, + learner = learner + ) + ) + + task <- methods::new( + "familiarTaskLearnerHyperparameters", + vimp_method = vimp_method, + learner = learner + ) + } + if (!is_available(object)) next - + + # Reconstitute settings from the data. + settings <- extract_settings_from_data(data = full_data) + + # Update some missing settings that can be fixed within this method. + settings$data$train_cohorts <- unique(full_data@data[[get_id_columns(single_column = "batch")]]) + settings$data$signature <- get_feature_columns(full_data)[1L:2L] + + # Parse the remaining settings that are important. + settings <- do.call( + .parse_general_settings, + args = c( + list( + "settings" = settings, + "data" = full_data@data, + "vimp_method" = vimp_method, + "learner" = learner + ), + list(...) + ) + ) + .not_available_invariant_data <- FALSE .no_hyperparameters <- FALSE - + # Check default parameters default_hyperparameters <- get_default_hyperparameters( object, - data = full_data) + data = full_data + ) - if (length(default_hyperparameters) > 0) { + if (length(default_hyperparameters) > 0L) { randomised_hyperparameters <- sapply(default_hyperparameters, function(x) x$randomise) - + if ("sign_size" %in% names(randomised_hyperparameters)) { .not_available_invariant_data <- sum(randomised_hyperparameters) > 1L || !randomised_hyperparameters["sign_size"] @@ -3734,20 +3860,21 @@ test_hyperparameter_optimisation <- function( .no_hyperparameters <- TRUE .not_available_invariant_data <- TRUE } - + if (verbose) { message(paste0( "\nComputing hyperparameters for ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes for a complete data set.")) + outcome_type, " outcomes for a complete data set." + )) } - - # Hyperparameter optimisation on a full dataset. + + # Create object new_object <- do.call( - optimise_hyperparameters, + .perform_task, args = c( list( - "object" = object, + "object" = task, "data" = full_data, "cl" = cl, "n_max_bootstraps" = n_max_bootstraps, @@ -3755,57 +3882,62 @@ test_hyperparameter_optimisation <- function( "n_max_intensify_steps" = n_max_intensify_steps, "n_random_sets" = n_random_sets, "n_challengers" = n_challengers, - "is_vimp" = is_vimp, - "verbose" = verbose), - dots)) - + "verbose" = verbose, + "settings" = settings + ), + dots + ) + ) + # Test that hyperparameters were set. test_fun( paste0( "1. Hyperparameters for the ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes can be created for a complete data set."), + outcome_type, " outcomes can be created for a complete data set." + ), { if (.no_hyperparameters) { # Test that no hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } else if (!.no_hyperparameters || !not_available_no_samples) { # Test that hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), FALSE) + testthat::expect_false(is_empty(new_object@hyperparameters)) # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make # sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size >= 2), - TRUE) - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size <= get_n_features(full_data)), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size >= 2L) + ) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size <= get_n_features(full_data)) + ) if (vimp_method %in% .get_available_signature_only_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 2), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 2L) + ) } if (vimp_method %in% .get_available_none_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == get_n_features(full_data)), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == get_n_features(full_data)) + ) } if (vimp_method %in% .get_available_no_features_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 0), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 0L) + ) } } } @@ -3813,77 +3945,92 @@ test_hyperparameter_optimisation <- function( } ) + # Go to next outcome type if only a specific configuration needs to be + # tested. + if (test_specific_config) next + if (verbose) { message(paste0( "\nComputing hyperparameters for ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes for a data set with only identical entries.")) + outcome_type, " outcomes for a data set with only identical entries." + )) } - + + # Extract feature information. + feature_info <- new_object@feature_info + # Optimise for data that are completely identical. new_object <- do.call( - optimise_hyperparameters, + .perform_task, args = c( list( - "object" = object, + "object" = task, "data" = identical_sample_data, "cl" = cl, + "feature_info_list" = feature_info, "n_max_bootstraps" = n_max_bootstraps, "n_max_optimisation_steps" = n_max_optimisation_steps, "n_max_intensify_steps" = n_max_intensify_steps, "n_random_sets" = n_random_sets, "n_challengers" = n_challengers, - "is_vimp" = is_vimp, - "verbose" = verbose), - dots)) - + "verbose" = verbose, + "settings" = settings + ), + dots + ) + ) + # Test that hyperparameters were set. test_fun( paste0( "2. Hyperparameters for the ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes can be created for a data set with only identical entries."), + outcome_type, " outcomes can be created for a data set with only identical entries." + ), { if (.no_hyperparameters || .not_available_invariant_data) { # Test that no hyperparameters are set. Models cannot # train on completely invariant data. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) + } else if (!.not_available_invariant_data) { # Test that hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), FALSE) + testthat::expect_false(is_empty(new_object@hyperparameters)) # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make # sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size >= 2), - TRUE) - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size <= get_n_features(full_data)), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size >= 2L) + ) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size <= get_n_features(full_data)) + ) if (vimp_method %in% .get_available_signature_only_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 2), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 2L) + ) } if (vimp_method %in% .get_available_none_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == get_n_features(full_data)), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == get_n_features(full_data)) + ) } if (vimp_method %in% .get_available_no_features_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 0), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 0L) + ) } } } @@ -3895,75 +4042,82 @@ test_hyperparameter_optimisation <- function( message(paste0( "\nComputing hyperparameters for ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes for a data set with only one entry.")) + outcome_type, " outcomes for a data set with only one entry." + )) } - + # Optimise for data that consist of only one sample. new_object <- do.call( - optimise_hyperparameters, + .perform_task, args = c( list( - "object" = object, + "object" = task, "data" = full_one_sample_data, "cl" = cl, + "feature_info_list" = feature_info, "n_max_bootstraps" = n_max_bootstraps, "n_max_optimisation_steps" = n_max_optimisation_steps, "n_max_intensify_steps" = n_max_intensify_steps, "n_random_sets" = n_random_sets, "n_challengers" = n_challengers, - "is_vimp" = is_vimp, - "verbose" = verbose), - dots)) + "verbose" = verbose, + "settings" = settings + ), + dots + ) + ) # Test. test_fun( paste0( "3. Hyperparameters for the ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes can be created for a data set with only one entry."), + outcome_type, " outcomes can be created for a data set with only one entry." + ), { if (.no_hyperparameters) { # Test that no hyperparameters are set. Single entry data cannot be # used to generate hyperparameter sets unless they are always # available. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } else if (!not_available_no_samples) { # Test that hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), FALSE) + testthat::expect_false(is_empty(new_object@hyperparameters)) # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make # sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size >= 2), - TRUE) - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size <= get_n_features(full_data)), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size >= 2L) + ) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size <= get_n_features(full_data)) + ) if (vimp_method %in% .get_available_signature_only_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 2), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 2L) + ) } if (vimp_method %in% .get_available_none_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == get_n_features(full_data)), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == get_n_features(full_data)) + ) } if (vimp_method %in% .get_available_no_features_vimp_methods()) { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 0), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 0L) + ) } } } @@ -3974,25 +4128,26 @@ test_hyperparameter_optimisation <- function( # randomised hyperparameters depend only on the number of features. # Therefore, this is a softer check. - if (!is.null(new_object@hyperparameters)) { + if (!is_empty(new_object@hyperparameters)) { # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make # sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 2), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 2L) + ) } } } else { # Bogus test to prevent skipping. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } } } @@ -4002,25 +4157,30 @@ test_hyperparameter_optimisation <- function( message(paste0( "\nComputing hyperparameters for ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes for an empty data set.")) + outcome_type, " outcomes for an empty data set." + )) } - + # Optimise when data is missing. new_object <- do.call( - optimise_hyperparameters, + .perform_task, args = c( list( - "object" = object, + "object" = task, "data" = empty_data, "cl" = cl, + "feature_info_list" = feature_info, "n_max_bootstraps" = n_max_bootstraps, "n_max_optimisation_steps" = n_max_optimisation_steps, "n_max_intensify_steps" = n_max_intensify_steps, "n_random_sets" = n_random_sets, "n_challengers" = n_challengers, - "is_vimp" = is_vimp, - "verbose" = verbose), - dots)) + "verbose" = verbose, + "settings" = settings + ), + dots + ) + ) # Test. test_fun( @@ -4029,21 +4189,23 @@ test_hyperparameter_optimisation <- function( ifelse(is_vimp, " variable importance method", " learner"), " and ", outcome_type, " outcomes ", ifelse(!not_available_no_samples, "can", "cannot"), - " be created for an empty data set."), + " be created for an empty data set." + ), { if (.no_hyperparameters) { # Test that no hyperparameters are set. Empty datasets cannot be # used to create hyperparameters. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } else if (!not_available_no_samples) { # Test that hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), FALSE) + testthat::expect_false(is_empty(new_object@hyperparameters)) # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) } else { # Not always available, but with hyperparameters. For some methods @@ -4051,50 +4213,65 @@ test_hyperparameter_optimisation <- function( # randomised hyperparameters depend only on the number of features. # Therefore, this is a softer check. - if (!is.null(new_object@hyperparameters)) { + if (!is_empty(new_object@hyperparameters)) { # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp && !is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make # sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 2), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 2L) + ) } } else { # Bogus test to prevent skipping. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is.null(new_object@hyperparameters)) } } } ) - + # One-feature data set --------------------------------------------------- - # Create object - object <- .test_create_hyperparameter_object( - data = one_feature_data, - vimp_method = vimp_method, - learner = learner, - is_vimp = is_vimp, - set_signature_feature = FALSE) - + + # Reconstitute settings from the data. + settings <- extract_settings_from_data(data = one_feature_data) + + # Update some missing settings that can be fixed within this method. + settings$data$train_cohorts <- unique(full_data@data[[get_id_columns(single_column = "batch")]]) + + # Parse the remaining settings that are important. + settings <- do.call( + .parse_general_settings, + args = c( + list( + "settings" = settings, + "data" = one_feature_data@data, + "vimp_method" = vimp_method, + "learner" = learner + ), + list(...) + ) + ) + if (verbose) { message(paste0( "\nComputing hyperparameters for ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes for a data set with only one feature.")) + outcome_type, " outcomes for a data set with only one feature." + )) } - + # Optimise parameters for a dataset with only one feature. new_object <- do.call( - optimise_hyperparameters, + .perform_task, args = c( list( - "object" = object, + "object" = task, "data" = one_feature_data, "cl" = cl, "n_max_bootstraps" = n_max_bootstraps, @@ -4102,90 +4279,106 @@ test_hyperparameter_optimisation <- function( "n_max_intensify_steps" = n_max_intensify_steps, "n_random_sets" = n_random_sets, "n_challengers" = n_challengers, - "is_vimp" = is_vimp, - "verbose" = verbose), - dots)) + "verbose" = verbose, + "settings" = settings + ), + dots + ) + ) test_fun( paste0( "5. Hyperparameters for the ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes can be created for a data set with only one feature."), + outcome_type, " outcomes can be created for a data set with only one feature." + ), { if (.no_hyperparameters) { # Test that no hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) + } else if (!.no_hyperparameters || !not_available_no_samples) { # Test that hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), FALSE) + testthat::expect_false(is_empty(new_object@hyperparameters)) # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 1), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 1L) + ) } } } } ) + # Extract feature info. + feature_info <- new_object@feature_info + if (verbose) { message(paste0( "\nComputing hyperparameters for ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes for a data set with only one feature and sample.")) + outcome_type, " outcomes for a data set with only one feature and sample." + )) } # Optimise parameters for a dataset with only one feature and sample. new_object <- do.call( - optimise_hyperparameters, + .perform_task, args = c( list( - "object" = object, + "object" = task, "data" = one_feature_one_sample_data, "cl" = cl, + "feature_info_list" = feature_info, "n_max_bootstraps" = n_max_bootstraps, "n_max_optimisation_steps" = n_max_optimisation_steps, "n_max_intensify_steps" = n_max_intensify_steps, "n_random_sets" = n_random_sets, "n_challengers" = n_challengers, - "is_vimp" = is_vimp, - "verbose" = verbose), - dots)) + "verbose" = verbose, + "settings" = settings + ), + dots + ) + ) test_fun( paste0( "6. Hyperparameters for the ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes can be created for a data set with only one feature and sample."), + outcome_type, " outcomes can be created for a data set with only one feature and sample." + ), { if (.no_hyperparameters) { # Test that no hyperparameters are set. Hyperparameters cannot be # set for datasets with only a single sample. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } else if (!not_available_no_samples) { # Test that hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), FALSE) + testthat::expect_false(is_empty(new_object@hyperparameters)) # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 1), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 1L) + ) } } @@ -4195,23 +4388,24 @@ test_hyperparameter_optimisation <- function( # randomised hyperparameters depend only on the number of features. # Therefore, this is a softer check. - if (!is.null(new_object@hyperparameters)) { + if (!is_empty(new_object@hyperparameters)) { # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 1), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 1L) + ) } } } else { # Bogus test to prevent skipping. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } } } @@ -4221,53 +4415,61 @@ test_hyperparameter_optimisation <- function( message(paste0( "\nComputing hyperparameters for ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", - outcome_type, " outcomes for a data set with only one, invariant feature.")) + outcome_type, " outcomes for a data set with only one, invariant feature." + )) } # Optimise parameters for a dataset with only one, invariant feature. new_object <- do.call( - optimise_hyperparameters, + .perform_task, args = c( list( - "object" = object, + "object" = task, "data" = one_feature_invariant_data, "cl" = cl, + "feature_info_list" = feature_info, "n_max_bootstraps" = n_max_bootstraps, "n_max_optimisation_steps" = n_max_optimisation_steps, "n_max_intensify_steps" = n_max_intensify_steps, "n_random_sets" = n_random_sets, "n_challengers" = n_challengers, - "is_vimp" = is_vimp, - "verbose" = verbose), - dots)) + "verbose" = verbose, + "settings" = settings + ), + dots + ) + ) + test_fun( paste0( "7. Hyperparameters for the ", current_method, ifelse(is_vimp, " variable importance method", " learner"), " and ", outcome_type, " outcomes can be created for a data set with ", - "only one, invariant feature."), + "only one, invariant feature." + ), { if (.no_hyperparameters) { # Test that no hyperparameters are set. Hyperparameters cannot be # set for datasets with invariant features. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } else if (!not_available_no_samples) { # Test that hyperparameters are set. - testthat::expect_equal(is.null(new_object@hyperparameters), FALSE) + testthat::expect_false(is_empty(new_object@hyperparameters)) # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 1), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 1L) + ) } } @@ -4277,23 +4479,24 @@ test_hyperparameter_optimisation <- function( # randomised hyperparameters depend only on the number of features. # Therefore, this is a softer check. - if (!is.null(new_object@hyperparameters)) { + if (!is_empty(new_object@hyperparameters)) { # Test that all hyperparameters are set. testthat::expect_setequal( names(new_object@hyperparameters), - names(get_default_hyperparameters(object))) + names(get_default_hyperparameters(object)) + ) if (!is_vimp) { if (!is.null(new_object@hyperparameter_data$parameter_table)) { # Test that sign_size hyperparameters make sense. - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 1), - TRUE) + testthat::expect_true( + all(new_object@hyperparameter_data$parameter_table$sign_size == 1L) + ) } } } else { # Bogus test to prevent skipping. - testthat::expect_equal(is.null(new_object@hyperparameters), TRUE) + testthat::expect_true(is_empty(new_object@hyperparameters)) } } } @@ -4305,1089 +4508,707 @@ test_hyperparameter_optimisation <- function( test_plots <- function( + plot_function, + ..., + plot_args = list(), + debug = FALSE, + parallel = waiver() +) { + if (debug) { + test_fun <- debug_test_that + } else { + test_fun <- testthat::test_that + } + + # Set parallelisation. + if (is.waive(parallel)) parallel <- !debug + + if (parallel) { + # Set options. + # Disable randomForestSRC OpenMP core use. + options(rf.cores = 1L) + on.exit(options(rf.cores = -1L), add = TRUE) + + # Disable multithreading on data.table to prevent reduced performance due to + # resource collisions with familiar parallelisation. + data.table::setDTthreads(1L) + on.exit(data.table::setDTthreads(0L), add = TRUE) + + # Start local cluster in the overall process. + cl <- .test_start_cluster(n_cores = 2L) + on.exit(.terminate_cluster(cl), add = TRUE) + + } else { + cl <- NULL + } + + test_collection_generator <- get_test_collection_generation(..., cl = cl) + + while (TRUE) { + # Generate parameters. + collection <- test_collection_generator() + if (coro::is_exhausted(collection)) break + + plot_fun_args <- c( + list("object" = collection$collection), + plot_args + ) + if (debug) plot_fun_args <- c(plot_fun_args, list("draw" = TRUE)) + + test_fun( + collection$message, + { + plot_list <- do.call( + plot_function, + args = plot_fun_args + ) + + # Determine which plots are present. + which_present <- .test_which_plot_present(plot_list) + + if (collection$expectation == "all_present") { + testthat::expect_true(all(which_present)) + } else if (collection$expectation == "all_absent") { + testthat::expect_true(!any(which_present)) + } else if (collection$expectation == "any_absent") { + testthat::expect_true(!all(which_present)) + } else { + ..error_reached_unreachable_code(paste0("unexpected expectation value:", collection$expectation)) + } + } + ) + } + +} + + + +test_plot_ordering <- function( plot_function, data_element, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - not_available_no_samples = TRUE, - not_available_single_feature = FALSE, - not_available_all_predictions_fail = TRUE, - not_available_some_predictions_fail = TRUE, - not_available_all_prospective = FALSE, - not_available_any_prospective = FALSE, - not_available_single_sample = FALSE, - not_available_extreme_probability = FALSE, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), ..., + experiment_args = list(), plot_args = list(), - test_specific_config = FALSE, create_novelty_detector = FALSE, + use_prediction_table = FALSE, + prediction_type = NULL, + use_single_sample = FALSE, debug = FALSE, - debug_outcome_type = NULL, - parallel = waiver()) { + parallel = waiver() +) { + + ..as_familiar_data_object <- function( + object, + data, + data_element, + cl, + use_prediction_table, + prediction_type, + ... + ) { + if (use_prediction_table) { + if (is.null(prediction_type)) prediction_type <- "default" + + # Generate data from prediction tables. + familiar_data_object <- as_familiar_data( + object = .predict(object = object, data = data, type = prediction_type, ...), + data_element = data_element, + cl = cl, + ... + ) + + } else { + # Generate data from models and ensembles. + familiar_data_object <- as_familiar_data( + object = object, + data = data, + data_element = data_element, + cl = cl, + ... + ) + } + + return(familiar_data_object) + } + ..duplicate_familiar_data_object <- function(x) { + x <- set_object_name(x) + x@vimp_method <- "mifs" + return(x) + } + + # Set debug options. if (debug) { test_fun <- debug_test_that plot_args$draw <- TRUE } else { test_fun <- testthat::test_that } - + # Set parallelisation. if (is.waive(parallel)) parallel <- !debug - + if (parallel) { # Set options. # Disable randomForestSRC OpenMP core use. - options(rf.cores = as.integer(1)) + options(rf.cores = 1L) on.exit(options(rf.cores = -1L), add = TRUE) - + # Disable multithreading on data.table to prevent reduced performance due to # resource collisions with familiar parallelisation. data.table::setDTthreads(1L) on.exit(data.table::setDTthreads(0L), add = TRUE) - + # Start local cluster in the overall process. cl <- .test_start_cluster(n_cores = 2L) on.exit(.terminate_cluster(cl), add = TRUE) + } else { cl <- NULL } - - all_outcome_types <- c("count", "continuous", "survival", "binomial", "multinomial") - if (debug && !is.null(debug_outcome_type)) { - all_outcome_types <- debug_outcome_type - } + + if (is.null(experiment_args$imputation_method)) experiment_args$imputation_method <- "simple" + if (is.null(experiment_args$cluster_method)) experiment_args$cluster_method <- "none" + if (is.null(experiment_args$vimp_method)) experiment_args$vimp_method <- "mim" + if (is.null(experiment_args$time_max)) experiment_args$time_max <- 3.5 # Iterate over the outcome type. - for (outcome_type in all_outcome_types) { - - if (!test_data_package_installed(outcome_type)) next - + for (outcome_type in outcome_type_available) { # Obtain data. full_data <- test_create_good_data(outcome_type) - identical_sample_data <- test_create_all_identical_data(outcome_type) - full_one_sample_data <- test_create_one_sample_data(outcome_type) - bootstrapped_data <- test_create_bootstrapped_data(outcome_type) - one_feature_data <- test_create_single_feature_data(outcome_type) - one_feature_one_sample_data <- test_create_single_feature_one_sample_data(outcome_type) - one_feature_invariant_data <- test_create_single_feature_invariant_data(outcome_type) + single_data <- test_create_one_sample_data(outcome_type) empty_data <- test_create_empty_data(outcome_type) - multi_data <- test_create_multiple_synthetic_series(outcome_type = outcome_type) - - # Data with different degrees of censoring. - one_censored_data <- test_create_good_data_one_censored(outcome_type) - few_censored_data <- test_create_good_data_few_censored(outcome_type) - no_censoring_data <- test_create_good_data_without_censoring(outcome_type) - - # Prospective datasets with (partially) missing outcomes - fully_prospective_data <- test_create_prospective_data(outcome_type) - mostly_prospective_data <- test_create_mostly_prospective_data(outcome_type) - partially_prospective_data <- test_create_partially_prospective_data(outcome_type) - - # Set exceptions per outcome type. - .not_available_no_samples <- not_available_no_samples - if (is.character(.not_available_no_samples)) { - .not_available_no_samples <- any(.not_available_no_samples == outcome_type) - } - - .not_available_single_feature <- not_available_single_feature - if (is.character(.not_available_single_feature)) { - .not_available_single_feature <- any(.not_available_single_feature == outcome_type) - } - - .not_available_all_predictions_fail <- not_available_all_predictions_fail - if (is.character(.not_available_all_predictions_fail)) { - .not_available_all_predictions_fail <- any(.not_available_all_predictions_fail == outcome_type) - } - - .not_available_some_predictions_fail <- not_available_some_predictions_fail - if (is.character(.not_available_some_predictions_fail)) { - .not_available_some_predictions_fail <- any(.not_available_some_predictions_fail == outcome_type) - } - - .not_available_any_prospective <- not_available_any_prospective - if (is.character(.not_available_any_prospective)) { - .not_available_any_prospective <- any(.not_available_any_prospective == outcome_type) - } - - .not_available_all_prospective <- not_available_all_prospective - if (is.character(.not_available_all_prospective)) { - .not_available_all_prospective <- any(.not_available_all_prospective == outcome_type) - } - - .not_available_single_sample <- not_available_single_sample - if (is.character(.not_available_single_sample)) { - .not_available_single_sample <- any(.not_available_single_sample == outcome_type) - } - .not_available_extreme_probability <- not_available_extreme_probability - if (is.character(.not_available_extreme_probability)) { - .not_available_extreme_probability <- any(.not_available_extreme_probability == outcome_type) - } - # Parse hyperparameter list - hyperparameters <- list( + hyperparameters_lasso <- list( "sign_size" = get_n_features(full_data), "family" = switch( outcome_type, "continuous" = "gaussian", - "count" = "poisson", "binomial" = "binomial", "multinomial" = "multinomial", - "survival" = "cox")) - - # Full data set ------------------------------------------------------------ - - # Train the model. - model_full_1 <- do.call_with_handlers( + "survival" = "cox" + ) + ) + + # Train the lasso model. + model_full_lasso <- suppressWarnings(do.call( test_train, - args = list( - cl = cl, - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, - create_novelty_detector = create_novelty_detector + args = c( + list( + "data" = full_data, + "hyperparameter_list" = hyperparameters_lasso, + "learner" = "lasso", + "create_novelty_detector" = create_novelty_detector + ), + experiment_args + ) + )) + + # Parse hyperparameter list + hyperparameters_glm <- list( + "sign_size" = get_n_features(full_data), + "family" = switch( + outcome_type, + "continuous" = "gaussian", + "binomial" = "logistic", + "multinomial" = "multinomial", + "survival" = "cox" ) ) - if (!test_object_package_installed(model_full_1)) next - model_full_1 <- model_full_1$value - - model_full_2 <- model_full_1 - model_full_2@fs_method <- "mifs" - + + # Train the lasso model. + model_full_glm <- suppressWarnings(do.call( + test_train, + args = c( + list( + "data" = full_data, + "hyperparameter_list" = hyperparameters_glm, + "learner" = "glm", + "create_novelty_detector" = create_novelty_detector + ), + experiment_args + ) + )) + + if (use_single_sample) { + input_data <- single_data + } else { + input_data <- full_data + } + # Create familiar data objects. - data_good_full_1 <- as_familiar_data( - object = model_full_1, - data = full_data, + data_good_full_lasso_1 <- ..as_familiar_data_object( + object = model_full_lasso, + data = input_data, data_element = data_element, cl = cl, - ...) - data_good_full_2 <- as_familiar_data( - object = model_full_2, - data = full_data, + use_prediction_table = use_prediction_table, + prediction_type = prediction_type[[outcome_type]], + ... + ) + data_good_full_lasso_2 <- ..duplicate_familiar_data_object(data_good_full_lasso_1) + data_good_full_glm_1 <- ..as_familiar_data_object( + object = model_full_glm, + data = input_data, data_element = data_element, cl = cl, - ...) - - # Create a completely intact dataset. + use_prediction_table = use_prediction_table, + prediction_type = prediction_type[[outcome_type]], + ... + ) + data_good_full_glm_2 <- ..duplicate_familiar_data_object(data_good_full_glm_1) + data_empty_glm_1 <- ..as_familiar_data_object( + object = model_full_glm, + data = empty_data, + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + prediction_type = prediction_type[[outcome_type]], + ... + ) + + data_empty_lasso_1 <- ..as_familiar_data_object( + object = model_full_lasso, + data = empty_data, + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + prediction_type = prediction_type[[outcome_type]], + ... + ) + data_empty_lasso_2 <- ..duplicate_familiar_data_object(data_empty_lasso_1) + + # Create a test dataset with multiple components test_fun( - paste0( - "1. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a complete data set."), + paste0("Plots for ", outcome_type, " outcomes can be created."), { - object <- list(data_good_full_1, data_good_full_2, data_good_full_1, data_good_full_2) + object <- list( + data_good_full_lasso_1, data_empty_lasso_2, data_good_full_lasso_1, data_good_full_lasso_2, + data_good_full_glm_1, data_good_full_glm_2, data_empty_glm_1, data_good_full_glm_2 + ) + object <- mapply( set_object_name, object, - c("development_1", "development_2", "validation_1", "validation_2")) + c( + "development_lasso_1", "development_lasso_2", "validation_lasso_1", "validation_lasso_2", + "development_glm_1", "development_glm_2", "validation_glm_1", "validation_glm_2" + ) + ) collection <- suppressWarnings(as_familiar_collection( object, - familiar_data_names = c("development", "development", "validation", "validation"))) + familiar_data_names = c( + "development", "development", "validation", "validation", + "development", "development", "validation", "validation" + ) + )) plot_list <- do.call( plot_function, - args = c( - list( - "object" = collection, - "export_collection" = TRUE), - plot_args)) - - if (outcome_type %in% outcome_type_available) { - # Test which plot elements are present. - which_present <- .test_which_plot_present(plot_list$plot_list) - testthat::expect_equal(all(which_present), TRUE) - - # Test that a collection is exported. - testthat::expect_s4_class(plot_list$collection, "familiarCollection") - - } else { - # Test which plot elements are present. - which_present <- .test_which_plot_present(plot_list) - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - - # Go to next outcome type if only a specific configuration needs to be - # tested. - if (test_specific_config) next - - # Create familiar data objects without known outcome data. - data_prospective_full_1 <- as_familiar_data( - object = model_full_1, - data = fully_prospective_data, - data_element = data_element, - cl = cl, - ...) - - # Create plots. - test_fun( - paste0( - "2A. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_all_prospective, - "can", "cannot"), - " be created for a prospective data set without known outcome."), - { - object <- list(data_prospective_full_1) - object <- mapply(set_object_name, object, c("prospective")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("prospective"))) - - plot_list <- do.call( - plot_function, args = c( list("object" = collection), - plot_args)) + plot_args + ) + ) which_present <- .test_which_plot_present(plot_list) - if (outcome_type %in% outcome_type_available && - !.not_available_all_prospective) { - testthat::expect_equal(all(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) + if (outcome_type %in% outcome_type_available) { + testthat::expect_true(all(which_present)) } else { - testthat::expect_equal(any(!which_present), TRUE) + testthat::expect_true(!any(which_present)) } } ) + } +} - # Create familiar data objects with mostly unknown outcome data. - data_prospective_most_1 <- as_familiar_data( - object = model_full_1, - data = mostly_prospective_data, - data_element = data_element, - cl = cl, - ...) - # Create plots. - test_fun( - paste0( - "2B. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && - (!.not_available_any_prospective || !.not_available_single_sample), - "can", "cannot"), - " be created for a prospective data set with one instance with known outcome."), - { - object <- list(data_prospective_most_1) - object <- mapply(set_object_name, object, c("prospective")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("prospective"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available && - (!.not_available_any_prospective || !.not_available_single_sample)) { - testthat::expect_equal(all(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) - - # Create familiar data objects where most outcomes are known. - data_prospective_partial_1 <- as_familiar_data( - object = model_full_1, - data = partially_prospective_data, - data_element = data_element, - cl = cl, - ...) - - # Create a completely intact dataset. - test_fun( - paste0( - "2C. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a prospective data set where most instances are known."), - { - object <- list(data_prospective_partial_1) - object <- mapply(set_object_name, object, c("prospective")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("prospective"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - # Create data object with one sample. - data_one_sample_full_1 <- as_familiar_data( - object = model_full_1, - data = full_one_sample_data, - data_element = data_element, - cl = cl, - ...) +test_export <- function( + export_function, + ..., + export_args = list(), + debug = FALSE, + debug_config = NULL, + debug_outcome_type = NULL, + parallel = waiver() +) { + # Automatically override debug + if (!is.null(debug_config)) debug <- TRUE + if (!is.null(debug_outcome_type)) debug <- TRUE + + if (debug) { + test_fun <- debug_test_that + } else { + test_fun <- testthat::test_that + } + + # Set parallelisation. + if (is.waive(parallel)) parallel <- !debug + + if (parallel) { + # Set options. + # Disable randomForestSRC OpenMP core use. + options(rf.cores = 1L) + on.exit(options(rf.cores = -1L), add = TRUE) + + # Disable multithreading on data.table to prevent reduced performance due to + # resource collisions with familiar parallelisation. + data.table::setDTthreads(1L) + on.exit(data.table::setDTthreads(0L), add = TRUE) + + # Start local cluster in the overall process. + cl <- .test_start_cluster(n_cores = 2L) + on.exit(.terminate_cluster(cl), add = TRUE) + + } else { + cl <- NULL + } + + test_collection_generator <- get_test_collection_generation( + ..., + cl = cl, + debug_config = debug_config, + debug_outcome_type = debug_outcome_type + ) + + while (TRUE) { + # Generate parameters. + collection <- test_collection_generator() + if (coro::is_exhausted(collection)) break test_fun( - paste0( - "2D. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available && - !.not_available_single_sample, - "can", "cannot"), - " be created for a prospective data set with one instance."), + collection$message, { - object <- list(data_one_sample_full_1) - object <- mapply(set_object_name, object, c("one_sample")) - - collection <- suppressWarnings(as_familiar_collection(object, familiar_data_names = c("one_sample"))) - - plot_list <- do.call( - plot_function, + data_elements <- do.call( + export_function, args = c( - list("object" = collection), - plot_args)) + list("object" = collection$collection), + export_args + ) + ) - which_present <- .test_which_plot_present(plot_list) + # Determine which elements are present. + which_present <- .test_which_data_element_present( + data_elements, + outcome_type = collection$collection@outcome_type + ) - if (outcome_type %in% outcome_type_available && !.not_available_single_sample) { - testthat::expect_equal(all(which_present), TRUE) + if (collection$expectation == "all_present") { + testthat::expect_true(all(which_present)) - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) + if (debug) show(data_elements) + } else if (collection$expectation == "all_absent") { + testthat::expect_true(!any(which_present)) + } else if (collection$expectation == "any_absent") { + testthat::expect_true(!all(which_present)) } else { - testthat::expect_equal(any(!which_present), TRUE) + ..error_reached_unreachable_code(paste0("unexpected expectation value:", collection$expectation)) } } ) - - # Create data object with bootstrapped data. - data_bootstrapped_full_1 <- as_familiar_data( - object = model_full_1, - data = bootstrapped_data, - data_element = data_element, - cl = cl, - ...) + } +} - test_fun( - paste0( - "2E. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a prospective, bootstrapped, data set."), - { - object <- list(data_bootstrapped_full_1) - object <- mapply(set_object_name, object, c("bootstrapped")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("bootstrapped"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - # Ensemble from multiple datasets. - multi_model_set <- suppressWarnings(lapply( - multi_data, - test_train, - cluster_method = "hclust", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - cluster_similarity_threshold = 0.7, - time_max = 60, - create_novelty_detector = create_novelty_detector)) - # Train a naive model. - naive_model <- suppressWarnings( - train_familiar( - data = multi_data[[1]], - experimental_design = "fs+mb", - cluster_method = "hclust", +test_export_specific <- function( + export_function, + data_element, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + ..., + export_args = list(), + use_data_set = "full", + use_prediction_table = FALSE, + n_models = 1L, + create_novelty_detector = FALSE, + debug = FALSE +) { + + ..duplicate_familiar_data_object <- function(x) { + x <- set_object_name(x) + x@vimp_method <- "mifs" + return(x) + } + + # Create list for output. + out_elements <- list() + + # Iterate over the outcome type. + for (outcome_type in outcome_type_available) { + # Obtain data. + main_data <- test_create_good_data(outcome_type) + + data <- switch( + use_data_set, + "full" = test_create_good_data(outcome_type), + "identical" = test_create_all_identical_data(outcome_type), + "one_sample" = test_create_one_sample_data(outcome_type) + ) + + # Parse hyperparameter list + hyperparameters <- list( + "sign_size" = get_n_features(main_data), + "family" = switch( + outcome_type, + "continuous" = "gaussian", + "binomial" = "binomial", + "multinomial" = "multinomial", + "survival" = "cox" + ) + ) + + if (n_models == 1L) { + # Train the model. + model_full <- suppressWarnings(test_train( + data = main_data, + cluster_method = "none", imputation_method = "simple", - fs_method = "no_features", + hyperparameter_list = hyperparameters, learner = "lasso", - hyperparameter = hyperparameters, - cluster_similarity_threshold = 0.7, - time_max = 60, - parallel = FALSE, - verbose = FALSE)) + time_max = 3.5, + create_novelty_detector = create_novelty_detector + )) + + } else { + # Train a set of models. + model_full <- list() + + for (ii in seq_len(n_models)) { + temp_model <- suppressWarnings(test_train( + data = test_create_bootstrapped_data(outcome_type, seed = ii), + cluster_method = "none", + imputation_method = "simple", + vimp_method = "mim", + hyperparameter_list = hyperparameters, + learner = "lasso", + time_max = 3.5, + create_bootstrap = TRUE, + create_novelty_detector = create_novelty_detector + )) + + model_full[[ii]] <- temp_model + } + } + + if (use_prediction_table) { + # Generate data from prediction tables. + data_good_full_1 <- as_familiar_data( + object = .predict(object = model_full, data = data, ...), + data_element = data_element, + ... + ) + + } else { + # Generate data from models and ensembles. + data_good_full_1 <- as_familiar_data( + object = model_full, + data = data, + data_element = data_element, + ... + ) + } + + data_good_full_2 <- ..duplicate_familiar_data_object(data_good_full_1) + + # Generate data objects and names. + object <- list(data_good_full_1, data_good_full_2, data_good_full_1, data_good_full_2) + object <- mapply( + set_object_name, + object, + c("development_1", "development_2", "validation_1", "validation_2") + ) + + # Process to collect. + collection <- suppressWarnings(as_familiar_collection( + object, + familiar_data_names = c("development", "development", "validation", "validation") + )) + + # Create data elements. + data_elements <- do.call( + export_function, + args = c( + list("object" = collection), + export_args + ) + ) + + # Save data elements and add name. + current_element <- list(data_elements) + names(current_element) <- outcome_type - # Replace fs_method attribute - naive_model@fs_method <- "none" + out_elements <- c(out_elements, current_element) + } + + return(out_elements) +} - # Add naive model to the multi-model dataset. - multi_model_set <- c(multi_model_set, list("naive" = naive_model)) - # Create data from ensemble of multiple models - multi_model_full <- as_familiar_data( - object = multi_model_set, - data = multi_data[[1]], - data_element = data_element, - cl = cl, - ...) - # Replace fs_method attribute - naive_model@fs_method <- "mifs" +integrated_test <- function( + ..., + learner = NULL, + hyperparameters = NULL, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + warning_good = NULL, + warning_bad = NULL, + debug = FALSE, + test_situations = c("good", "bad") +) { + if (debug) { + test_fun <- debug_test_that + suppress_fun <- suppress_fun_messages <- identity - # Create additional familiar data objects. - data_naive_full <- as_familiar_data( - object = naive_model, - data = full_data, - data_element = data_element, - cl = cl, - ... - ) - data_empty_full_1 <- as_familiar_data( - object = model_full_1, - data = empty_data, - data_element = data_element, - cl = cl, - ...) - data_empty_full_2 <- as_familiar_data( - object = model_full_2, - data = empty_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_full_1 <- as_familiar_data( - object = model_full_1, - data = full_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_full_2 <- as_familiar_data( - object = model_full_2, - data = full_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_identical_full_1 <- as_familiar_data( - object = model_full_1, - data = identical_sample_data, - data_element = data_element, - cl = cl, - ...) - data_identical_full_2 <- as_familiar_data( - object = model_full_2, - data = identical_sample_data, - data_element = data_element, - cl = cl, - ...) - - # Create a dataset with a missing quadrant. - test_fun( - paste0( - "3. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset with some missing data and a naive model."), - { - object <- list(data_good_full_1, data_naive_full, data_empty_full_1, data_good_full_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(any(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - - # Create a dataset with all missing quadrants - test_fun( - paste0( - "4. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_no_samples, - "can", "cannot"), - " be created for a dataset with completely missing data."), - { - object <- list(data_empty_full_1, data_empty_full_2, data_empty_full_1, data_empty_full_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available && !.not_available_no_samples) { - testthat::expect_equal(all(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - - # Create dataset with one-sample quadrants for validation - test_fun( - paste0( - "5. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset where some data only have one sample."), - { - object <- list(data_good_full_1, data_good_full_2, data_one_sample_full_1, data_one_sample_full_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(any(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - - # Create dataset with some quadrants with identical data - test_fun( - paste0( - "6. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset where some data only have identical samples."), - { - object <- list(data_good_full_1, data_good_full_2, data_identical_full_1, data_identical_full_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) + } else { + test_fun <- testthat::test_that + suppress_fun <- suppressWarnings + suppress_fun_messages <- suppressMessages + } + + # Set flag for missing learner. + learner_unset <- is.null(learner) + + for (outcome_type in outcome_type_available) { + .warning_good <- warning_good + if (is.list(warning_good)) { + .warning_good <- warning_good[[outcome_type]] + } - test_fun( - paste0( - "7. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset created from an ensemble of multiple models."), - { - object <- list(multi_model_full) - object <- mapply(set_object_name, object, c("development_1")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - - # One-feature data set ----------------------------------------------------- - - # Train the model. - model_one_1 <- suppressWarnings(test_train( - data = one_feature_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - model_one_2 <- model_one_1 - model_one_2@fs_method <- "mifs" - - # Create familiar data objects. - data_good_one_1 <- as_familiar_data( - object = model_one_1, - data = one_feature_data, - data_element = data_element, - cl = cl, - ...) - data_good_one_2 <- as_familiar_data( - object = model_one_2, - data = one_feature_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_one_1 <- as_familiar_data( - object = model_one_1, - data = one_feature_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_one_2 <- as_familiar_data( - object = model_one_2, - data = one_feature_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_identical_one_1 <- as_familiar_data( - object = model_one_1, - data = one_feature_invariant_data, - data_element = data_element, - cl = cl, - ...) - data_identical_one_2 <- as_familiar_data( - object = model_one_2, - data = one_feature_invariant_data, - data_element = data_element, - cl = cl, - ...) - - # Create a completely intact, one sample dataset. - test_fun( - paste0( - "8. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_feature, - "can", "cannot"), - " be created for a complete one-feature data set."), - { - object <- list(data_good_one_1, data_good_one_2, data_good_one_1, data_good_one_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available && !.not_available_single_feature) { - testthat::expect_equal(all(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) - - # Create a dataset with a one-sample quadrant. - test_fun( - paste0( - "9. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_feature, - "can", "cannot"), - " be created for a dataset with some one-sample data."), - { - object <- list(data_good_one_1, data_good_one_2, data_one_sample_one_1, data_one_sample_one_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available && !.not_available_single_feature) { - testthat::expect_equal(any(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) - - # Create a dataset with some identical data. - test_fun( - paste0( - "10. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_feature, - "can", "cannot"), - " be created for a dataset with some invariant data."), - { - object <- list(data_good_one_1, data_good_one_2, data_identical_one_1, data_identical_one_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - plot_list <- suppressWarnings(do.call( - plot_function, - args = c( - list("object" = collection), - plot_args))) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available && !.not_available_single_feature) { - testthat::expect_equal(any(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) + .warning_bad <- warning_bad + if (is.list(warning_bad)) { + .warning_bad <- warning_bad[[outcome_type]] + } - # Data set with limited censoring ------------------------------------------ - if (outcome_type %in% c("survival", "competing_risk")) { - # Train the model. - model_cens_1 <- suppressWarnings(test_train( - cl = cl, - data = no_censoring_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - model_cens_2 <- suppressWarnings(test_train( - cl = cl, - data = one_censored_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - model_cens_3 <- suppressWarnings(test_train( - cl = cl, - data = few_censored_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - data_cens_1 <- as_familiar_data( - object = model_cens_1, - data = no_censoring_data, - data_element = data_element, - cl = cl, - ...) - data_cens_2 <- as_familiar_data( - object = model_cens_2, - data = one_censored_data, - data_element = data_element, - cl = cl, - ...) - data_cens_3 <- as_familiar_data( - object = model_cens_3, - data = few_censored_data, - data_element = data_element, - cl = cl, - ...) - - # Create a dataset with some identical data. + if ("good" %in% test_situations) { test_fun( paste0( - "11. Plots for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a data set that includes no or limited censoring."), + "Experiment for a good dataset with ", outcome_type, + " outcome functions correctly." + ), { - object <- list(data_cens_1, data_cens_2, data_cens_3) - object <- mapply( - set_object_name, - object, - c("no_censoring", "one_censored", "few_censored")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("no_censoring", "one_censored", "few_censored"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) + # Create datasets + full_data <- test_create_good_data(outcome_type) + + if (learner_unset) { + # Set learner + learner <- "lasso" + + # Parse hyperparameter list + hyperparameters <- list( + "sign_size" = get_n_features(full_data), + "family" = switch( + outcome_type, + "continuous" = "gaussian", + "binomial" = "binomial", + "multinomial" = "multinomial", + "survival" = "cox" + ) + ) + + # Parse as list. + hyperparameters <- list("lasso" = hyperparameters) + } - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) + if (!is.null(.warning_good)) { + testthat::expect_warning( + output <- suppress_fun_messages(summon_familiar( + data = full_data, + learner = learner, + hyperparameter = hyperparameters, + time_max = 3.5, + verbose = debug, + ... + )), + .warning_good + ) + } else { - testthat::expect_equal(all(!which_present), TRUE) + output <- suppress_fun(summon_familiar( + data = full_data, + learner = learner, + hyperparameter = hyperparameters, + time_max = 3.5, + verbose = debug, + ... + )) } + + testthat::expect_equal(is.null(output), FALSE) } ) } - - # Without any valid predictions -------------------------------------------- - - # Train the model. - model_failed_predictions <- suppressWarnings(test_train( - cl = cl, - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso_test_all_fail", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - failed_prediction_data <- as_familiar_data( - object = model_failed_predictions, - data = full_data, - data_element = data_element, - cl = cl, - ...) - - test_fun( - paste0( - "12. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_all_predictions_fail, - "can", "cannot"), - " be created for models yielding only invalid predictions."), - { - collection <- suppressWarnings(as_familiar_collection( - failed_prediction_data, - familiar_data_names = c("failed_predictions"))) - - plot_list <- do.call( - plot_function, args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available && !.not_available_all_predictions_fail) { - testthat::expect_equal(all(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) - - # With some invalid predictions -------------------------------------------- - - # Train the model. - model_failing_predictions <- suppressWarnings(test_train( - cl = cl, - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso_test_some_fail", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - failing_prediction_data <- as_familiar_data( - object = model_failing_predictions, - data = full_data, - data_element = data_element, - cl = cl, - ...) - - test_fun( - paste0( - "13. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_some_predictions_fail, - "can", "cannot"), - " be created for models yielding some invalid predictions."), - { - collection <- suppressWarnings(as_familiar_collection( - failing_prediction_data, - familiar_data_names = c("failed_predictions"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available && !.not_available_some_predictions_fail) { - testthat::expect_equal(all(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) - - # With extreme probability values ------------------------------------------ - # Train the model. - if (outcome_type %in% c("binomial", "multinomial")) { - model_extreme_predictions <- suppressWarnings(test_train( - cl = cl, - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso_test_extreme", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - extreme_prediction_data <- as_familiar_data( - object = model_extreme_predictions, - data = full_data, - data_element = data_element, - cl = cl, - ...) - + if ("bad" %in% test_situations) { test_fun( paste0( - "14. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_extreme_probability, - "can", "cannot"), - " be created for models yielding extreme predictions."), + "Experiment for a bad dataset with ", outcome_type, + " outcome functions correctly." + ), { - collection <- suppressWarnings(as_familiar_collection( - extreme_prediction_data, - familiar_data_names = c("extreme_predictions"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) + # Create datasets. We explicitly insert NA data to circumvent an initial + # plausibility check. + bad_data <- test_create_bad_data( + outcome_type = outcome_type, + add_na_data = TRUE + ) - which_present <- .test_which_plot_present(plot_list) + if (learner_unset) { + # Set learner + learner <- "lasso" + + # Parse hyperparameter list + hyperparameters <- list( + "sign_size" = get_n_features(bad_data), + "family" = switch( + outcome_type, + "continuous" = "gaussian", + "binomial" = "binomial", + "multinomial" = "multinomial", + "survival" = "cox" + ) + ) + + # Parse as list. + hyperparameters <- list("lasso" = hyperparameters) + } - if (outcome_type %in% outcome_type_available && !.not_available_extreme_probability) { - testthat::expect_equal(all(which_present), TRUE) + if (!is.null(.warning_bad)) { + testthat::expect_warning( + output <- suppress_fun_messages(summon_familiar( + data = bad_data, + learner = learner, + hyperparameter = hyperparameters, + feature_max_fraction_missing = 0.95, + time_max = 3.5, + verbose = debug, + ... + )), + .warning_bad + ) } else { - testthat::expect_equal(any(!which_present), TRUE) + # Note that we set a very high feature_max_fraction_missing to deal + # with NA rows in the dataset. Also time is explicitly set to prevent + # an error. + output <- suppress_fun(summon_familiar( + data = bad_data, + learner = learner, + hyperparameter = hyperparameters, + feature_max_fraction_missing = 0.95, + time_max = 3.5, + verbose = debug, + ... + )) } + + testthat::expect_equal(is.null(output), FALSE) } ) } @@ -5396,1826 +5217,1187 @@ test_plots <- function( -test_plot_ordering <- function( - plot_function, - data_element, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - ..., - experiment_args = list(), - plot_args = list(), - create_novelty_detector = FALSE, - debug = FALSE, - parallel = waiver()) { - # Set debug options. - if (debug) { - test_fun <- debug_test_that - plot_args$draw <- TRUE - } else { - test_fun <- testthat::test_that +debug_test_that <- function(desc, code) { + # This is a drop-in replacement for testthat::test_that that makes it easier + # to debug errors. + + if (!is.character(desc) || length(desc) != 1L) { + stop("\"desc\" should be a character string") } + + # Execute the code + code <- substitute(code) + eval(code, envir = parent.frame()) +} - # Set parallelisation. - if (is.waive(parallel)) parallel <- !debug - - if (parallel) { - # Set options. - # Disable randomForestSRC OpenMP core use. - options(rf.cores = as.integer(1)) - on.exit(options(rf.cores = -1L), add = TRUE) - # Disable multithreading on data.table to prevent reduced performance due to - # resource collisions with familiar parallelisation. - data.table::setDTthreads(1L) - on.exit(data.table::setDTthreads(0L), add = TRUE) - # Start local cluster in the overall process. - cl <- .test_start_cluster(n_cores = 2L) - on.exit(.terminate_cluster(cl), add = TRUE) - } else { - cl <- NULL +test_not_deprecated <- function(x, deprecation_string = c("deprec", "replac")) { + # Test that no deprecation warnings are given. + if (length(x) > 0L) { + for (current_string in deprecation_string) { + testthat::expect_false(any(grepl( + x = x, pattern = current_string, fixed = TRUE + ))) + } } +} - if (is.null(experiment_args$imputation_method)) experiment_args$imputation_method <- "simple" - if (is.null(experiment_args$cluster_method)) experiment_args$cluster_method <- "none" - if (is.null(experiment_args$fs_method)) experiment_args$fs_method <- "mim" - if (is.null(experiment_args$time_max)) experiment_args$time_max <- 1832 - # Iterate over the outcome type. - for (outcome_type in outcome_type_available) { - - if (!test_data_package_installed(outcome_type)) next - - # Obtain data. - full_data <- test_create_good_data(outcome_type) - empty_data <- test_create_empty_data(outcome_type) - # Lasso model -------------------------------------------------------------- - # Parse hyperparameter list - hyperparameters_lasso <- list( - "sign_size" = get_n_features(full_data), - "family" = switch( - outcome_type, - "continuous" = "gaussian", - "count" = "poisson", - "binomial" = "binomial", - "multinomial" = "multinomial", - "survival" = "cox")) +.test_which_plot_present <- function(p) { + # Check if the top element is null or empty. + if (is.null(p)) return(FALSE) + if (length(p) == 0L) return(FALSE) + + # Check that the top element is a gtable or ggplot. + if (gtable::is.gtable(p) || ggplot2::is_ggplot(p)) { + return(TRUE) + } + + plot_present <- sapply(p, gtable::is.gtable) | sapply(p, ggplot2::is_ggplot) + if (any(plot_present)) { + return(plot_present) + } + + if (all(sapply(p, is.null))) { + return(!sapply(p, is.null)) + } + + # If the code gets here, p is a nested list. + p <- unlist(p, recursive = FALSE) + + if (is.null(p)) return(FALSE) + if (length(p) == 0L) return(FALSE) + + return(sapply(p, gtable::is.gtable) | sapply(p, ggplot2::is_ggplot)) +} - # Train the lasso model. - model_full_lasso_1 <- do.call_with_handlers( - test_train, - args = c( - list( - "data" = full_data, - "hyperparameter_list" = hyperparameters_lasso, - "learner" = "lasso", - "create_novelty_detector" = create_novelty_detector - ), - experiment_args - ) - ) - if (!test_object_package_installed(model_full_lasso_1)) next - model_full_lasso_1 <- model_full_lasso_1$value - - model_full_lasso_2 <- model_full_lasso_1 - model_full_lasso_2@fs_method <- "mifs" - # GLM model ---------------------------------------------------------------- - # Parse hyperparameter list - hyperparameters_glm <- list( - "sign_size" = get_n_features(full_data), - "family" = switch( - outcome_type, - "continuous" = "gaussian", - "count" = "poisson", - "binomial" = "logistic", - "multinomial" = "multinomial", - "survival" = "cox")) - # Train the lasso model. - model_full_glm_1 <- suppressWarnings(do.call( - test_train, - args = c( - list( - "data" = full_data, - "hyperparameter_list" = hyperparameters_glm, - "learner" = "glm", - "create_novelty_detector" = create_novelty_detector), - experiment_args))) - - model_full_glm_2 <- model_full_glm_1 - model_full_glm_2@fs_method <- "mifs" +.test_which_data_element_present <- function(x, outcome_type) { + # Check if the top element is null or empty. + if (is_empty(x)) return(FALSE) + + data_element_present <- !sapply(x, is_empty) + if (!any(data_element_present)) return(FALSE) + + return(data_element_present) +} - # Create plot -------------------------------------------------------------- - # Create familiar data objects. - data_good_full_lasso_1 <- as_familiar_data( - object = model_full_lasso_1, - data = full_data, - data_element = data_element, - cl = cl, - ...) - data_good_full_lasso_2 <- as_familiar_data( - object = model_full_lasso_2, - data = full_data, - data_element = data_element, - cl = cl, - ...) - data_good_full_glm_1 <- as_familiar_data( - object = model_full_glm_1, - data = full_data, - data_element = data_element, - cl = cl, - ...) - data_good_full_glm_2 <- as_familiar_data( - object = model_full_glm_2, - data = full_data, - data_element = data_element, - cl = cl, - ...) - data_empty_glm_1 <- as_familiar_data( - object = model_full_glm_1, - data = empty_data, - data_element = data_element, - cl = cl, - ...) - data_empty_lasso_2 <- as_familiar_data( - object = model_full_lasso_2, - data = empty_data, - data_element = data_element, - cl = cl, - ...) - - # Create a test dataset with multiple components - test_fun( - paste0("Plots for ", outcome_type, " outcomes can be created."), - { - object <- list( - data_good_full_lasso_1, data_empty_lasso_2, data_good_full_lasso_1, data_good_full_lasso_2, - data_good_full_glm_1, data_good_full_glm_2, data_empty_glm_1, data_good_full_glm_2) - - object <- mapply( - set_object_name, - object, - c( - "development_lasso_1", "development_lasso_2", "validation_lasso_1", "validation_lasso_2", - "development_glm_1", "development_glm_2", "validation_glm_1", "validation_glm_2")) - - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c( - "development", "development", "validation", "validation", - "development", "development", "validation", "validation"))) - - plot_list <- do.call( - plot_function, - args = c( - list("object" = collection), - plot_args)) - - which_present <- .test_which_plot_present(plot_list) - - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - } + +.test_start_cluster <- function(n_cores = NULL) { + # Determine the number of available cores. + n_cores_available <- parallel::detectCores() - 1L + + # Determine the number of available cores. + if (is.null(n_cores)) n_cores <- n_cores_available + if (n_cores > n_cores_available) n_cores <- n_cores_available + if (n_cores < 2L) return(NULL) + + assign("is_external_cluster", FALSE, envir = familiar_global_env) + + # Start a new cluster + cl <- .start_cluster( + n_cores = n_cores, + cluster_type = "psock" + ) + + # If the cluster doesn't start, return a NULL + if (is.null(cl)) return(NULL) + + # Set library paths to avoid issues with non-standard library locations. + libs <- .libPaths() + parallel::clusterExport(cl = cl, varlist = "libs", envir = environment()) + parallel::clusterEvalQ(cl = cl, .libPaths(libs)) + + # Load familiar and data.table libraries to each cluster node. + parallel::clusterEvalQ(cl = cl, library(familiar)) + parallel::clusterEvalQ(cl = cl, library(data.table)) + + # Set options on each cluster node. + parallel::clusterEvalQ(cl = cl, options(rf.cores = 1L)) + parallel::clusterEvalQ(cl = cl, data.table::setDTthreads(1L)) + + return(cl) } -test_export <- function( - export_function, +.is_testing <- function() { + return(identical(Sys.getenv("TESTTHAT"), "true")) +} + + +get_test_collection_generation <- function(...) { + # This is a thin wrapper around .generate_test_collection and returns the + # generator. This is aimed at preventing issues when installing familiar even + # though coro is not available. + + .generate_test_collection <- coro::generator(function( data_element, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), not_available_no_samples = TRUE, not_available_single_feature = FALSE, not_available_all_predictions_fail = TRUE, not_available_some_predictions_fail = TRUE, - not_available_any_prospective = FALSE, + not_available_all_prospective = FALSE, + not_available_mostly_prospective = FALSE, not_available_single_sample = FALSE, not_available_extreme_probability = FALSE, + use_prediction_table = FALSE, ..., - export_args = list(), + cl = NULL, test_specific_config = FALSE, + test_config = NULL, + debug_config = NULL, + debug_outcome_type = NULL, n_models = 1L, - create_novelty_detector = FALSE, - debug = FALSE, - parallel = waiver()) { - if (debug) { - test_fun <- debug_test_that - } else { - test_fun <- testthat::test_that - } - - # Set parallelisation. - if (is.waive(parallel)) parallel <- !debug - - if (parallel) { - # Set options. - # Disable randomForestSRC OpenMP core use. - options(rf.cores = as.integer(1)) - on.exit(options(rf.cores = -1L), add = TRUE) - - # Disable multithreading on data.table to prevent reduced performance due to - # resource collisions with familiar parallelisation. - data.table::setDTthreads(1L) - on.exit(data.table::setDTthreads(0L), add = TRUE) - - # Start local cluster in the overall process. - cl <- .test_start_cluster(n_cores = 2L) - on.exit(.terminate_cluster(cl), add = TRUE) - } else { - cl <- NULL - } - - # Iterate over the outcome type. - for (outcome_type in c("count", "continuous", "binomial", "multinomial", "survival")) { + create_novelty_detector = FALSE + ) { - if (!test_data_package_installed(outcome_type)) next - - # Obtain data. - full_data <- test_create_good_data(outcome_type) - identical_sample_data <- test_create_all_identical_data(outcome_type) - full_one_sample_data <- test_create_one_sample_data(outcome_type) - bootstrapped_data <- test_create_bootstrapped_data(outcome_type) - one_feature_data <- test_create_single_feature_data(outcome_type) - one_feature_one_sample_data <- test_create_single_feature_one_sample_data(outcome_type) - one_feature_invariant_data <- test_create_single_feature_invariant_data(outcome_type) - empty_data <- test_create_empty_data(outcome_type) - multi_data <- test_create_multiple_synthetic_series(outcome_type = outcome_type) - - # Data with different degrees of censoring. - no_censoring_data <- test_create_good_data_without_censoring(outcome_type) - one_censored_data <- test_create_good_data_one_censored(outcome_type) - few_censored_data <- test_create_good_data_few_censored(outcome_type) - - # Prospective datasets with (partially) missing outcomes - fully_prospective_data <- test_create_prospective_data(outcome_type) - mostly_prospective_data <- test_create_mostly_prospective_data(outcome_type) - partially_prospective_data <- test_create_partially_prospective_data(outcome_type) - - # Set exceptions per outcome type. - .not_available_no_samples <- not_available_no_samples - if (is.character(.not_available_no_samples)) { - .not_available_no_samples <- any(.not_available_no_samples == outcome_type) - } - - .not_available_single_feature <- not_available_single_feature - if (is.character(.not_available_single_feature)) { - .not_available_single_feature <- any(.not_available_single_feature == outcome_type) - } - - .not_available_any_prospective <- not_available_any_prospective - if (is.character(.not_available_any_prospective)) { - .not_available_any_prospective <- any(.not_available_any_prospective == outcome_type) - } - - .not_available_all_predictions_fail <- not_available_all_predictions_fail - if (is.character(.not_available_all_predictions_fail)) { - .not_available_all_predictions_fail <- any(.not_available_all_predictions_fail == outcome_type) - } - - .not_available_some_predictions_fail <- not_available_some_predictions_fail - if (is.character(.not_available_some_predictions_fail)) { - .not_available_some_predictions_fail <- any(.not_available_some_predictions_fail == outcome_type) - } - - .not_available_single_sample <- not_available_single_sample - if (is.character(.not_available_single_sample)) { - .not_available_single_sample <- any(.not_available_single_sample == outcome_type) + ..as_familiar_data_object <- function( + object, + data, + data_element, + cl, + use_prediction_table, + ... + ) { + if (use_prediction_table) { + # Generate data from prediction tables. + familiar_data_object <- as_familiar_data( + object = .predict(object = object, data = data, ...), + data_element = data_element, + cl = cl, + ... + ) + + } else { + # Generate data from models and ensembles. + familiar_data_object <- as_familiar_data( + object = object, + data = data, + data_element = data_element, + cl = cl, + ... + ) + } + + return(familiar_data_object) } - - .not_available_extreme_probability <- not_available_extreme_probability - if (is.character(.not_available_extreme_probability)) { - .not_available_extreme_probability <- any(.not_available_extreme_probability == outcome_type) + + ..duplicate_familiar_data_object <- function(x) { + x <- set_object_name(x) + x@vimp_method <- "mifs" + return(x) } - - # Parse hyperparameter list - hyperparameters <- list( - "sign_size" = get_n_features(full_data), - "family" = switch( - outcome_type, - "continuous" = "gaussian", - "count" = "poisson", - "binomial" = "binomial", - "multinomial" = "multinomial", - "survival" = "cox")) - - # Full data set ------------------------------------------------------------ - - if (n_models == 1) { - # Train the model. - model_full_1 <- do.call_with_handlers( - test_train, - args = list( + + # Prevent CRAN notes due to lazy binding + good_data_1 <- good_data_2 <- empty_data_1 <- NULL + good_one_feature_data_1 <- good_one_feature_data_2 <- NULL + + # Allow for debugging specific outcome types + all_outcome_types <- c("continuous", "binomial", "multinomial", "survival") + if (!is.null(debug_outcome_type)) all_outcome_types <- debug_outcome_type + + # Within this function, test_config and debug_config are the same. + if (!is.null(test_config)) debug_config <- test_config + + # TODO: Fully deprecate this. + if (test_specific_config) ..error_reached_unreachable_code("test_specific_config is deprecated; replace by test_config = \"normal\"") + + # Iterate over the outcome type. + for (outcome_type in all_outcome_types) { + + # Set up full dataset. + full_data <- test_create_good_data(outcome_type) + + # Set exceptions per outcome type. + .not_available_no_samples <- not_available_no_samples + if (is.character(.not_available_no_samples)) { + .not_available_no_samples <- any(.not_available_no_samples == outcome_type) + } + + .not_available_single_feature <- not_available_single_feature + if (is.character(.not_available_single_feature)) { + .not_available_single_feature <- any(.not_available_single_feature == outcome_type) + } + + .not_available_mostly_prospective <- not_available_mostly_prospective + if (is.character(.not_available_mostly_prospective)) { + .not_available_mostly_prospective <- any(.not_available_mostly_prospective == outcome_type) + } + + .not_available_all_prospective <- not_available_all_prospective + if (is.character(.not_available_all_prospective)) { + .not_available_all_prospective <- any(.not_available_all_prospective == outcome_type) + } + + .not_available_all_predictions_fail <- not_available_all_predictions_fail + if (is.character(.not_available_all_predictions_fail)) { + .not_available_all_predictions_fail <- any(.not_available_all_predictions_fail == outcome_type) + } + + .not_available_some_predictions_fail <- not_available_some_predictions_fail + if (is.character(.not_available_some_predictions_fail)) { + .not_available_some_predictions_fail <- any(.not_available_some_predictions_fail == outcome_type) + } + + .not_available_single_sample <- not_available_single_sample + if (is.character(.not_available_single_sample)) { + .not_available_single_sample <- any(.not_available_single_sample == outcome_type) + } + + .not_available_extreme_probability <- not_available_extreme_probability + if (is.character(.not_available_extreme_probability)) { + .not_available_extreme_probability <- any(.not_available_extreme_probability == outcome_type) + } + + # Parse hyperparameter. + hyperparameters <- list( + "sign_size" = get_n_features(full_data), + "family" = switch( + outcome_type, + "continuous" = "gaussian", + "binomial" = "binomial", + "multinomial" = "multinomial", + "survival" = "cox" + ) + ) + + + # Full data -------------------------------------------------------------- + + if (n_models == 1L) { + # Train the model. + model_full <- suppressWarnings(test_train( cl = cl, data = full_data, cluster_method = "none", imputation_method = "simple", hyperparameter_list = hyperparameters, learner = "lasso", - time_max = 1832, + time_max = 3.5, create_novelty_detector = create_novelty_detector - ) - ) - if (!test_object_package_installed(model_full_1)) next - model_full_1 <- model_full_1$value - - model_full_2 <- model_full_1 - model_full_2@fs_method <- "mifs" - - } else { - # Train a set of models. - model_full_1 <- list() - model_full_2 <- list() - - for (ii in seq_len(n_models)) { - temp_model_1 <- do.call_with_handlers( - test_train, - args = list( + )) + + } else { + # Train a set of models. + model_full <- list() + + for (ii in seq_len(n_models)) { + temp_model <- suppressWarnings(test_train( cl = cl, - data = full_data, + data = test_create_bootstrapped_data( + outcome_type = outcome_type, + seed = ii + ), cluster_method = "none", imputation_method = "simple", - fs_method = "mim", + vimp_method = "mim", hyperparameter_list = hyperparameters, learner = "lasso", - time_max = 1832, + time_max = 3.5, create_bootstrap = TRUE, create_novelty_detector = create_novelty_detector - ) + )) + + model_full[[ii]] <- temp_model + } + } + + good_data_1 %<~% ..as_familiar_data_object( + object = model_full, + data = full_data, + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + + good_data_2 %<~% ..duplicate_familiar_data_object(good_data_1) + + if (is.null(debug_config) || "normal" %in% debug_config) { + familiar_data_list <- mapply( + set_object_name, + list(good_data_1, good_data_2, good_data_1, good_data_2), + c("development_1", "development_2", "validation_1", "validation_2") ) - if (!test_object_package_installed(temp_model_1)) next - temp_model_1 <- temp_model_1$value - temp_model_2 <- temp_model_1 - temp_model_2@fs_method <- "mifs" - - model_full_1[[ii]] <- temp_model_1 - model_full_2[[ii]] <- temp_model_2 - } - } - - # Create familiar data objects. - data_good_full_1 <- as_familiar_data( - object = model_full_1, - data = full_data, - data_element = data_element, - cl = cl, - ...) - data_good_full_2 <- as_familiar_data( - object = model_full_2, - data = full_data, - data_element = data_element, - cl = cl, - ...) - - # Create a completely intact dataset. - test_fun( - paste0( - "1. Export data for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a complete data set."), - { - object <- list(data_good_full_1, data_good_full_2, data_good_full_1, data_good_full_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) + test_message <- paste0( + "(normal) Data for ", outcome_type, " outcomes ", + ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), + " be created for a complete data set." + ) - data_elements <- do.call( - export_function, - args = c( - list( - "object" = collection, - "export_collection" = TRUE), - export_args)) + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available) test_expectation <- "all_present" - # Extract collection. - exported_collection <- data_elements$collection - data_elements$collection <- NULL + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + } + + # Fully prospective data ------------------------------------------------- + + if (is.null(debug_config) || "prospective" %in% debug_config) { + fully_prospective_data <- ..as_familiar_data_object( + object = model_full, + data = test_create_prospective_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - # Determine which elements are present. - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_data_list <- mapply(set_object_name, list(fully_prospective_data), c("prospective")) - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - testthat::expect_s4_class(exported_collection, "familiarCollection") - } else { - testthat::expect_equal(all(!which_present), TRUE) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("prospective") + )) + + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available && !.not_available_all_prospective) { + test_expectation <- "all_present" } + + test_message <- paste0( + "(prospective) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a prospective data set without known outcome." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("fully_prospective_data") } - ) - - # Go to next outcome type if only a specific configuration needs to be - # tested. - if (test_specific_config) next - - data_prospective_full_1 <- as_familiar_data( - object = model_full_1, - data = fully_prospective_data, - data_element = data_element, - cl = cl, - ...) - - # Test prospective data set. - test_fun( - paste0( - "2A. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_any_prospective, - "can", "cannot"), - " be created for a prospective data set without known outcome."), - { - object <- list(data_prospective_full_1) - object <- mapply(set_object_name, object, c("prospective")) + + # Mostly prospective data ------------------------------------------------ + + if (is.null(debug_config) || "mostly prospective" %in% debug_config) { + mostly_prospective_data <- ..as_familiar_data_object( + object = model_full, + data = test_create_mostly_prospective_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("prospective"))) + familiar_data_list <- mapply(set_object_name, list(mostly_prospective_data), c("prospective")) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("prospective") + )) - if (outcome_type %in% outcome_type_available && !.not_available_any_prospective) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) + test_expectation <- "all_absent" + if ( + outcome_type %in% outcome_type_available && + (!.not_available_mostly_prospective || !.not_available_single_sample) + ) { + test_expectation <- "all_present" } + + test_message <- paste0( + "(mostly prospective) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a prospective data set with one instance with known outcome." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("mostly_prospective_data") } - ) - - # Create familiar data objects with mostly unknown outcome data. - data_prospective_most_1 <- as_familiar_data( - object = model_full_1, - data = mostly_prospective_data, - data_element = data_element, - cl = cl, - ...) - - # Create plots. - test_fun( - paste0( - "2B. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && - (!.not_available_any_prospective || !.not_available_single_sample), - "can", "cannot"), - " be created for a prospective data set with one instance with known outcome."), - { - object <- list(data_prospective_most_1) - object <- mapply(set_object_name, object, c("prospective")) + + # Mostly retrospective data ---------------------------------------------- + + if (is.null(debug_config) || "few prospective" %in% debug_config) { - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("prospective"))) + mostly_retrospective_data <- ..as_familiar_data_object( + object = model_full, + data = test_create_partially_prospective_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + familiar_data_list <- mapply(set_object_name, list(mostly_retrospective_data), c("prospective")) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("prospective") + )) - if (outcome_type %in% outcome_type_available && - (!.not_available_any_prospective || !.not_available_single_sample)) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available) test_expectation <- "all_present" + + test_message <- paste0( + "(few prospective) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a prospective data set where most instances are known." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("mostly_retrospective_data") } - ) - - # Create familiar data objects where most outcomes are known. - data_prospective_partial_1 <- as_familiar_data( - object = model_full_1, - data = partially_prospective_data, - data_element = data_element, - cl = cl, - ...) - - # Create a completely intact dataset. - test_fun( - paste0( - "2C. Export data for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a prospective data set where most instances are known."), - { - object <- list(data_prospective_partial_1) - object <- mapply(set_object_name, object, c("prospective")) + + # Single-instance data --------------------------------------------------- + + if (is.null(debug_config) || "single instance" %in% debug_config) { - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("prospective"))) + single_instance_data <- ..as_familiar_data_object( + object = model_full, + data = test_create_one_sample_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + familiar_data_list <- mapply(set_object_name, list(single_instance_data), c("one_sample")) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("one_sample") + )) - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(all(!which_present), TRUE) + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available && !.not_available_single_sample) { + test_expectation <- "all_present" } + + test_message <- paste0( + "(single instance) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a prospective data set with one instance." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("single_instance_data") } - ) - - # Create data object with one sample. - data_one_sample_full_1 <- as_familiar_data( - object = model_full_1, - data = full_one_sample_data, - data_element = data_element, - cl = cl, - ...) - - test_fun( - paste0( - "2D. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_sample, - "can", "cannot"), - " be created for a prospective data set with one instance."), - { - object <- list(data_one_sample_full_1) - object <- mapply(set_object_name, object, c("one_sample")) + + # Bootstrapped data ------------------------------------------------------ + if (is.null(debug_config) || "bootstrap" %in% debug_config) { - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("one_sample"))) + bootstrapped_data <- ..as_familiar_data_object( + object = model_full, + data = test_create_bootstrapped_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + familiar_data_list <- mapply(set_object_name, list(bootstrapped_data), c("bootstrapped")) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("bootstrapped") + )) - if (outcome_type %in% outcome_type_available && !.not_available_single_sample) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available) test_expectation <- "all_present" + + test_message <- paste0( + "(bootstrap) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a prospective, bootstrapped, data set." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("bootstrapped_data") } - ) - - # Create data object with bootstrapped data. - data_bootstrapped_full_1 <- as_familiar_data( - object = model_full_1, - data = bootstrapped_data, - data_element = data_element, - cl = cl, - ...) - - test_fun( - paste0( - "2E. Plots for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_sample, - "can", "cannot"), - " be created for a prospective, bootstrapped, data set."), - { - object <- list(data_bootstrapped_full_1) - object <- mapply(set_object_name, object, c("bootstrapped")) + + # Partially absent data -------------------------------------------------- + + empty_data_1 %<~% ..as_familiar_data_object( + object = model_full, + data = test_create_empty_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + + # Train a naive model. + naive_model <- suppressWarnings(train_familiar( + data = full_data, + experimental_design = "fs+mb", + cluster_method = "hclust", + imputation_method = "simple", + vimp_method = "no_features", + learner = "lasso", + hyperparameter = hyperparameters, + cluster_similarity_threshold = 0.7, + time_max = 3.5, + parallel = FALSE, + verbose = FALSE + )) + + # Replace vimp_method attribute + naive_model@vimp_method <- "mifs" + + if (is.null(debug_config) || "single empty dataset" %in% debug_config) { + naive_data <- ..as_familiar_data_object( + object = naive_model, + data = test_create_good_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("bootstrapped"))) + familiar_data_list <- mapply( + set_object_name, + list(good_data_1, naive_data, empty_data_1, good_data_2), + c("development_1", "development_2", "validation_1", "validation_2") + ) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available) test_expectation <- "all_present" - if (outcome_type %in% outcome_type_available && !.not_available_single_sample) { - testthat::expect_equal(all(which_present), TRUE) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } + test_message <- paste0( + "(single empty dataset) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a dataset with some missing data." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("naive_data") } - ) - - # Ensemble from multiple datasets. - multi_model_set <- suppressWarnings(lapply( - multi_data, - test_train, - cluster_method = "hclust", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - cluster_similarity_threshold = 0.7, - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - # Train a naive model. - naive_model <- suppressWarnings(train_familiar( - data = multi_data[[1]], - experimental_design = "fs+mb", - cluster_method = "hclust", - imputation_method = "simple", - fs_method = "no_features", - learner = "lasso", - hyperparameter = hyperparameters, - cluster_similarity_threshold = 0.7, - time_max = 60, - parallel = FALSE, - verbose = FALSE)) - - # Replace fs_method attribute - naive_model@fs_method <- "none" - - # Add naive model to the multi-model dataset. - multi_model_set <- c(multi_model_set, list("naive" = naive_model)) - - # Create data from ensemble of multiple models - multi_model_full <- as_familiar_data( - object = multi_model_set, - data = multi_data[[1]], - data_element = data_element, - cl = cl, - ...) - - # Replace fs_method attribute - naive_model@fs_method <- "mifs" - - # Create additional familiar data objects. - data_naive_full <- as_familiar_data( - object = naive_model, - data = full_data, - data_element = data_element, - cl = cl, - ... - ) - data_empty_full_1 <- as_familiar_data( - object = model_full_1, - data = empty_data, - data_element = data_element, - cl = cl, - ...) - data_empty_full_2 <- as_familiar_data( - object = model_full_2, - data = empty_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_full_1 <- as_familiar_data( - object = model_full_1, - data = full_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_full_2 <- as_familiar_data( - object = model_full_2, - data = full_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_identical_full_1 <- as_familiar_data( - object = model_full_1, - data = identical_sample_data, - data_element = data_element, - cl = cl, - ...) - data_identical_full_2 <- as_familiar_data( - object = model_full_2, - data = identical_sample_data, - data_element = data_element, - cl = cl, - ...) - - # Create a dataset with a missing quadrant. - test_fun( - paste0( - "3. Export data for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset with some missing data."), - { - object <- list(data_good_full_1, data_naive_full, data_empty_full_1, data_good_full_2) - object <- mapply( + + # Fully absent data ------------------------------------------------------ + + if (is.null(debug_config) || "all empty datasets" %in% debug_config) { + empty_data_2 <- ..duplicate_familiar_data_object(empty_data_1) + + familiar_data_list <- mapply( set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) + list(empty_data_1, empty_data_2, empty_data_1, empty_data_2), + c("development_1", "development_2", "validation_1", "validation_2") + ) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available && !.not_available_no_samples) test_expectation <- "all_present" - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + test_message <- paste0( + "(all empty datasets) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a dataset with completely missing data." + ) - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(any(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("empty_data_2") } - ) - - # Create a dataset with all missing quadrants - test_fun( - paste0( - "4. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_no_samples, - "can", "cannot"), - " be created for a dataset with completely missing data."), - { - object <- list(data_empty_full_1, data_empty_full_2, data_empty_full_1, data_empty_full_2) - object <- mapply( + rm("empty_data_1") + + # Partially single-instance data ----------------------------------------- + + if (is.null(debug_config) || "some single instance datasets" %in% debug_config) { + + one_sample_data_1 <- ..as_familiar_data_object( + object = model_full, + data = test_create_one_sample_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + + one_sample_data_2 <- ..duplicate_familiar_data_object(one_sample_data_1) + + familiar_data_list <- mapply( set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) + list(good_data_1, good_data_2, one_sample_data_1, one_sample_data_2), + c("development_1", "development_2", "validation_1", "validation_2") + ) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available) test_expectation <- "all_present" - if (outcome_type %in% outcome_type_available && !.not_available_no_samples) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } + test_message <- paste0( + "(some single instance datasets) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a dataset where some data only have one sample." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("one_sample_data_1", "one_sample_data_2") } - ) - - # Create dataset with one-sample quadrants for validation - test_fun( - paste0( - "5. Export data for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset where some data only have one sample."), - { - object <- list(data_good_full_1, data_good_full_2, data_one_sample_full_1, data_one_sample_full_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) + + # Partially identical data ----------------------------------------------- + + if (is.null(debug_config) || "identical instance datasets" %in% debug_config) { - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) + identical_sample_data_1 <- ..as_familiar_data_object( + object = model_full, + data = test_create_all_identical_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + identical_sample_data_2 <- ..duplicate_familiar_data_object(identical_sample_data_1) - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(any(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } - } - ) - - # Create dataset with some quadrants with identical data - test_fun( - paste0( - "6. Export data for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset where some data only have identical samples."), - { - object <- list(data_good_full_1, data_good_full_2, data_identical_full_1, data_identical_full_2) - object <- mapply( + familiar_data_list <- mapply( set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) + list(good_data_1, good_data_2, identical_sample_data_1, identical_sample_data_2), + c("development_1", "development_2", "validation_1", "validation_2") + ) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available) test_expectation <- "all_present" - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + test_message <- paste0( + "(identical instance datasets) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a dataset where some data only have identical samples." + ) - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("identical_sample_data_1", "identical_sample_data_2") } - ) - - test_fun( - paste0( - "7. Export data for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a dataset created from an ensemble of multiple models."), - { - object <- list(multi_model_full) - object <- mapply(set_object_name, object, c("development_1")) + + # Multi-model ensemble --------------------------------------------------- + + if (is.null(debug_config) || "multiple models" %in% debug_config) { + + multi_model_data <- list( + test_create_good_data(outcome_type), + test_create_bootstrapped_data(outcome_type, seed = 1844L), + test_create_bootstrapped_data(outcome_type, seed = 1863L) + ) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development"))) + multi_model_set <- suppressWarnings(lapply( + multi_model_data, + test_train, + cluster_method = "hclust", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = "lasso", + cluster_similarity_threshold = 0.7, + time_max = 3.5, + create_novelty_detector = create_novelty_detector + )) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + # Replace vimp_method attribute and add naive_model to the multi-model + # ensemble. + naive_model@vimp_method <- "none" + multi_model_set <- c(multi_model_set, list(naive_model)) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + multi_model_data <- ..as_familiar_data_object( + object = multi_model_set, + data = full_data, + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(all(!which_present), TRUE) - } + familiar_data_list <- mapply(set_object_name, list(multi_model_data), c("development_1")) + + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development") + )) + + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available) test_expectation <- "all_present" + + test_message <- paste0( + "(multiple models) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a dataset created from an ensemble of multiple models." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("multi_model_data", "multi_model_set", "naive_model") } - ) - - # One-feature data set ----------------------------------------------------- - - # Train the model. - model_one_1 <- suppressWarnings(test_train( - cl = cl, - data = one_feature_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - model_one_2 <- model_one_1 - model_one_2@fs_method <- "mifs" - - # Create familiar data objects. - data_good_one_1 <- as_familiar_data( - object = model_one_1, - data = one_feature_data, - data_element = data_element, - cl = cl, - ...) - data_good_one_2 <- as_familiar_data( - object = model_one_2, - data = one_feature_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_one_1 <- as_familiar_data( - object = model_one_1, - data = one_feature_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_one_sample_one_2 <- as_familiar_data( - object = model_one_2, - data = one_feature_one_sample_data, - data_element = data_element, - cl = cl, - ...) - data_identical_one_1 <- as_familiar_data( - object = model_one_1, - data = one_feature_invariant_data, - data_element = data_element, - cl = cl, - ...) - data_identical_one_2 <- as_familiar_data( - object = model_one_2, - data = one_feature_invariant_data, - data_element = data_element, - cl = cl, - ...) - - # Create a completely intact, one sample dataset. - test_fun( - paste0( - "8. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_feature, - "can", "cannot"), - " be created for a complete one-feature data set."), - { - object <- list(data_good_one_1, data_good_one_2, data_good_one_1, data_good_one_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) + rm("good_data_1", "good_data_2", "model_full") + + # One-feature data ------------------------------------------------------- + + # Train the model. + one_feature_model <- suppressWarnings(test_train( + cl = cl, + data = test_create_single_feature_data(outcome_type), + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = "lasso", + time_max = 3.5, + create_novelty_detector = create_novelty_detector + )) + + good_one_feature_data_1 %<~% ..as_familiar_data_object( + object = one_feature_model, + data = test_create_single_feature_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + good_one_feature_data_2 %<~% ..duplicate_familiar_data_object(good_one_feature_data_1) + + if (is.null(debug_config) || "single feature" %in% debug_config) { - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) + familiar_data_list <- mapply( + set_object_name, + list(good_one_feature_data_1, good_one_feature_data_2, good_one_feature_data_1, good_one_feature_data_2), + c("development_1", "development_2", "validation_1", "validation_2") + ) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available && !.not_available_single_feature) { + test_expectation <- "all_present" + } + + test_message <- paste0( + "(single feature) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a complete one-feature data set." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + } + + # Partially single-instance one-feature data ----------------------------- + + if (is.null(debug_config) || "single feature and sample" %in% debug_config) { + + good_one_sample_one_feature_data_1 <- ..as_familiar_data_object( + object = one_feature_model, + data = test_create_single_feature_one_sample_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + good_one_sample_one_feature_data_2 <- ..duplicate_familiar_data_object( + good_one_sample_one_feature_data_1 + ) + + familiar_data_list <- mapply( + set_object_name, + list( + good_one_feature_data_1, good_one_feature_data_2, + good_one_sample_one_feature_data_1, good_one_sample_one_feature_data_2 + ), + c("development_1", "development_2", "validation_1", "validation_2") + ) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) + + test_expectation <- "all_absent" if (outcome_type %in% outcome_type_available && !.not_available_single_feature) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) + test_expectation <- "all_present" } + + test_message <- paste0( + "(single feature and sample) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a one-feature dataset with some one-sample data." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("good_one_sample_one_feature_data_1", "good_one_sample_one_feature_data_2") } - ) - - # Create a dataset with a one-sample quadrant. - test_fun( - paste0( - "9. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_feature, - "can", "cannot"), - " be created for a dataset with some one-sample data."), - { - object <- list(data_good_one_1, data_good_one_2, data_one_sample_one_1, data_one_sample_one_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) + + # Partially identical one-feature data ----------------------------------- + + if (is.null(debug_config) || "single feature identical instance dataset" %in% debug_config) { - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) + good_identical_one_feature_data_1 <- ..as_familiar_data_object( + object = one_feature_model, + data = test_create_single_feature_invariant_data(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + good_identical_one_feature_data_2 <- ..duplicate_familiar_data_object(good_identical_one_feature_data_1) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + familiar_data_list <- mapply( + set_object_name, + list( + good_one_feature_data_1, good_one_feature_data_2, + good_identical_one_feature_data_1, good_identical_one_feature_data_2 + ), + c("development_1", "development_2", "validation_1", "validation_2") + ) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("development", "development", "validation", "validation") + )) + test_expectation <- "all_absent" if (outcome_type %in% outcome_type_available && !.not_available_single_feature) { - testthat::expect_equal(any(which_present), TRUE) - - if (debug) show(data_elements) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) + test_expectation <- "all_present" } - } - ) - - # Create a dataset with some identical data. - test_fun(paste0( - "10. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_single_feature, - "can", "cannot"), - " be created for a dataset with some invariant data."), - { - object <- list(data_good_one_1, data_good_one_2, data_identical_one_1, data_identical_one_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + test_message <- paste0( + "(single feature identical instance dataset) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a one-feature dataset with some invariant data." + ) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) - if (outcome_type %in% outcome_type_available && !.not_available_single_feature) { - testthat::expect_equal(any(which_present), TRUE) - - if (debug) show(data_elements) + rm("good_identical_one_feature_data_1", "good_identical_one_feature_data_2") + } + rm("good_one_feature_data_1", "good_one_feature_data_2", "one_feature_model") + + # Data with limited censoring -------------------------------------------- + if (is.null(debug_config) || "limited censoring" %in% debug_config) { + if (outcome_type %in% c("survival", "competing_risk")) { + # Train the model. + model_cens_1 <- suppressWarnings(test_train( + cl = cl, + data = test_create_good_data_without_censoring(outcome_type), + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = "lasso", + time_max = 3.5 + )) - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) + model_cens_2 <- suppressWarnings(test_train( + cl = cl, + data = test_create_good_data_one_censored(outcome_type), + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = "lasso", + time_max = 3.5 + )) - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) - - # Data set with limited censoring ------------------------------------------ - if (outcome_type %in% c("survival", "competing_risk")) { - # Train the model. - model_cens_1 <- suppressWarnings(test_train( - cl = cl, - data = no_censoring_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832)) - - model_cens_2 <- suppressWarnings(test_train( - cl = cl, - data = one_censored_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832)) - - model_cens_3 <- suppressWarnings(test_train( - cl = cl, - data = few_censored_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832)) - - data_cens_1 <- as_familiar_data( - object = model_cens_1, - data = no_censoring_data, - data_element = data_element, - cl = cl, - ...) - data_cens_2 <- as_familiar_data( - object = model_cens_2, - data = one_censored_data, - data_element = data_element, - cl = cl, - ...) - data_cens_3 <- as_familiar_data( - object = model_cens_3, - data = few_censored_data, - data_element = data_element, - cl = cl, - ...) - - # Create a dataset with some identical data. - test_fun( - paste0( - "11. Exports for ", outcome_type, " outcomes ", - ifelse(outcome_type %in% outcome_type_available, "can", "cannot"), - " be created for a data set that includes no or limited censoring."), - { - object <- list(data_cens_1, data_cens_2, data_cens_3) - object <- mapply( - set_object_name, - object, - c("no_censoring", "one_censored", "few_censored")) + model_cens_3 <- suppressWarnings(test_train( + cl = cl, + data = test_create_good_data_few_censored(outcome_type), + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = "lasso", + time_max = 3.5 + )) - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("no_censoring", "one_censored", "few_censored"))) + data_cens_1 <- as_familiar_data( + object = model_cens_1, + data = test_create_good_data_without_censoring(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + data_cens_2 <- as_familiar_data( + object = model_cens_2, + data = test_create_good_data_one_censored(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) + data_cens_3 <- as_familiar_data( + object = model_cens_3, + data = test_create_good_data_few_censored(outcome_type), + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + familiar_data_list <- mapply( + set_object_name, + list(data_cens_1, data_cens_2, data_cens_3), + c("no_censoring", "one_censored", "few_censored") + ) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("no_censoring", "one_censored", "few_censored") + )) + test_expectation <- "all_absent" if (outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(all(!which_present), TRUE) + test_expectation <- "all_present" } - } - ) - } - - # Train the model. - model_failed_predictions <- suppressWarnings(test_train( - cl = cl, - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso_test_all_fail", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - failed_prediction_data <- as_familiar_data( - object = model_failed_predictions, - data = full_data, - data_element = data_element, - cl = cl, - ...) - - test_fun( - paste0( - "12. Exports for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_all_predictions_fail, - "can", "cannot"), - " be created for models that do not allow for predicting survival probabilitiies."), - { - collection <- suppressWarnings(as_familiar_collection( - failed_prediction_data, - familiar_data_names = c("all_failed_predictions"))) - - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) - - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) - - if (outcome_type %in% outcome_type_available && !.not_available_all_predictions_fail) { - testthat::expect_equal(all(which_present), TRUE) - if (debug) show(data_elements) + test_message <- paste0( + "(limited censoring) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for a data set that includes no or limited censoring." + ) - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) - } else { - testthat::expect_equal(any(!which_present), TRUE) + rm("data_cens_1", "data_cens_2", "data_cens_3") + rm("model_cens_1", "model_cens_2", "model_cens_3") } } - ) - - # With some invalid predictions -------------------------------------------- - - model_failing_predictions <- suppressWarnings(test_train( - cl = cl, - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso_test_some_fail", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - failing_prediction_data <- as_familiar_data( - object = model_failing_predictions, - data = full_data, - data_element = data_element, - cl = cl, - ...) - - test_fun( - paste0( - "13. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_some_predictions_fail, - "can", "cannot"), - " be created for models that contain some invalid predictions."), - { - collection <- suppressWarnings(as_familiar_collection( - failing_prediction_data, - familiar_data_names = c("some_failed_predictions"))) + + # Only invalid predictions ----------------------------------------------- + + if (is.null(debug_config) || "all invalid predictions" %in% debug_config) { + model_failed_predictions <- suppressWarnings(test_train( + cl = cl, + data = full_data, + cluster_method = "none", + imputation_method = "simple", + hyperparameter_list = hyperparameters, + learner = "lasso_test_all_fail", + time_max = 3.5, + create_novelty_detector = create_novelty_detector + )) - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) + failed_prediction_data <- ..as_familiar_data_object( + object = model_failed_predictions, + data = full_data, + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) + familiar_data_list <- mapply(set_object_name, list(failed_prediction_data), c("all_failed_predictions")) - if (outcome_type %in% outcome_type_available && !.not_available_some_predictions_fail) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else if (!outcome_type %in% outcome_type_available) { - testthat::expect_equal(all(!which_present), TRUE) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } - } - ) - - # With extreme probability values ------------------------------------------ - - # Train the model. - if (outcome_type %in% c("binomial", "multinomial")) { - model_extreme_predictions <- suppressWarnings(test_train( - cl = cl, - data = full_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = hyperparameters, - learner = "lasso_test_extreme", - time_max = 1832, - create_novelty_detector = create_novelty_detector)) - - extreme_prediction_data <- as_familiar_data( - object = model_extreme_predictions, - data = full_data, - data_element = data_element, - cl = cl, - ...) - - test_fun( - paste0( - "14. Export data for ", outcome_type, " outcomes ", - ifelse( - outcome_type %in% outcome_type_available && !.not_available_extreme_probability, - "can", "cannot"), - " be created for models yielding extreme predictions."), - { - collection <- suppressWarnings(as_familiar_collection( - extreme_prediction_data, - familiar_data_names = c("extreme_predictions"))) - - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) - - which_present <- .test_which_data_element_present( - data_elements, - outcome_type = outcome_type) - - if (outcome_type %in% outcome_type_available && !.not_available_extreme_probability) { - testthat::expect_equal(all(which_present), TRUE) - - if (debug) show(data_elements) - - } else { - testthat::expect_equal(any(!which_present), TRUE) - } + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("all_failed_predictions") + )) + + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available && !.not_available_all_predictions_fail) { + test_expectation <- "all_present" } - ) - } - } -} - - - -test_export_specific <- function( - export_function, - data_element, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - ..., - export_args = list(), - use_data_set = "full", - n_models = 1L, - create_novelty_detector = FALSE, - debug = FALSE) { - - # Create list for output. - out_elements <- list() - - # Iterate over the outcome type. - for (outcome_type in outcome_type_available) { - - if (!test_data_package_installed(outcome_type)) next - - # Obtain data. - main_data <- test_create_good_data(outcome_type) - - data <- switch( - use_data_set, - "full" = test_create_good_data(outcome_type), - "identical" = test_create_all_identical_data(outcome_type), - "one_sample" = test_create_one_sample_data(outcome_type)) - - # Parse hyperparameter list - hyperparameters <- list( - "sign_size" = get_n_features(main_data), - "family" = switch( - outcome_type, - "continuous" = "gaussian", - "count" = "poisson", - "binomial" = "binomial", - "multinomial" = "multinomial", - "survival" = "cox")) - - if (n_models == 1) { - # Train the model. - model_full_1 <- do.call_with_handlers( - test_train, - args = list( - data = main_data, + + test_message <- paste0( + "(all invalid predictions) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for models that do not provide valid predictions." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("failed_prediction_data", "model_failed_predictions") + } + + # Some invalid predictions ----------------------------------------------- + + if (is.null(debug_config) || "some invalid predictions" %in% debug_config) { + + model_failing_predictions <- suppressWarnings(test_train( + cl = cl, + data = full_data, cluster_method = "none", imputation_method = "simple", hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, + learner = "lasso_test_some_fail", + time_max = 3.5, create_novelty_detector = create_novelty_detector + )) + + failing_prediction_data <- ..as_familiar_data_object( + object = model_failing_predictions, + data = full_data, + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... ) - ) - if (!test_object_package_installed(model_full_1)) next - model_full_1 <- model_full_1$value - - model_full_2 <- model_full_1 - model_full_2@fs_method <- "mifs" + + familiar_data_list <- mapply(set_object_name, list(failing_prediction_data), c("some_failed_predictions")) + + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("some_failed_predictions") + )) + + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available && !.not_available_some_predictions_fail) { + test_expectation <- "all_present" + } + + test_message <- paste0( + "(some invalid predictions) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for models that provide some invalid predictions." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("failing_prediction_data", "model_failing_predictions") + } - } else { - # Train a set of models. - model_full_1 <- list() - model_full_2 <- list() - - for (ii in seq_len(n_models)) { - temp_model_1 <- do.call_with_handlers( - test_train, - args = list( - data = main_data, + # Extreme predicted values ----------------------------------------------- + + if (is.null(debug_config) || "extreme predictions" %in% debug_config) { + if (outcome_type %in% c("binomial", "multinomial")) { + + model_extreme_predictions <- suppressWarnings(test_train( + cl = cl, + data = full_data, cluster_method = "none", imputation_method = "simple", - fs_method = "mim", hyperparameter_list = hyperparameters, - learner = "lasso", - time_max = 1832, - create_bootstrap = TRUE, + learner = "lasso_test_extreme", + time_max = 3.5, create_novelty_detector = create_novelty_detector - ) - ) - if (!test_object_package_installed(temp_model_1)) next - temp_model_1 <- temp_model_1$value - - temp_model_2 <- temp_model_1 - temp_model_2@fs_method <- "mifs" - - model_full_1[[ii]] <- temp_model_1 - model_full_2[[ii]] <- temp_model_2 - } - } - - # Create familiar data objects. - data_good_full_1 <- as_familiar_data( - object = model_full_1, - data = data, - data_element = data_element, - ...) - - data_good_full_2 <- as_familiar_data( - object = model_full_2, - data = data, - data_element = data_element, - ...) - - # Generate data objects and names. - object <- list(data_good_full_1, data_good_full_2, data_good_full_1, data_good_full_2) - object <- mapply( - set_object_name, - object, - c("development_1", "development_2", "validation_1", "validation_2")) - - # Process to collect. - collection <- suppressWarnings(as_familiar_collection( - object, - familiar_data_names = c("development", "development", "validation", "validation"))) - - # Create data elements. - data_elements <- do.call( - export_function, - args = c( - list("object" = collection), - export_args)) - - # Save data elements and add name. - current_element <- list(data_elements) - names(current_element) <- outcome_type - - out_elements <- c(out_elements, current_element) - } - - return(out_elements) -} - - - -integrated_test <- function( - ..., - learner = NULL, - hyperparameters = NULL, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - warning_good = NULL, - warning_bad = NULL, - debug = FALSE) { - if (debug) { - test_fun <- debug_test_that - suppress_fun <- identity - } else { - test_fun <- testthat::test_that - suppress_fun <- suppressMessages - } - - # Set flag for missing learner. - learner_unset <- is.null(learner) - - for (outcome_type in outcome_type_available) { - - if (!test_data_package_installed(outcome_type)) next - - .warning_good <- warning_good - if (is.list(warning_good)) { - .warning_good <- warning_good[[outcome_type]] - } - - .warning_bad <- warning_bad - if (is.list(warning_bad)) { - .warning_bad <- warning_bad[[outcome_type]] - } - - test_fun( - paste0( - "Experiment for a good dataset with ", outcome_type, - " outcome functions correctly."), - { - # Create datasets - full_data <- test_create_good_data(outcome_type) - - if (learner_unset) { - # Set learner - learner <- "lasso" - - # Parse hyperparameter list - hyperparameters <- list( - "sign_size" = get_n_features(full_data), - "family" = switch( - outcome_type, - "continuous" = "gaussian", - "count" = "poisson", - "binomial" = "binomial", - "multinomial" = "multinomial", - "survival" = "cox")) - - # Parse as list. - hyperparameters <- list("lasso" = hyperparameters) - } - - if (!is.null(.warning_good)) { - testthat::expect_warning( - output <- suppress_fun(summon_familiar( - data = full_data, - learner = learner, - hyperparameter = hyperparameters, - time_max = 1832, - verbose = debug, - ...)), - .warning_good) + )) - } else { - output <- suppress_fun(summon_familiar( + extreme_prediction_data <- ..as_familiar_data_object( + object = model_extreme_predictions, data = full_data, - learner = learner, - hyperparameter = hyperparameters, - time_max = 1832, - verbose = debug, - ...)) - } - - testthat::expect_equal(is.null(output), FALSE) - } - ) - - test_fun( - paste0( - "Experiment for a bad dataset with ", outcome_type, - " outcome functions correctly."), - { - # Create datasets. We explicitly insert NA data to circumvent an initial - # plausibility check. - bad_data <- test_create_bad_data( - outcome_type = outcome_type, - add_na_data = TRUE) - - if (learner_unset) { - # Set learner - learner <- "lasso" - - # Parse hyperparameter list - hyperparameters <- list( - "sign_size" = get_n_features(bad_data), - "family" = switch( - outcome_type, - "continuous" = "gaussian", - "count" = "poisson", - "binomial" = "binomial", - "multinomial" = "multinomial", - "survival" = "cox")) - - # Parse as list. - hyperparameters <- list("lasso" = hyperparameters) - } - - if (!is.null(.warning_bad)) { - testthat::expect_warning( - output <- suppress_fun(summon_familiar( - data = bad_data, - learner = learner, - hyperparameter = hyperparameters, - feature_max_fraction_missing = 0.95, - time_max = 1832, - verbose = debug, - ...)), - .warning_bad) + data_element = data_element, + cl = cl, + use_prediction_table = use_prediction_table, + ... + ) - } else { - # Note that we set a very high feature_max_fraction_missing to deal - # with NA rows in the dataset. Also time is explicitly set to prevent - # an error. - output <- suppress_fun(summon_familiar( - data = bad_data, - learner = learner, - hyperparameter = hyperparameters, - feature_max_fraction_missing = 0.95, - time_max = 1832, - verbose = debug, - ...)) + familiar_data_list <- mapply(set_object_name, list(extreme_prediction_data), c("extreme_predictions")) + + familiar_collection <- suppressWarnings(as_familiar_collection( + familiar_data_list, + familiar_data_names = c("extreme_predictions") + )) + + test_expectation <- "all_absent" + if (outcome_type %in% outcome_type_available && !.not_available_extreme_probability) { + test_expectation <- "all_present" + } + + test_message <- paste0( + "(extreme predictions) Data for ", outcome_type, " outcomes ", + ifelse(test_expectation == "all_present", "can", "cannot"), + " be created for models yielding extreme predictions." + ) + + coro::yield(list( + "collection" = familiar_collection, + "message" = test_message, + "expectation" = test_expectation + )) + + rm("extreme_prediction_data", "model_extreme_predictions") } - - testthat::expect_equal(is.null(output), FALSE) } - ) - } -} - - - -debug_test_that <- function(desc, code) { - # This is a drop-in replacement for testthat::test_that that makes it easier - # to debug errors. - - if (!is.character(desc) || length(desc) != 1) { - stop("\"desc\" should be a character string") - } - - # Execute the code - code <- substitute(code) - eval(code, envir = parent.frame()) -} - - - -test_not_deprecated <- function(x, deprecation_string = c("deprec", "replac")) { - # Test that no deprecation warnings are given. - if (length(x) > 0) { - for (current_string in deprecation_string) { - testthat::expect_equal( - any(grepl( - x = x, - pattern = current_string, - fixed = TRUE)), - FALSE) } - } -} - - - -.test_which_plot_present <- function(p) { - # Check if the top element is null or empty. - if (is.null(p)) return(FALSE) - if (length(p) == 0) return(FALSE) - - # Check that the top element is a gtable or ggplot. - if (gtable::is.gtable(p) || ggplot2::is.ggplot(p)) { - return(TRUE) - } - - plot_present <- sapply(p, gtable::is.gtable) | sapply(p, ggplot2::is.ggplot) - if (any(plot_present)) { - return(plot_present) - } - - if (all(sapply(p, is.null))) { - return(!sapply(p, is.null)) - } - - # If the code gets here, p is a nested list. - p <- unlist(p, recursive = FALSE) - - if (is.null(p)) return(FALSE) - if (length(p) == 0) return(FALSE) - - return(sapply(p, gtable::is.gtable) | sapply(p, ggplot2::is.ggplot)) -} - - - -.test_which_data_element_present <- function(x, outcome_type) { - # Check if the top element is null or empty. - if (is_empty(x)) return(FALSE) - - data_element_present <- !sapply(x, is_empty) - if (!any(data_element_present)) return(FALSE) - - return(data_element_present) -} - - - -.test_start_cluster <- function(n_cores = NULL) { - # Determine the number of available cores. - n_cores_available <- parallel::detectCores() - 1L - - # Determine the number of available cores. - if (is.null(n_cores)) n_cores <- n_cores_available - if (n_cores > n_cores_available) n_cores <- n_cores_available - if (n_cores < 2) return(NULL) - - assign("is_external_cluster", FALSE, envir = familiar_global_env) - - # Start a new cluster - cl <- .start_cluster( - n_cores = n_cores, - cluster_type = "psock") - - # If the cluster doesn't start, return a NULL - if (is.null(cl)) return(NULL) - - # Set library paths to avoid issues with non-standard library locations. - libs <- .libPaths() - parallel::clusterExport(cl = cl, varlist = "libs", envir = environment()) - parallel::clusterEvalQ(cl = cl, .libPaths(libs)) - - # Load familiar and data.table libraries to each cluster node. - parallel::clusterEvalQ(cl = cl, library(familiar)) - parallel::clusterEvalQ(cl = cl, library(data.table)) - - # Set options on each cluster node. - parallel::clusterEvalQ(cl = cl, options(rf.cores = as.integer(1))) - parallel::clusterEvalQ(cl = cl, data.table::setDTthreads(1L)) - - return(cl) -} - - - -.test_create_hyperparameter_object <- function( - data, - vimp_method, - learner, - is_vimp, - cluster_method = "none", - ..., - set_signature_feature = FALSE) { - if (set_signature_feature) { - signature_features <- get_feature_columns(data)[1:2] - } else { - signature_features <- NULL - } - - # Create feature info list. - feature_info_list <- create_feature_info( - data = data, - fs_method = vimp_method, - learner = learner, - cluster_method = cluster_method, - imputation_method = "simple", - ..., - signature = signature_features, - parallel = FALSE) - - # Find required features. - required_features <- get_required_features( - x = data, - feature_info_list = feature_info_list) - - if (is_vimp) { - # Create the variable importance met hod object or familiar model object - # to compute variable importance with. - object <- promote_vimp_method(object = methods::new("familiarVimpMethod", - outcome_type = data@outcome_type, - vimp_method = vimp_method, - required_features = required_features, - feature_info = feature_info_list, - outcome_info = data@outcome_info)) - - } else { - # Create familiar model object. - object <- promote_learner(object = methods::new("familiarModel", - outcome_type = data@outcome_type, - learner = learner, - fs_method = vimp_method, - required_features = required_features, - feature_info = feature_info_list, - outcome_info = data@outcome_info)) - } - - return(object) + }) + + return(.generate_test_collection(...)) } - -.is_testing <- function() { - return(identical(Sys.getenv("TESTTHAT"), "true")) -} diff --git a/R/TestTrain.R b/R/TestTrain.R new file mode 100644 index 00000000..521f8418 --- /dev/null +++ b/R/TestTrain.R @@ -0,0 +1,208 @@ +#' @include FamiliarS4Generics.R +#' @include FamiliarS4Classes.R +NULL + + + +# test_train (generic) --------------------------------------------------------- +setGeneric( + "test_train", + function(data, ...) standardGeneric("test_train") +) + + + +# test_train (data.table) ------------------------------------------------------ +setMethod( + "test_train", + signature(data = "data.table"), + function( + data, + data_bypass = NULL, + learner, + hyperparameter_list = list(), + create_bootstrap = FALSE, + ... + ) { + if (!is.null(data_bypass)) { + # Convert data_bypass to dataObject. + data_bypass <- do.call( + as_data_object, + args = c( + list("data" = data_bypass), + list(...) + ) + ) + } + + # Convert data to dataObject. + data <- do.call( + as_data_object, + args = c( + list("data" = data), + list(...) + ) + ) + + return(do.call( + test_train, + args = c( + list( + "data" = data, + "data_bypass" = data_bypass, + "learner" = learner, + "hyperparameter_list" = hyperparameter_list, + "create_bootstrap" = create_bootstrap + ), + list(...) + ) + )) + } +) + + + +# test_train (dataObject) ------------------------------------------------------ +setMethod( + "test_train", + signature(data = "dataObject"), + function( + data, + data_bypass = NULL, + learner, + hyperparameter_list = list(), + create_bootstrap = FALSE, + create_novelty_detector = FALSE, + create_naive = FALSE, + cl = NULL, + trim_model = FALSE, + verbose = FALSE, + ... + ) { + # The bypass data allows for bypassing important aspects of the + # pre-processing pipeline, e.g. the preprocessing checks. This enables + # testing of very rare cases where preprocessing may run fine, but the + # subsample does not allow for training. + if (is.null(data_bypass)) data_bypass <- data + + # Prepare settings --------------------------------------------------------- + + # Reconstitute settings from the data. + settings <- extract_settings_from_data(data_bypass) + + # Update some missing settings that can be fixed within this method. + settings$data$train_cohorts <- unique(data_bypass@data[[get_id_columns(single_column = "batch")]]) + + # Parse the remaining settings that are important. Remove outcome_type from + # ... This prevents an error caused by multiple matching arguments. + dots <- list(...) + dots$parallel <- NULL + dots$vimp_method <- NULL + + # Determine if a naive model should be forced. + vimp_method <- ifelse(create_naive, "no_features", "none") + + settings <- do.call( + .parse_general_settings, + args = c( + list( + "settings" = settings, + "data" = data_bypass@data, + "parallel" = FALSE, + "vimp_method" = vimp_method, + "learner" = learner + ), + dots + ) + ) + + # Push settings to the backend as some functions require this. + .assign_settings_to_global(settings = settings) + + + # Prepare hyperparameters -------------------------------------------------- + + # Get default hyperparameters. + param_list <- .get_preset_hyperparameters( + data = data, + learner = learner, + names_only = FALSE + ) + + # Update with user-provided settings. + param_list <- .update_hyperparameters( + parameter_list = param_list, + user_list = hyperparameter_list + ) + + # Determine which hyperparameters still need to be specified. + unset_parameters <- sapply( + param_list, + function(hyperparameter_entry) hyperparameter_entry$randomise + ) + + # Raise an error if any hyperparameters were not set. + if (any(unset_parameters)) { + ..error(paste0( + "The following hyperparameters need to be specified: ", + paste_s(names(unset_parameters)[unset_parameters]) + )) + } + + # Obtain the final list of hyperparameters. + param_list <- lapply( + param_list, + function(hyperparameter_entry) hyperparameter_entry$init_config + ) + + + # Create feature information list ------------------------------------------ + + feature_info_task <- methods::new( + "familiarTaskFeatureInfo" + ) + + # Feature information objects are created from the bypass dataset. + feature_info <- .perform_task( + object = feature_info_task, + data = data_bypass, + settings = settings, + verbose = verbose + ) + + + # Create learner ----------------------------------------------------------- + + train_task <- methods::new( + "familiarTaskTrain", + vimp_method = vimp_method, + learner = learner + ) + + if (create_bootstrap) { + data <- select_data_from_samples( + data = data, + samples = fam_sample( + x = data@data, + replace = TRUE, + seed = 19L + ) + ) + } + + # Learners are trained using the actual data. + object <- .perform_task( + object = train_task, + data = data, + settings = settings, + feature_info_list = feature_info, + hyperparameters = param_list, + novelty_detector = ifelse(create_novelty_detector, "isolation_forest", "none"), + detector_parameters = NULL, + trim_model = trim_model, + verbose = verbose + ) + + return(object) + } +) diff --git a/R/TestTrainNovelty.R b/R/TestTrainNovelty.R new file mode 100644 index 00000000..06ef8ccd --- /dev/null +++ b/R/TestTrainNovelty.R @@ -0,0 +1,199 @@ +# test_train_novelty_detector (generic) ---------------------------------------- +setGeneric("test_train_novelty_detector", function(data, ...) standardGeneric("test_train_novelty_detector")) + + + +# test_train_novelty_detector (data.table) ------------------------------------- +setMethod( + "test_train_novelty_detector", + signature(data = "data.table"), + function( + data, + data_bypass = NULL, + detector, + hyperparameter_list = list(), + create_bootstrap = FALSE, + ... + ) { + if (!is.null(data_bypass)) { + # Convert data_bypass to dataObject. + data_bypass <- do.call( + as_data_object, + args = c( + list("data" = data_bypass), + list(...) + ) + ) + } + + # Convert data to dataObject. + data <- do.call( + as_data_object, + args = c( + list("data" = data), + list(...) + ) + ) + + return(do.call( + test_train_novelty_detector, + args = c( + list( + "data" = data, + "data_bypass" = data_bypass, + "detector" = detector, + "hyperparameter_list" = hyperparameter_list, + "create_bootstrap" = create_bootstrap + ), + list(...) + ) + )) + } +) + + +# test_train_novelty_detector (dataObject) ------------------------------------- +setMethod( + "test_train_novelty_detector", + signature(data = "dataObject"), + function( + data, + data_bypass = NULL, + detector, + hyperparameter_list = list(), + create_bootstrap = FALSE, + cl = NULL, + trim_model = FALSE, + ... + ) { + # The bypass data allows for bypassing important aspects of the + # pre-processing pipeline, e.g. the preprocessing checks. This enables + # testing of very rare cases where preprocessing may run fine, but the + # subsample does not allow for training. + if (is.null(data_bypass)) data_bypass <- data + + # Prepare settings --------------------------------------------------------- + + # Reconstitute settings from the data. + settings <- extract_settings_from_data(data_bypass) + + # Update some missing settings that can be fixed within this method. + settings$data$train_cohorts <- unique(data_bypass@data[[get_id_columns(single_column = "batch")]]) + + # Parse the remaining settings that are important. Remove outcome_type from + # ... This prevents an error caused by multiple matching arguments. + dots <- list(...) + dots$parallel <- NULL + dots$vimp_method <- NULL + dots$hyperparameter <- NULL + + # Create setting_hyperparam so that it can be parsed correctly. + if (!detector %in% names(hyperparameter_list) && length(hyperparameter_list) > 0L) { + setting_hyperparam <- list() + setting_hyperparam[[detector]] <- hyperparameter_list + } else { + setting_hyperparam <- hyperparameter_list + } + + settings <- do.call( + .parse_general_settings, + args = c( + list( + "settings" = settings, + "data" = data_bypass@data, + "parallel" = FALSE, + "vimp_method" = "none", + "learner" = "glm", + "novelty_detector" = detector, + "detector_parameters" = setting_hyperparam + ), + dots + ) + ) + + # Push settings to the backend. + .assign_settings_to_global(settings = settings) + + + # Prepare hyperparameters -------------------------------------------------- + + # Get default hyperparameters. + param_list <- .get_preset_hyperparameters( + data = data, + detector = detector, + names_only = FALSE + ) + + # Update with user-provided settings. + param_list <- .update_hyperparameters( + parameter_list = param_list, + user_list = settings$mb$detector_parameters[[detector]] + ) + + # Determine which hyperparameters still need to be specified. + unset_parameters <- sapply( + param_list, + function(hyperparameter_entry) hyperparameter_entry$randomise + ) + + # Raise an error if any hyperparameters were not set. + if (any(unset_parameters)) { + ..error(paste0( + "The following hyperparameters need to be specified: ", + paste_s(names(unset_parameters)[unset_parameters]) + )) + } + + # Obtain the final list of hyperparameters. + param_list <- lapply( + param_list, + function(hyperparameter_entry) hyperparameter_entry$init_config + ) + + + # Create feature information list ------------------------------------------ + + feature_info_task <- methods::new( + "familiarTaskFeatureInfo" + ) + + # Feature information objects are created from the bypass dataset. + feature_info <- .perform_task( + object = feature_info_task, + data = data_bypass, + settings = settings + ) + + + # Create novelty detector -------------------------------------------------- + + detector_task <- methods::new( + "familiarTaskTrainNovelty", + learner = detector, + vimp_method = "none" + ) + + # Create bootstraps. + if (create_bootstrap) { + data <- select_data_from_samples( + data = data, + samples = fam_sample( + x = data@data, + replace = TRUE + ) + ) + } + + # Train novelty detector and add to model. + object <- .perform_task( + object = detector_task, + data = data, + settings = settings, + feature_info_list = feature_info, + hyperparameters = param_list, + trim_model = trim_model + ) + + return(object) + } +) diff --git a/R/TestVimp.R b/R/TestVimp.R new file mode 100644 index 00000000..8cf0e3cb --- /dev/null +++ b/R/TestVimp.R @@ -0,0 +1,167 @@ +# test_create_vimp_method (data.table) ----------------------------------------- +setMethod( + "test_create_vimp_method", + signature(data = "data.table"), + function( + data, + vimp_method, + vimp_method_parameter_list = list(), + ... + ) { + # Convert data to dataObject. + data <- do.call( + as_data_object, + args = c( + list("data" = data), + list(...) + ) + ) + + return(do.call( + test_create_vimp_method, + args = c( + list( + "data" = data, + "vimp_method" = vimp_method, + "vimp_method_parameter_list" = vimp_method_parameter_list + ), + list(...) + ) + )) + } +) + + + +# test_create_vimp_method (dataObject) ----------------------------------------- +setMethod( + "test_create_vimp_method", + signature(data = "dataObject"), + function( + data, + data_bypass = NULL, + vimp_method, + vimp_method_parameter_list = list(), + ... + ) { + # The bypass data allows for bypassing important aspects of the + # pre-processing pipeline, e.g. the preprocessing checks. This enables + # testing of very rare cases where preprocessing may run fine, but the + # subsample does not allow for training. + if (is.null(data_bypass)) data_bypass <- data + + # Prepare setting ---------------------------------------------------------- + + # Reconstitute settings from the data. + settings <- extract_settings_from_data(data) + + # Update some missing settings that can be fixed within this method. + settings$data$train_cohorts <- unique(data@data[[get_id_columns(single_column = "batch")]]) + + # Parse the remaining settings that are important. Remove outcome_type from + # ... This prevents an error caused by multiple matching arguments. + dots <- list(...) + dots$parallel <- NULL + dots$vimp_method <- NULL + + if (!is.null(dots$signature)) settings$data$signature <- dots$signature + + settings <- do.call( + .parse_general_settings, + args = c( + list( + "settings" = settings, + "data" = data_bypass@data, + "parallel" = FALSE, + "vimp_method" = vimp_method, + "learner" = "glm" + ), + dots + ) + ) + + # Push settings to the backend. + .assign_settings_to_global(settings = settings) + + + # Prepare hyperparameters -------------------------------------------------- + + # Get default hyperparameters. + param_list <- .get_preset_hyperparameters( + data = data, + vimp_method = vimp_method, + names_only = FALSE + ) + + # Update with user-provided settings. + param_list <- .update_hyperparameters( + parameter_list = param_list, + user_list = vimp_method_parameter_list + ) + + # Determine which hyperparameters still need to be specified. + unset_parameters <- sapply( + param_list, + function(hyperparameter_entry) hyperparameter_entry$randomise + ) + + # Mark sign-size as set, as it is not used for variable importance. + if ("sign_size" %in% names(unset_parameters)) { + unset_parameters["sign_size"] <- FALSE + } + + # Raise an error if any hyperparameters were not set. + if (any(unset_parameters)) { + ..error(paste0( + "The following hyperparameters need to be specified: ", + paste_s(names(unset_parameters)[unset_parameters]) + )) + } + + # Obtain the final list of hyperparameters. + param_list <- lapply( + param_list, + function(hyperparameter_entry) hyperparameter_entry$init_config + ) + + + # Create feature information list ------------------------------------------ + + feature_info_task <- methods::new( + "familiarTaskFeatureInfo" + ) + + # Feature information objects are created from the bypass dataset. + feature_info <- .perform_task( + object = feature_info_task, + data = data_bypass, + settings = settings + ) + + + # Prepare vimp object ------------------------------------------------------ + + # Get required features. + required_features <- get_required_features( + x = data, + feature_info_list = feature_info + ) + + # Create a familiar variable importance method. + object <- methods::new( + "familiarVimpMethod", + outcome_type = data@outcome_type, + vimp_method = vimp_method, + hyperparameters = param_list, + outcome_info = data@outcome_info, + feature_info = feature_info[required_features], + required_features = required_features + ) + + # Promote object to correct subclass. + object <- promote_vimp_method(object) + + # Return in list. + return(object) + } +) diff --git a/R/TrainS4Methods.R b/R/TrainS4Methods.R deleted file mode 100644 index 20d22951..00000000 --- a/R/TrainS4Methods.R +++ /dev/null @@ -1,475 +0,0 @@ -#' @include FamiliarS4Generics.R -#' @include FamiliarS4Classes.R -NULL - - - -# test_train (generic) --------------------------------------------------------- -setGeneric("test_train", function(data, ...) standardGeneric("test_train")) - - - -# test_train (data.table) ------------------------------------------------------ -setMethod( - "test_train", - signature(data = "data.table"), - function( - data, - data_bypass = NULL, - learner, - hyperparameter_list = list(), - create_bootstrap = FALSE, - ...) { - if (!is.null(data_bypass)) { - # Convert data_bypass to dataObject. - data_bypass <- do.call( - as_data_object, - args = c( - list("data" = data_bypass), - list(...))) - } - - # Convert data to dataObject. - data <- do.call( - as_data_object, - args = c( - list("data" = data), - list(...))) - - return(do.call( - test_train, - args = c( - list( - "data" = data, - "data_bypass" = data_bypass, - "learner" = learner, - "hyperparameter_list" = hyperparameter_list, - "create_bootstrap" = create_bootstrap), - list(...)))) - } -) - - - -# test_train (dataObject) ------------------------------------------------------ -setMethod( - "test_train", - signature(data = "dataObject"), - function( - data, - data_bypass = NULL, - learner, - hyperparameter_list = list(), - create_bootstrap = FALSE, - create_novelty_detector = FALSE, - create_naive = FALSE, - cl = NULL, - trim_model = FALSE, - ...) { - # The bypass data allows for bypassing important aspects of the - # pre-processing pipeline, e.g. the preprocessing checks. This enables - # testing of very rare cases where preprocessing may run fine, but the - # subsample does not allow for training. - if (is.null(data_bypass)) data_bypass <- data - - # Prepare settings --------------------------------------------------------- - - # Reconstitute settings from the data. - settings <- extract_settings_from_data(data_bypass) - - # Update some missing settings that can be fixed within this method. - settings$data$train_cohorts <- unique(data_bypass@data[[get_id_columns(single_column = "batch")]]) - - # Parse the remaining settings that are important. Remove outcome_type from - # ... This prevents an error caused by multiple matching arguments. - dots <- list(...) - dots$parallel <- NULL - dots$fs_method <- NULL - dots$hyperparameter <- NULL - - # Create setting_hyperparam so that it can be parsed correctly. - if (!learner %in% names(hyperparameter_list) && length(hyperparameter_list) > 0) { - setting_hyperparam <- list() - setting_hyperparam[[learner]] <- hyperparameter_list - } else { - setting_hyperparam <- hyperparameter_list - } - - # Determine if a naive model should be forced. - fs_method <- ifelse(create_naive, "no_features", "none") - - settings <- do.call( - .parse_general_settings, - args = c( - list( - "settings" = settings, - "data" = data_bypass@data, - "parallel" = FALSE, - "fs_method" = fs_method, - "learner" = learner, - "hyperparameter" = setting_hyperparam), - dots)) - - # Push settings to the backend. - .assign_settings_to_global(settings = settings) - - # Prepare outcome_info ----------------------------------------------------- - - # Create a generic outcome object - outcome_info <- data_bypass@outcome_info - - # Prepare featureInfo objects ---------------------------------------------- - - # Create a list of featureInfo objects. - feature_info_list <- .get_feature_info_data( - data = data_bypass@data, - file_paths = NULL, - project_id = character(), - outcome_type = settings$data$outcome_type) - - # Extract the generic data. - feature_info_list <- feature_info_list[["generic"]] - - # Perform some pre-processing (i.e. remove singular features) - feature_info_list <- .determine_preprocessing_parameters( - cl = cl, - data = data_bypass, - feature_info_list = feature_info_list, - settings = settings, - verbose = FALSE) - - # Remove invariant features from the data - data <- filter_features( - data = data, - available_features = get_available_features( - feature_info_list = feature_info_list)) - - # Find features that are required for processing the data - required_features <- get_required_features( - x = data, - feature_info_list = feature_info_list) - - # Find important features, i.e. those that constitute the signature either - # individually or as part of a cluster. - model_features <- get_model_features( - x = data, - feature_info_list = feature_info_list) - - # Naive models do not require features. - if (create_naive) required_features <- model_features <- NULL - - # Prepare hyperparameters -------------------------------------------------- - - # Get default hyperparameters. - param_list <- .get_preset_hyperparameters( - data = data, - learner = learner, - names_only = FALSE) - - # Update with user-provided settings. - param_list <- .update_hyperparameters( - parameter_list = param_list, - user_list = settings$mb$hyper_param[[learner]]) - - # Determine which hyperparameters still need to be specified. - unset_parameters <- sapply( - param_list, - function(hyperparameter_entry) hyperparameter_entry$randomise) - - # Raise an error if any hyperparameters were not set. - if (any(unset_parameters)) { - stop(paste0( - "The following hyperparameters need to be specified: ", - paste_s(names(unset_parameters)[unset_parameters]))) - } - - # Obtain the final list of hyperparameters. - param_list <- lapply( - param_list, - function(hyperparameter_entry) hyperparameter_entry$init_config) - - # Prepare model and data --------------------------------------------------- - - # Create familiar model - object <- methods::new( - "familiarModel", - outcome_type = settings$data$outcome_type, - learner = learner, - fs_method = fs_method, - hyperparameters = param_list, - required_features = required_features, - model_features = model_features, - novelty_features = model_features, - run_table = get_placeholder_run_table(), - feature_info = feature_info_list, - outcome_info = outcome_info, - settings = settings$eval, - project_id = 0) - - # Add package version/ - object <- add_package_version(object = object) - - # Process data. - data <- process_input_data( - object = object, - data = data, - stop_at = "clustering") - - # Create bootstraps. - if (create_bootstrap) { - data <- select_data_from_samples( - data = data, - samples = fam_sample( - x = data@data, - replace = TRUE)) - } - - # Train model. - object <- .train( - object = object, - data = data, - get_additional_info = TRUE, - trim_model = trim_model, - timeout = Inf) - - # Train novelty detector. - object <- .train_novelty_detector( - object = object, - data = data, - detector = ifelse(create_novelty_detector, "isolation_forest", "none")) - - # Generate a placeholder name for the familiarModel object - object <- set_object_name(x = object) - - return(object) - } -) - - - -# test_train_novelty_detector (generic) ---------------------------------------- -setGeneric("test_train_novelty_detector", function(data, ...) standardGeneric("test_train_novelty_detector")) - - - -# test_train_novelty_detector (data.table) ------------------------------------- -setMethod( - "test_train_novelty_detector", - signature(data = "data.table"), - function( - data, - data_bypass = NULL, - detector, - hyperparameter_list = list(), - create_bootstrap = FALSE, - ...) { - if (!is.null(data_bypass)) { - # Convert data_bypass to dataObject. - data_bypass <- do.call( - as_data_object, - args = c( - list("data" = data_bypass), - list(...))) - } - - # Convert data to dataObject. - data <- do.call( - as_data_object, - args = c( - list("data" = data), - list(...))) - - return(do.call( - test_train_novelty_detector, - args = c( - list( - "data" = data, - "data_bypass" = data_bypass, - "detector" = detector, - "hyperparameter_list" = hyperparameter_list, - "create_bootstrap" = create_bootstrap), - list(...)))) - } -) - - -# test_train_novelty_detector (dataObject) ------------------------------------- -setMethod( - "test_train_novelty_detector", - signature(data = "dataObject"), - function( - data, - data_bypass = NULL, - detector, - hyperparameter_list = list(), - create_bootstrap = FALSE, - cl = NULL, - trim_model = FALSE, - ...) { - # The bypass data allows for bypassing important aspects of the - # pre-processing pipeline, e.g. the preprocessing checks. This enables - # testing of very rare cases where preprocessing may run fine, but the - # subsample does not allow for training. - if (is.null(data_bypass)) data_bypass <- data - - # Prepare settings --------------------------------------------------------- - - # Reconstitute settings from the data. - settings <- extract_settings_from_data(data_bypass) - - # Update some missing settings that can be fixed within this method. - settings$data$train_cohorts <- unique(data_bypass@data[[get_id_columns(single_column = "batch")]]) - - # Parse the remaining settings that are important. Remove outcome_type from - # ... This prevents an error caused by multiple matching arguments. - dots <- list(...) - dots$parallel <- NULL - dots$fs_method <- NULL - dots$hyperparameter <- NULL - - # Create setting_hyperparam so that it can be parsed correctly. - if (!detector %in% names(hyperparameter_list) && length(hyperparameter_list) > 0) { - setting_hyperparam <- list() - setting_hyperparam[[detector]] <- hyperparameter_list - } else { - setting_hyperparam <- hyperparameter_list - } - - settings <- do.call( - .parse_general_settings, - args = c( - list( - "settings" = settings, - "data" = data_bypass@data, - "parallel" = FALSE, - "fs_method" = "none", - "learner" = "glm", - "novelty_detector" = detector, - "detector_parameters" = setting_hyperparam), - dots)) - - # Push settings to the backend. - .assign_settings_to_global(settings = settings) - - # Prepare featureInfo objects ---------------------------------------------- - - # Create a list of featureInfo objects. - feature_info_list <- .get_feature_info_data( - data = data_bypass@data, - file_paths = NULL, - project_id = character(), - outcome_type = settings$data$outcome_type) - - # Extract the generic data. - feature_info_list <- feature_info_list[["generic"]] - - # Perform some pre-processing (i.e. remove singular features) - feature_info_list <- .determine_preprocessing_parameters( - cl = cl, - data = data_bypass, - feature_info_list = feature_info_list, - settings = settings, - verbose = FALSE) - - # Remove invariant features from the data - data <- filter_features( - data = data, - available_features = get_available_features( - feature_info_list = feature_info_list) - ) - - # Find features that are required for processing the data. - required_features <- get_required_features( - x = data, - feature_info_list = feature_info_list - ) - - # Find important features, i.e. those that constitute the signature either - # individually or as part of a cluster. - model_features <- get_model_features( - x = data, - feature_info_list = feature_info_list) - - # Prepare hyperparameters -------------------------------------------------- - - # Get default hyperparameters. - param_list <- .get_preset_hyperparameters( - data = data, - detector = detector, - names_only = FALSE) - - # Update with user-provided settings. - param_list <- .update_hyperparameters( - parameter_list = param_list, - user_list = settings$mb$detector_parameters[[detector]]) - - # Determine which hyperparameters still need to be specified. - unset_parameters <- sapply( - param_list, - function(hyperparameter_entry) hyperparameter_entry$randomise) - - # Raise an error if any hyperparameters were not set. - if (any(unset_parameters)) { - stop(paste0( - "The following hyperparameters need to be specified: ", - paste_s(names(unset_parameters)[unset_parameters]))) - } - - # Obtain the final list of hyperparameters. - param_list <- lapply( - param_list, - function(hyperparameter_entry) hyperparameter_entry$init_config) - - # Prepare model and data --------------------------------------------------- - - # Create familiar model - object <- methods::new( - "familiarNoveltyDetector", - learner = detector, - hyperparameters = param_list, - required_features = required_features, - model_features = model_features, - feature_info = feature_info_list, - run_table = get_placeholder_run_table(), - project_id = 0) - - # Add package version/ - object <- add_package_version(object = object) - - # Process data. - data <- process_input_data( - object = object, - data = data, - stop_at = "clustering") - - # Create bootstraps. - if (create_bootstrap) { - data <- select_data_from_samples( - data = data, - samples = fam_sample( - x = data@data, - replace = TRUE)) - } - - # Train model. - object <- .train( - object = object, - data = data, - get_additional_info = TRUE, - trim_model = trim_model, - timeout = Inf) - - return(object) - } -) - - - -get_placeholder_run_table <- function() { - return(data.table::data.table( - "run_id" = 1L, - "data_id" = 1L, - "can_pre_process" = TRUE, - "perturbation" = "main", - "perturb_level" = 1)) -} diff --git a/R/Transformation.R b/R/Transformation.R index fab9b69f..d8353847 100644 --- a/R/Transformation.R +++ b/R/Transformation.R @@ -8,13 +8,15 @@ setClass( slots = list( "method" = "character", "transformer" = "ANY", - "fitting_parameters" = "ANY"), + "fitting_parameters" = "ANY" + ), prototype = list( "method" = "none", "transformer" = NULL, - "fitting_parameters" = NULL) + "fitting_parameters" = NULL ) - +) + # NOTE: the classes below were used prior to version 1.5.0. These classes should # not be removed to make sure that the corresponding objects can be updated. All # related methods have been deprecated. @@ -22,26 +24,23 @@ setClass( setClass( "featureInfoParametersTransformationNone", contains = "featureInfoParameters", - slots = list( - "reason" = "ANY"), - prototype = list( - "reason" = NULL)) + slots = list("reason" = "ANY"), + prototype = list("reason" = NULL) +) setClass( "featureInfoParametersTransformationBoxCox", contains = "featureInfoParametersTransformationPowerTransform", - slots = list( - "lambda" = "numeric"), - prototype = list( - "lambda" = NA_real_)) + slots = list("lambda" = "numeric"), + prototype = list("lambda" = NA_real_) +) setClass( "featureInfoParametersTransformationYeoJohnson", contains = "featureInfoParametersTransformationPowerTransform", - slots = list( - "lambda" = "numeric"), - prototype = list( - "lambda" = NA_real_)) + slots = list("lambda" = "numeric"), + prototype = list("lambda" = NA_real_) +) @@ -61,7 +60,8 @@ setClass( # Check type if (!type %in% c("all", "none", "box_cox", "yeo_johnson")) { ..error_reached_unreachable_code(paste0( - ".get_available_transformation_methods: unspecified type: ", type)) + ".get_available_transformation_methods: unspecified type: ", type + )) } available_transformation_method <- NULL @@ -69,19 +69,22 @@ setClass( if (type %in% c("none", "all")) { available_transformation_method <- c( available_transformation_method, - .get_available_none_transformation_methods()) + .get_available_none_transformation_methods() + ) } if (type %in% c("all", "box_cox")) { available_transformation_method <- c( available_transformation_method, - .get_available_box_cox_transformation_methods()) + .get_available_box_cox_transformation_methods() + ) } if (type %in% c("all", "yeo_johnson")) { available_transformation_method <- c( available_transformation_method, - .get_available_yeo_johnson_transformation_methods()) + .get_available_yeo_johnson_transformation_methods() + ) } return(available_transformation_method) @@ -96,7 +99,8 @@ create_transformation_parameter_skeleton <- function( transformation_lambda = NULL, transformation_optimisation_criterion = "mle", transformation_gof_p_value = NULL, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Creates a skeleton for the provided transformation method. If # transformation_lambda is provided (typically not), this value is updated as # well. @@ -107,7 +111,8 @@ create_transformation_parameter_skeleton <- function( # Select only features that appear in the feature info list. feature_names <- intersect( names(feature_info_list), - feature_names) + feature_names + ) # Skip step if no feature info objects are updated. if (is_empty(feature_names)) return(feature_info_list) @@ -116,7 +121,8 @@ create_transformation_parameter_skeleton <- function( .check_parameter_value_is_valid( x = transformation_method, var_name = "transformation_method", - values = .get_available_transformation_methods()) + values = .get_available_transformation_methods() + ) # Check that transformation_lambda is numeric. This is slightly redundant, as # this is also checked by the power.transform package. @@ -124,7 +130,8 @@ create_transformation_parameter_skeleton <- function( .check_number_in_valid_range( x = transformation_lambda, var_name = "transformation_lambda", - range = c(-Inf, Inf)) + range = c(-Inf, Inf) + ) } # Update familiar info objects with a feature transformation skeleton. @@ -135,7 +142,8 @@ create_transformation_parameter_skeleton <- function( lambda = transformation_lambda, optimisation_criterion = transformation_optimisation_criterion, gof_p_value = transformation_gof_p_value, - .override_existing = .override_existing) + .override_existing = .override_existing + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -154,11 +162,14 @@ create_transformation_parameter_skeleton <- function( optimisation_criterion = "mle", gof_p_value = NULL, lambda = NULL, - .override_existing = FALSE) { + .override_existing = FALSE +) { # Check if transformation data was already completed, and does not require # being determined anew. - if (feature_info_complete(feature_info@transformation_parameters) && - !.override_existing) { + if ( + feature_info_complete(feature_info@transformation_parameters) && + !.override_existing + ) { return(feature_info) } @@ -170,7 +181,8 @@ create_transformation_parameter_skeleton <- function( method = method, optimisation_criterion = optimisation_criterion, gof_p_value = gof_p_value, - lambda = lambda) + lambda = lambda + ) # Update transformation_parameters slot. feature_info@transformation_parameters <- object @@ -187,7 +199,8 @@ create_transformation_parameter_skeleton <- function( method, optimisation_criterion = "mle", gof_p_value = NULL, - lambda = NULL) { + lambda = NULL +) { # This is the lowest level function for creation transformation parameter # skeletons. This function always generates the same class of object. Fitting # parameters are passed on to power.transform::find_transformation_parameters. @@ -195,9 +208,11 @@ create_transformation_parameter_skeleton <- function( if (!require_package("power.transform", message_type = "silent")) { fitting_parameters <- list("method" = "none") - } else if (feature_type != "numeric" || - !available || - (method %in% .get_available_none_transformation_methods())) { + } else if ( + feature_type != "numeric" || + !available || + (method %in% .get_available_none_transformation_methods()) + ) { fitting_parameters <- list("method" = "none") } else if (method %in% .get_available_box_cox_transformation_methods()) { @@ -209,7 +224,8 @@ create_transformation_parameter_skeleton <- function( } else { ..error_reached_unreachable_code(paste0( "create_transformation_parameter_skeleton: encountered an unknown transformation method: ", - paste_s(method))) + paste_s(method) + )) } # Set estimation method (optimisation criterion). @@ -270,7 +286,8 @@ add_transformation_parameters <- function( cl = NULL, feature_info_list, data, - verbose = FALSE) { + verbose = FALSE +) { # Determine transformation parameters and add them to the feature_info_list. # Find feature columns. @@ -279,10 +296,12 @@ add_transformation_parameters <- function( # Sanity check. if (!(setequal( feature_names, - get_available_features(feature_info_list = feature_info_list)))) { + get_available_features(feature_info_list = feature_info_list) + ))) { ..error_reached_unreachable_code(paste0( "add_transformation_parameters: features in data and the feature info ", - "list are expect to be the same, but were not.")) + "list are expect to be the same, but were not." + )) } # Iterate over features. @@ -292,7 +311,8 @@ add_transformation_parameters <- function( feature_info = feature_info_list[feature_names], data = data@data[, mget(feature_names)], progress_bar = verbose, - chopchop = TRUE) + chopchop = TRUE + ) # Provide names for the updated feature info objects. names(updated_feature_info) <- feature_names @@ -307,11 +327,13 @@ add_transformation_parameters <- function( .add_transformation_parameters <- function( feature_info, - data) { + data +) { # Pass to underlying function that adds the feature info. object <- add_feature_info_parameters( object = feature_info@transformation_parameters, - data = data) + data = data + ) # Update transformation_parameters slot. feature_info@transformation_parameters <- object @@ -326,11 +348,13 @@ setMethod( "add_feature_info_parameters", signature( object = "featureInfoParametersTransformationPowerTransform", - data = "ANY"), + data = "ANY" + ), function( object, data, - ...) { + ... + ) { # Check if all required parameters have been set. if (feature_info_complete(object)) return(object) @@ -345,7 +369,7 @@ setMethod( # The case where all data are missing is not handled by the power.transform # package, which (correctly) throws an error. if (is.numeric(data)) { - if (all(!is.finite(data))) { + if (!any(is.finite(data))) { object@fitting_parameters$method <- "none" } } @@ -357,7 +381,8 @@ setMethod( power.transform::find_transformation_parameters, args = c( list("x" = data), - object@fitting_parameters) + object@fitting_parameters + ) ), classes = c( "power_transform_no_transform", @@ -381,12 +406,14 @@ setMethod( "apply_feature_info_parameters", signature( object = "featureInfoParametersTransformationPowerTransform", - data = "ANY"), + data = "ANY" + ), function( object, data, invert = FALSE, - ...) { + ... + ) { # Check if the power.transform package is present. if (!require_package("power.transform", message_type = "silent")) { @@ -397,7 +424,8 @@ setMethod( require_package( "power.transform", purpose = "to transform features", - message_type = "error") + message_type = "error" + ) } } @@ -407,8 +435,8 @@ setMethod( y = data, transformer = object@transformer ), - classes = "power_transform_transform_invalid_values") - ) + classes = "power_transform_transform_invalid_values" + )) } else { return(suppressWarnings( @@ -417,8 +445,8 @@ setMethod( transformer = object@transformer, oob_action = "valid" ), - classes = "power_transform_transform_invalid_values") - ) + classes = "power_transform_transform_invalid_values" + )) } } ) @@ -428,7 +456,8 @@ setMethod( ..collect_and_aggregate_transformation_info <- function( feature_info_list, instance_mask, - feature_name) { + feature_name +) { # Aggregate transformation parameters. This function exists so that it can be # tested as part of a unit test. @@ -437,13 +466,15 @@ setMethod( none_object <- ..create_transformation_parameter_skeleton( feature_name = feature_name, - method = "none") + method = "none" + ) none_object@transformer <- power.transform::create_transformer_skeleton(method = "none") if (!any(instance_mask)) { return(list( "parameters" = none_object, - "instance_mask" = instance_mask)) + "instance_mask" = instance_mask + )) } # Check the method of the transformation objects. @@ -461,7 +492,8 @@ setMethod( if (all(object_method[instance_mask] == "none")) { return(list( "parameters" = none_object, - "instance_mask" = instance_mask)) + "instance_mask" = instance_mask + )) } # For the remaining objects, check which class occurs most. @@ -473,7 +505,7 @@ setMethod( method_table <- method_table[!method == "none"] # Select the method that occurs most often. - most_common_method <- method_table[n == max(method_table$n), ]$method[1] + most_common_method <- method_table[n == max(method_table$n), ]$method[1L] # Update the instance mask. instance_mask <- instance_mask & object_method == most_common_method @@ -486,5 +518,6 @@ setMethod( return(list( "parameters" = feature_info_list[[selected_instance]]@transformation_parameters, - "instance_mask" = instance_mask)) + "instance_mask" = instance_mask + )) } diff --git a/R/TrimUtilities.R b/R/TrimUtilities.R index d130907a..b3040b76 100644 --- a/R/TrimUtilities.R +++ b/R/TrimUtilities.R @@ -2,16 +2,17 @@ return(list( "coef" = list( "FUN" = stats::coef, - "with_timeout" = FALSE), + "with_timeout" = FALSE + ), "vcov" = list( "FUN" = stats::vcov, - "with_timeout" = TRUE), + "with_timeout" = TRUE + ), "summary" = list( "FUN" = summary, - "with_timeout" = TRUE), - "varimp" = list( - "FUN" = mboost::varimp, - "with_timeout" = TRUE))) + "with_timeout" = TRUE + ) + )) } @@ -23,7 +24,8 @@ # Capture message captured_message <- suppressWarnings(tryCatch( utils::capture.output(show(object@model), file = NULL), - error = identity)) + error = identity + )) # Check if show generated an error. if (inherits(captured_message, "error")) return(object) @@ -42,17 +44,18 @@ # Add to trimmed functions. object@trimmed_function <- c( object@trimmed_function, - list("show" = captured_message)) + list("show" = captured_message) + ) return(object) } -.replace_broken_functions <- function(object, trimmed_object, timeout = 60000) { +.replace_broken_functions <- function(object, trimmed_object, timeout = 60000.0) { # Find all methods that are trimmable. trimmable_methods <- names(..trim_functions()) - + # Load packages associated with the model into the namespace so that all # associated methods may be found. require_package(object) @@ -64,7 +67,7 @@ # dependent packages. There seems to be an issue with visibility of such # methods when the package is only loaded, not attached. I don't want to # attach packages because that may alter the search space of the user. - if (any(class(object@model) %in% c("mboost"))) { + if (inherits(object@model, "mboost")) { class_methods <- unique(c(class_methods, "varimp")) } @@ -81,12 +84,14 @@ ..replace_broken_function, object = object, trimmed_object = trimmed_object, - timeout = timeout) + timeout = timeout + ) # Get non-null items and add to existing functions. trimmed_object@trimmed_function <- c( trimmed_object@trimmed_function, - replacement_functions[!sapply(replacement_functions, is.null)]) + replacement_functions[!sapply(replacement_functions, is.null)] + ) return(trimmed_object) } @@ -103,7 +108,8 @@ FUN, args = list(object@model), timeout = timeout, - additional_packages = object@package) + additional_packages = object@package + ) # If an error occurs or the project times out the required function is not # considered implemented for the object. @@ -111,11 +117,16 @@ return(NULL) } initial_info <- initial_info$value - + # Attempt to extract the results from the trimmed object. - new_info <- do.call_with_handlers( - FUN, - args = list(trimmed_object@model)) + new_info <- do.call_external( + what = do.call_with_handlers, + args = list( + "what" = FUN, + "args" = list(trimmed_object@model) + ), + additional_packages = object@package + ) # If an error occurs, it means that the information required to create the # function is no longer available due to object trimming, or recreating the @@ -195,7 +206,8 @@ if (exists(current_object, envir = envir, inherits = FALSE)) { remove( list = current_object, - envir = envir) + envir = envir + ) } } } @@ -207,8 +219,10 @@ duplicated_environment <- list2env( as.list.environment(envir, all.names = TRUE, - sorted = FALSE), - parent = parent) + sorted = FALSE + ), + parent = parent + ) return(duplicated_environment) } @@ -229,7 +243,8 @@ x = local_x, old_env = old_env, new_env = new_env, - recursive = recursive) + recursive = recursive + ) # Re-assign to environment. assign(y, local_x, envir = x) @@ -239,12 +254,13 @@ x = x, old_env = old_env, new_env = new_env, - recursive = recursive) + recursive = recursive + ) return(invisible(NULL)) } else if (is.list(x)) { - if (length(x) == 0) return(x) + if (length(x) == 0L) return(x) # Determine class (if any). object_class <- class(x) @@ -265,14 +281,16 @@ x, old_env = old_env, new_env = new_env, - recursive = recursive) + recursive = recursive + ) } return(x) }, old_env = old_env, new_env = new_env, - recursive = recursive) + recursive = recursive + ) class(x) <- object_class diff --git a/R/Utilities.R b/R/Utilities.R index 3c28d55d..fd1a5caa 100644 --- a/R/Utilities.R +++ b/R/Utilities.R @@ -1,20 +1,27 @@ #' @include FamiliarS4Generics.R -stop_or_warn <- function(message, as_error = TRUE) { - # Find the name of the calling environment. - calling_function <- environmentName(parent.env) - - if (length(calling_function) > 0) { - if (calling_function != "") { - message <- paste0(calling_function, ": ", message) - } +stop_or_warn <- function(message, as_error = TRUE, call = rlang::caller_env()) { + if (as_error) { + ..error(message, call = call) + } else { + ..warning(message, call = call) } +} - if (as_error) { - stop(message, call. = FALSE) + + +is.unset <- function(x) { + if (is.null(x)) { + return(TRUE) + } else if (is.waive(x)) { + return(TRUE) + } else if (length(x) == 0L) { + return(TRUE) + } else if (all(is.na(x))) { + return(TRUE) } else { - warning(message, call. = FALSE) + return(FALSE) } } @@ -32,8 +39,6 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { univariate_fun <- .univariate_binomial_logistic_regression_test } else if (outcome_type == "multinomial") { univariate_fun <- .univariate_multinomial_logistic_regression_test - } else if (outcome_type == "count") { - univariate_fun <- .univariate_poisson_regression_test } else if (outcome_type == "competing_risk") { ..error_outcome_type_not_implemented(outcome_type) } else { @@ -48,7 +53,8 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { FUN = univariate_fun, progress_bar = FALSE, outcome_data = data_obj@data[, mget(outcome_columns)], - chopchop = TRUE) + chopchop = TRUE + ) return(coefficient_p_values) } @@ -71,7 +77,7 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { level_names <- levels(x) level_count <- nlevels(x) - x <- lapply(level_names[2:level_count], function(ii, x) (as.numeric(x == ii)), x = x) + x <- lapply(level_names[2L:level_count], function(ii, x) (as.numeric(x == ii)), x = x) } } else { # Numeric variables are only stored as a list. @@ -94,7 +100,7 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Cox regression model for univariate analysis # Check if any data was provided. - if (length(x) == 0) { + if (length(x) == 0L) { return(NA_real_) } @@ -104,7 +110,7 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Remove missing elements. valid_elements <- is.finite(x) & is.finite(y_time) & is.finite(y_event) - if (sum(valid_elements) <= 1) return(NA_real_) + if (sum(valid_elements) <= 1L) return(NA_real_) # Keep only valid elements. x <- x[valid_elements] @@ -119,14 +125,18 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { ..univariate_test_variable_encoding(x, insert_intercept = FALSE), data.table::data.table( "time" = y_time, - "event" = y_event)) + "event" = y_event + ) + ) # Construct model model <- tryCatch( coxph( Surv(time, event) ~ ., - data = data), - error = identity) + data = data + ), + error = identity + ) # Check if the model did not converge. if (inherits(model, "error")) return(NA_real_) @@ -135,10 +145,10 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { z <- .compute_z_statistic(model) # Compute the p-value from a t-distribution - p_value <- 2 * (1.0 - stats::pt(abs(z), df = length(x))) + p_value <- 2.0 * (1.0 - stats::pt(abs(z), df = length(x))) # Check if the value is finite. - if (all(!is.finite(p_value))) return(NA_real_) + if (!any(is.finite(p_value))) return(NA_real_) # Return p-value. return(unname(min(p_value, na.rm = TRUE))) @@ -150,14 +160,14 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Gaussian regression for univariable analysis # Check if any data was provided. - if (length(x) == 0) return(NA_real_) + if (length(x) == 0L) return(NA_real_) # Extract response y <- outcome_data$outcome # Remove missing elements. valid_elements <- is.finite(x) & is.finite(y) - if (sum(valid_elements) <= 1) return(NA_real_) + if (sum(valid_elements) <= 1L) return(NA_real_) # Keep only valid elements. x <- x[valid_elements] @@ -169,7 +179,8 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Bind data. data <- cbind( ..univariate_test_variable_encoding(x, insert_intercept = TRUE), - data.table::data.table("response" = y)) + data.table::data.table("response" = y) + ) if (require_package("fastglm", message_type = "silent")) { # Using fastglm. @@ -183,7 +194,9 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { "x" = as.matrix(data[, mget(predictors)]), "y" = data$response, "family" = stats::gaussian(link = "identity"), - "method" = 3L)) + "method" = 3L + ) + ) # Check for errors. if (!is.null(model$error)) return(NA_real_) @@ -196,8 +209,10 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { model <- tryCatch( stats::glm(response ~ . - 1, data = data, - family = stats::gaussian(link = "identity")), - error = identity) + family = stats::gaussian(link = "identity") + ), + error = identity + ) # Check if the model did not converge. if (inherits(model, "error")) return(NA_real_) @@ -210,85 +225,10 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { z <- z[!names(z) %in% "intercept__"] # Compute the p-value from a t-distribution - p_value <- 2 * (1.0 - stats::pt(abs(z), df = length(x))) + p_value <- 2.0 * (1.0 - stats::pt(abs(z), df = length(x))) # Check if the value is finite. - if (all(!is.finite(p_value))) return(NA_real_) - - # Return p-value. - return(unname(min(p_value, na.rm = TRUE))) -} - - - -.univariate_poisson_regression_test <- function(x, outcome_data) { - # Poisson regression for univariable analysis with count-type outcomes - - # Check if any data was provided. - if (length(x) == 0) return(NA_real_) - - # Extract response - y <- outcome_data$outcome - - # Remove missing elements. - valid_elements <- is.finite(x) & is.finite(y) - if (sum(valid_elements) <= 1) return(NA_real_) - - # Keep only valid elements. - x <- x[valid_elements] - y <- y[valid_elements] - - # Check if the feature column is singular. - if (is_singular_data(x)) return(NA_real_) - - # Bind data. - data <- cbind( - ..univariate_test_variable_encoding(x, insert_intercept = TRUE), - data.table::data.table("response" = y)) - - if (require_package("fastglm", message_type = "silent")) { - # Using fastglm. - predictors <- setdiff(colnames(data), "response") - - # Construct model. - model <- do.call_with_handlers( - fastglm::fastglm, - args = list( - "x" = as.matrix(data[, mget(predictors)]), - "y" = data$response, - "family" = stats::poisson(), - "method" = 3L)) - - # Check for errors. - if (!is.null(model$error)) return(NA_real_) - - # Extract the model itself. - model <- model$value - - } else { - # Using glm as backup option. - model <- suppressWarnings(tryCatch( - stats::glm( - response ~ . - 1, - data = data, - family = stats::poisson(link = "log")), - error = identity)) - - # Check if the model did not converge. - if (inherits(model, "error")) return(NA_real_) - } - - # Compute z-statistic. - z <- .compute_z_statistic(model) - - # Remove intercept (if present). - z <- z[names(z) != "intercept__"] - - # Compute the p-value from a t-distribution - p_value <- 2 * (1.0 - stats::pt(abs(z), df = length(x))) - - # Check if the value is finite. - if (all(!is.finite(p_value))) return(NA_real_) + if (!any(is.finite(p_value))) return(NA_real_) # Return p-value. return(unname(min(p_value, na.rm = TRUE))) @@ -300,14 +240,14 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Binomial model for univariable analysis using logistic regression # Check if any data was provided. - if (length(x) == 0) return(NA_real_) + if (length(x) == 0L) return(NA_real_) # Extract response y <- outcome_data$outcome # Remove missing elements. valid_elements <- is.finite(x) & is.finite(y) - if (sum(valid_elements) <= 1) return(NA_real_) + if (sum(valid_elements) <= 1L) return(NA_real_) # Keep only valid elements. x <- x[valid_elements] @@ -319,7 +259,8 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Bind data. data <- cbind( ..univariate_test_variable_encoding(x, insert_intercept = TRUE), - data.table::data.table("response" = y)) + data.table::data.table("response" = y) + ) if (require_package("fastglm", message_type = "silent")) { # Using fastglm. @@ -332,7 +273,9 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { "x" = as.matrix(data[, mget(predictors)]), "y" = as.numeric(data$response) - 1, "family" = stats::binomial(link = "logit"), - "method" = 3L)) + "method" = 3L + ) + ) # Check for errors. if (!is.null(model$error)) return(NA_real_) @@ -349,7 +292,9 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { "x" = as.matrix(data[, mget(setdiff(predictors, "intercept__"))]), "y" = as.numeric(data$response) - 1, "family" = stats::binomial(link = "logit"), - "method" = 3L)) + "method" = 3L + ) + ) # Check for errors, and only attempt to replace model by model_2 if no # errors are present. @@ -368,8 +313,10 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { stats::glm( response ~ . - 1, data = data, - family = stats::binomial(link = "logit")), - error = identity)) + family = stats::binomial(link = "logit") + ), + error = identity + )) # Check if the model did not converge if (inherits(model, "error")) return(NA_real_) @@ -382,10 +329,10 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { z <- z[names(z) != "intercept__"] # Compute the p-value from a t-distribution - p_value <- 2 * (1.0 - stats::pt(abs(z), df = length(x))) + p_value <- 2.0 * (1.0 - stats::pt(abs(z), df = length(x))) # Check if the value is finite. - if (all(!is.finite(p_value))) return(NA_real_) + if (!any(is.finite(p_value))) return(NA_real_) # Return p-value. return(unname(min(p_value, na.rm = TRUE))) @@ -397,14 +344,14 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Multinomial model for univariable analysis using logistic regression # Check if any data was provided. - if (length(x) == 0) return(NA_real_) + if (length(x) == 0L) return(NA_real_) # Extract response y <- outcome_data$outcome # Remove missing elements. valid_elements <- is.finite(x) & is.finite(y) - if (sum(valid_elements) <= 1) return(NA_real_) + if (sum(valid_elements) <= 1L) return(NA_real_) # Keep only valid elements. x <- x[valid_elements] @@ -416,12 +363,14 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Bind data. data <- cbind( ..univariate_test_variable_encoding(x, insert_intercept = TRUE), - data.table::data.table("response" = y)) + data.table::data.table("response" = y) + ) # Check if the package is installed and attached. require_package( x = "nnet", - purpose = "to determine univariate p-values for multinomial outcomes") + purpose = "to determine univariate p-values for multinomial outcomes" + ) # Construct model model <- do.call_with_handlers( @@ -429,7 +378,9 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { args = list( response ~ . - 1, "data" = data, - "maxit" = 500)) + "maxit" = 500L + ) + ) # Check for errors. if (!is.null(model$error)) return(NA_real_) @@ -439,13 +390,15 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # Check if the model converged. NNET might fail to converge if the # Hauck-Donner effect is present. - if (model$convergence == 1) { + if (model$convergence == 1L) { model_2 <- do.call_with_handlers( nnet::multinom, args = list( response ~ . - 1 - intercept__, "data" = data, - "maxit" = 500)) + "maxit" = 500L + ) + ) # Check for errors, and only attempt to replace model by model_2 if no # errors are present. @@ -455,7 +408,7 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { # If the Hauck-Donner effect is indeed present, the new model without the # intercept should converge quickly. - if (model_2$convergence == 0) model <- model_2 + if (model_2$convergence == 0L) model <- model_2 } } @@ -467,10 +420,10 @@ compute_univariable_p_values <- function(cl = NULL, data_obj, feature_columns) { z <- if (is.matrix(z)) as.vector(z[, predictors]) else z[predictors] # Compute the p-value from a t-distribution - p_value <- 2 * (1.0 - stats::pt(abs(z), df = length(x) * (nlevels(y) - 1L))) + p_value <- 2.0 * (1.0 - stats::pt(abs(z), df = length(x) * (nlevels(y) - 1L))) # Check if the value is finite. - if (all(!is.finite(p_value))) return(NA_real_) + if (!any(is.finite(p_value))) return(NA_real_) # Return p-value. return(unname(min(p_value, na.rm = TRUE))) @@ -527,105 +480,105 @@ compute_icc <- function(x, feature, id_data, type = "1") { # Calculate mean squared errors: msb between subjects (bj), msj between raters # (ai), mse of error (eij) and msw of error with rater (ai + eij). - if (n_samples > 1) { - msb <- sum(data$bj^2, na.rm = TRUE) / (n_samples - 1) + if (n_samples > 1L) { + msb <- sum(data$bj^2.0, na.rm = TRUE) / (n_samples - 1.0) } if (type == "1") { # Calculate mean squared of error with rater - msw <- (sum(data$eij^2, na.rm = TRUE) + sum(data$ai^2, na.rm = TRUE)) / - (n_samples * (n_raters - 1)) + msw <- (sum(data$eij^2.0, na.rm = TRUE) + sum(data$ai^2.0, na.rm = TRUE)) / + (n_samples * (n_raters - 1.0)) # Calculate icc for individual rater and rater panel - if (msb == 0 && msw == 0) { - icc <- 1 - icc_panel <- 1 - icc_ci_low <- 1 - icc_ci_up <- 1 - icc_panel_ci_low <- 1 - icc_panel_ci_up <- 1 + if (msb == 0.0 && msw == 0.0) { + icc <- 1.0 + icc_panel <- 1.0 + icc_ci_low <- 1.0 + icc_ci_up <- 1.0 + icc_panel_ci_low <- 1.0 + icc_panel_ci_up <- 1.0 } else { - icc <- (msb - msw) / (msb + (n_raters - 1) * msw) + icc <- (msb - msw) / (msb + (n_raters - 1.0) * msw) icc_panel <- (msb - msw) / msb # Fisher score s_fisher <- msb / msw - s_fisher_low <- s_fisher / stats::qf(0.975, n_samples - 1, n_samples * (n_raters - 1)) - s_fisher_up <- s_fisher / stats::qf(0.025, n_samples - 1, n_samples * (n_raters - 1)) + s_fisher_low <- s_fisher / stats::qf(0.975, n_samples - 1L, n_samples * (n_raters - 1L)) + s_fisher_up <- s_fisher / stats::qf(0.025, n_samples - 1L, n_samples * (n_raters - 1L)) # Calcuate confidence intervals from fisher score - icc_ci_low <- (s_fisher_low - 1) / (s_fisher_low + n_raters - 1) - icc_ci_up <- (s_fisher_up - 1) / (s_fisher_up + n_raters - 1) - icc_panel_ci_low <- 1 - 1 / s_fisher_low - icc_panel_ci_up <- 1 - 1 / s_fisher_up + icc_ci_low <- (s_fisher_low - 1.0) / (s_fisher_low + n_raters - 1.0) + icc_ci_up <- (s_fisher_up - 1.0) / (s_fisher_up + n_raters - 1.0) + icc_panel_ci_low <- 1.0 - 1.0 / s_fisher_low + icc_panel_ci_up <- 1.0 - 1.0 / s_fisher_up } } if (type == "2") { # Calculate mean squared error (mse) and mean squared rater error (msj) - msj <- sum(data$ai^2, na.rm = TRUE) / (n_raters - 1) - mse <- sum(data$eij^2, na.rm = TRUE) / ((n_samples - 1) * (n_raters - 1)) + msj <- sum(data$ai^2.0, na.rm = TRUE) / (n_raters - 1.0) + mse <- sum(data$eij^2.0, na.rm = TRUE) / ((n_samples - 1.0) * (n_raters - 1.0)) # Calculate icc for individual rater and rater panel - if (msb == 0 && mse == 0) { - icc <- 1 - icc_panel <- 1 - icc_ci_low <- 1 - icc_ci_up <- 1 - icc_panel_ci_low <- 1 - icc_panel_ci_up <- 1 + if (msb == 0.0 && mse == 0.0) { + icc <- 1.0 + icc_panel <- 1.0 + icc_ci_low <- 1.0 + icc_ci_up <- 1.0 + icc_panel_ci_low <- 1.0 + icc_panel_ci_up <- 1.0 } else { - icc <- (msb - mse) / (msb + (n_raters - 1) * mse + (n_raters / n_samples) * (msj - mse)) + icc <- (msb - mse) / (msb + (n_raters - 1.0) * mse + (n_raters / n_samples) * (msj - mse)) icc_panel <- (msb - mse) / (msb + (msj - mse) / n_samples) # Determine confidence intervals - vn <- (n_raters - 1) * (n_samples - 1) * - (n_raters * icc * msj / mse + n_samples * (1 + (n_raters - 1) * icc) - n_raters * icc)^2 - vd <- (n_samples - 1) * n_raters^2 * icc^2 * (msj / mse)^2 + - (n_samples * (1 + (n_raters - 1) * icc) - n_raters * icc)^2 + vn <- (n_raters - 1.0) * (n_samples - 1.0) * + (n_raters * icc * msj / mse + n_samples * (1.0 + (n_raters - 1.0) * icc) - n_raters * icc)^2.0 + vd <- (n_samples - 1.0) * n_raters^2.0 * icc^2.0 * (msj / mse)^2.0 + + (n_samples * (1.0 + (n_raters - 1.0) * icc) - n_raters * icc)^2.0 v <- vn / vd - thresh_low <- stats::qf(0.975, n_samples - 1, v) - thresh_up <- stats::qf(0.025, n_samples - 1, v) + thresh_low <- stats::qf(0.975, n_samples - 1L, v) + thresh_up <- stats::qf(0.025, n_samples - 1L, v) # Calcuate confidence intervals from fisher score icc_ci_low <- n_samples * (msb - thresh_low * mse) / (thresh_low * (n_raters * msj + (n_raters * n_samples - n_raters - n_samples) * mse) + n_samples * msb) icc_ci_up <- n_samples * (msb - thresh_up * mse) / (thresh_up * (n_raters * msj + (n_raters * n_samples - n_raters - n_samples) * mse) + n_samples * msb) - icc_panel_ci_low <- icc_ci_low * n_raters / (1 + icc_ci_low * (n_raters - 1)) - icc_panel_ci_up <- icc_ci_up * n_raters / (1 + icc_ci_up * (n_raters - 1)) + icc_panel_ci_low <- icc_ci_low * n_raters / (1.0 + icc_ci_low * (n_raters - 1.0)) + icc_panel_ci_up <- icc_ci_up * n_raters / (1.0 + icc_ci_up * (n_raters - 1.0)) } } if (type == "3") { # Calculate mean squared error (mse) - mse <- sum(data$eij^2, na.rm = TRUE) / ((n_samples - 1) * (n_raters - 1)) + mse <- sum(data$eij^2.0, na.rm = TRUE) / ((n_samples - 1.0) * (n_raters - 1.0)) # Calculate icc for individual rater and rater panel - if (msb == 0 && mse == 0) { - icc <- 1 - icc_panel <- 1 - icc_ci_low <- 1 - icc_ci_up <- 1 - icc_panel_ci_low <- 1 - icc_panel_ci_up <- 1 + if (msb == 0.0 && mse == 0.0) { + icc <- 1.0 + icc_panel <- 1.0 + icc_ci_low <- 1.0 + icc_ci_up <- 1.0 + icc_panel_ci_low <- 1.0 + icc_panel_ci_up <- 1.0 } else { - icc <- (msb - mse) / (msb + (n_raters - 1) * mse) + icc <- (msb - mse) / (msb + (n_raters - 1.0) * mse) icc_panel <- (msb - mse) / msb # Fisher score s_fisher <- msb / mse - s_fisher_low <- s_fisher / stats::qf(0.975, n_samples - 1, (n_samples - 1) * (n_raters - 1)) - s_fisher_up <- s_fisher / stats::qf(0.025, n_samples - 1, (n_samples - 1) * (n_raters - 1)) + s_fisher_low <- s_fisher / stats::qf(0.975, n_samples - 1L, (n_samples - 1L) * (n_raters - 1L)) + s_fisher_up <- s_fisher / stats::qf(0.025, n_samples - 1L, (n_samples - 1L) * (n_raters - 1L)) # Calcuate confidence intervals from fisher score - icc_ci_low <- (s_fisher_low - 1) / (s_fisher_low + n_raters - 1) - icc_ci_up <- (s_fisher_up - 1) / (s_fisher_up + n_raters - 1) - icc_panel_ci_low <- 1 - 1 / s_fisher_low - icc_panel_ci_up <- 1 - 1 / s_fisher_up + icc_ci_low <- (s_fisher_low - 1.0) / (s_fisher_low + n_raters - 1.0) + icc_ci_up <- (s_fisher_up - 1.0) / (s_fisher_up + n_raters - 1.0) + icc_panel_ci_low <- 1.0 - 1.0 / s_fisher_low + icc_panel_ci_up <- 1.0 - 1.0 / s_fisher_up } } @@ -646,7 +599,8 @@ compute_icc <- function(x, feature, id_data, type = "1") { "icc_up" = icc_ci_up, "icc_panel" = icc_panel, "icc_panel_low" = icc_panel_ci_low, - "icc_panel_up" = icc_panel_ci_up)) + "icc_panel_up" = icc_panel_ci_up + )) } @@ -657,11 +611,12 @@ compute_icc <- function(x, feature, id_data, type = "1") { # Find the position of the period preceding the file extension. indicator <- tail( - gregexpr(pattern = ".", text = x, fixed = TRUE)[[1]], - n = 1L) + gregexpr(pattern = ".", text = x, fixed = TRUE)[[1L]], + n = 1L + ) # Check when period (.) is not found in x. - if (indicator == -1) return("") + if (indicator == -1L) return("") # Find the extension extension <- substr(x, start = indicator + 1L, stop = nchar(x)) @@ -678,13 +633,13 @@ harmonic_p_value <- function(x) { x <- x$p_value # Fix numeric issues due to very small p-values. - x[x < 1E-15] <- 1E-15 + x[x < 1.0E-15] <- 1.0E-15 return(list("p_value" = harmonicmeanp::p.hmp(x, L = length(x)))) } else { # Fix numeric issues due to very small p-values. - x[x < 1E-15] <- 1E-15 + x[x < 1.0E-15] <- 1.0E-15 return(harmonicmeanp::p.hmp(x, L = length(x))) } @@ -709,7 +664,7 @@ get_estimate <- function(x, na.rm = TRUE) { if (is.numeric(x)) { # Determine the estimate. - if (length(x) > 0) { + if (length(x) > 0L) { y <- mean(x) } else { y <- NA_real_ @@ -717,7 +672,7 @@ get_estimate <- function(x, na.rm = TRUE) { } else { # Determine the estimate. - if (length(x) > 0) { + if (length(x) > 0L) { y <- get_mode(x) } else { y <- NA @@ -731,7 +686,7 @@ get_estimate <- function(x, na.rm = TRUE) { .sanitise_dots <- function(class, ...) { dots <- list(...) - if (length(dots) == 0) return(dots) + if (length(dots) == 0L) return(dots) slot_names <- names(methods::getSlots(class)) @@ -742,11 +697,13 @@ get_estimate <- function(x, na.rm = TRUE) { get_placeholder_vimp_table <- function( vimp_method, - run_table = NULL) { + run_table = NULL +) { # Set vimp method. vimp_object <- methods::new( "vimpTable", - vimp_method = vimp_method) + vimp_method = vimp_method + ) # Set run table. vimp_object@run_table <- run_table @@ -765,7 +722,8 @@ get_id_columns <- function(id_depth = "repetition", single_column = NULL) { ..error_value_not_allowed( x = id_depth, var_name = "id_depth", - values = c("batch", "sample", "series", "repetition")) + values = c("batch", "sample", "series", "repetition") + ) } if (is.null(single_column)) { @@ -775,7 +733,8 @@ get_id_columns <- function(id_depth = "repetition", single_column = NULL) { "batch" = "batch_id", "sample" = c("batch_id", "sample_id"), "series" = c("batch_id", "sample_id", "series_id"), - "repetition" = c("batch_id", "sample_id", "series_id", "repetition_id")) + "repetition" = c("batch_id", "sample_id", "series_id", "repetition_id") + ) } else { id_columns <- switch( @@ -783,7 +742,8 @@ get_id_columns <- function(id_depth = "repetition", single_column = NULL) { "batch" = "batch_id", "sample" = "sample_id", "series" = "series_id", - "repetition" = "repetition_id") + "repetition" = "repetition_id" + ) } return(id_columns) @@ -792,72 +752,109 @@ get_id_columns <- function(id_depth = "repetition", single_column = NULL) { get_object_file_name <- function( - learner, - fs_method, project_id, - data_id, - run_id, - pool_data_id = NULL, - pool_run_id = NULL, + data_id = NULL, + run_id = NULL, + ensemble_data_id = NULL, + ensemble_run_id = NULL, + learner = NULL, + vimp_method = NULL, + name = NULL, object_type, - is_ensemble = NULL, - is_validation = NULL, with_extension = TRUE, - dir_path = NULL) { - # Generate file name for an object - - if (!object_type %in% c("familiarModel", "familiarEnsemble", "familiarData")) { - stop("The object type was not recognised.") - } - - # Generate the basic string - base_str <- paste0( - project_id, "_", - learner, "_", - fs_method, "_", - data_id, "_", - run_id) + dir_path = NULL +) { if (object_type == "familiarModel") { # For familiarModel objects - output_str <- paste0(base_str, "_model") + if (is.null(learner) || is.null(vimp_method)) { + ..error_reached_unreachable_code("missing arguments") + } - } else if (object_type == "familiarEnsemble") { - # For familiarEnsemble objects - - if (is.null(is_ensemble)) { - stop("The \"is_ensemble\" parameter is not set to TRUE or FALSE.") + output_str <- c(project_id, learner, vimp_method, data_id, run_id, "model") + + } else if (object_type == "familiarNoveltyDetector") { + # For familiarNoveltyDetector objects + + if (is.null(learner) || is.null(vimp_method)) { + ..error_reached_unreachable_code("missing arguments") } - - output_str <- paste0( - base_str, "_", - ifelse(is_ensemble, "ensemble", "pool")) + + output_str <- c(project_id, learner, vimp_method, data_id, run_id, "detector") } else if (object_type == "familiarData") { # For familiarData objects - if (is.null(is_ensemble)) { - stop("The \"is_ensemble\" parameter is not set to TRUE or FALSE.") + if ( + is.null(learner) || is.null(vimp_method) || + is.null(data_id) || is.null(run_id) || is.null(name) || + is.null(ensemble_data_id) || is.null(ensemble_run_id) + ) { + ..error_reached_unreachable_code("missing arguments") } - if (is.null(is_validation)) { - stop("The \"is_validation\" parameter is not set to TRUE or FALSE.") + output_str <- c( + project_id, learner, vimp_method, data_id, run_id, ensemble_data_id, ensemble_run_id, name, "data" + ) + + } else if (object_type == "familiarCollection") { + + if ( + ((is.null(data_id) || is.null(run_id)) && is.null(name)) + ) { + ..error_reached_unreachable_code("missing arguments") } - - if (is.null(pool_data_id) || is.null(pool_run_id)) { - stop() + + output_str <- c(project_id) + if (is.null(name)) { + output_str <- c(output_str, data_id, run_id) + } else { + output_str <- c(output_str, name) } - - output_str <- paste0( - base_str, "_", - ifelse(is_ensemble, "ensemble", "pool"), "_", - pool_data_id, "_", - pool_run_id, "_", - ifelse(is_validation, "validation", "development"), "_data" - ) + + output_str <- c(output_str, "collection") + + } else if (object_type == "vimpTable") { + + if (is.null(vimp_method)) { + ..error_reached_unreachable_code("missing arguments") + } + + output_str <- c(project_id, vimp_method, data_id, run_id, "vimp") + + } else if (object_type == "featureInfo") { + # Complete feature info objects. + output_str <- c(project_id, data_id, run_id, "feature_info") + + } else if (object_type == "genericFeatureInfo") { + # Generic feature info objects. + output_str <- c(project_id, "generic_feature_info") + + } else if (object_type == "hyperparametersVimp") { + + if (is.null(vimp_method)) { + ..error_reached_unreachable_code("missing arguments") + } + + output_str <- c(project_id, data_id, run_id, vimp_method, "vimp_hyperparameters") + + } else if (object_type == "hyperparametersLearner") { + + if (is.null(vimp_method) || is.null(learner)) { + ..error_reached_unreachable_code("missing arguments") + } + + output_str <- c(project_id, data_id, run_id, learner, vimp_method, "learner_hyperparameters") + + } else { + ..error_reached_unreachable_code(paste0("unknown object_type: ", object_type)) } + # Strip any NA entries, and collapse to single string. + output_str <- output_str[!is.na(output_str)] + output_str <- paste(output_str, collapse = "_") + # Add extension if (with_extension) { output_str <- paste0(output_str, ".RDS") @@ -877,19 +874,21 @@ get_object_dir_path <- function( dir_path, object_type, learner = NULL, - fs_method = NULL) { + vimp_method = NULL +) { # Generate the directory path to an object if (!object_type %in% c( - "familiarModel", "familiarEnsemble", "familiarData", "familiarCollection")) { - stop("The object type was not recognised.") + "familiarModel", "familiarEnsemble", "familiarData", "familiarCollection" + )) { + ..error("The object type was not recognised.") } if (object_type %in% c("familiarModel", "familiarEnsemble")) { - if (is.null(learner) && is.null(fs_method)) { + if (is.null(learner) && is.null(vimp_method)) { return(normalizePath(file.path(dir_path), mustWork = FALSE)) } else { - return(normalizePath(file.path(dir_path, learner, fs_method), mustWork = FALSE)) + return(normalizePath(file.path(dir_path, learner, vimp_method), mustWork = FALSE)) } } else if (object_type %in% c("familiarData", "familiarCollection")) { @@ -902,7 +901,8 @@ extract_from_slot <- function( object_list, slot_name, slot_element = NULL, - na.rm = FALSE) { + na.rm = FALSE +) { # Extracts values from a slot in an object. Providing slot_element allows # extraction from a list in a slot @@ -921,7 +921,8 @@ extract_from_slot <- function( } }, slot_name = slot_name, - slot_element = slot_element) + slot_element = slot_element + ) } if (na.rm) { @@ -929,9 +930,11 @@ extract_from_slot <- function( slot_values <- slot_values[!sapply(slot_values, is.null)] # Then remove NA - if (is.numeric(slot_values) || - is.logical(slot_values) || - is.character(slot_values)) { + if ( + is.numeric(slot_values) || + is.logical(slot_values) || + is.character(slot_values) + ) { slot_values <- slot_values[!sapply(slot_values, is.na)] } @@ -954,143 +957,23 @@ all_empty_slot <- function(object_list, slot_name, slot_element = NULL) { object_list = object_list, slot_name = slot_name, slot_element = slot_element, - na.rm = TRUE) + na.rm = TRUE + ) # Determine if there are any slot values that have a value. - return(length(slot_values) == 0) + return(length(slot_values) == 0L) } -process_random_forest_survival_predictions <- function( - event_matrix, - event_times, - prediction_table, - time, - type) { - # Suppress NOTES due to non-standard evaluation in data.table - event_time <- NULL - - # Set id columns - id_columns <- get_id_columns() - - # Make a local copy of the prediction_table - prediction_table <- data.table::copy(prediction_table) - # Convert event_matrix to a matrix. - if (!is.matrix(event_matrix)) { - event_matrix <- matrix( - data = event_matrix, - ncol = length(event_matrix)) - } - - # Combine with identifiers and cast to table. - event_table <- cbind( - prediction_table[, mget(id_columns)], - data.table::as.data.table(event_matrix)) - - # Remove duplicate entries - event_table <- unique(event_table, by = id_columns) - - # Melt to a long format. - event_table <- data.table::melt( - event_table, - id.vars = id_columns, - variable.name = "time_variable", - value.name = "value") - - # Create conversion table to convert temporary variables into the event times. - conversion_table <- data.table::data.table( - "time_variable" = paste0("V", seq_along(event_times)), - "event_time" = event_times) - - # Add in event times - event_table <- merge( - x = event_table, - y = conversion_table, - by = "time_variable") - - # Drop the time_variable column - event_table[, "time_variable" := NULL] - - if (time %in% event_times) { - # Get the event time directly. - event_table <- event_table[event_time == time, ] - - # Remove event_time column and rename the value column to predicted_outcome. - event_table[, "event_time" := NULL] - data.table::setnames( - x = event_table, - old = "value", - new = "predicted_outcome") - - } else { - # Add starting values. - if (!0 %in% event_times) { - # Create initial table - initial_event_table <- data.table::copy(event_table[event_time == event_times[1]]) - - # Update values - if (type == "cumulative_hazard") { - initial_event_table[, ":="("value" = 0.0, "event_time" = 0)] - } else if (type == "survival") { - initial_event_table[, ":="("value" = 1.0, "event_time" = 0)] - } else { - ..error_reached_unreachable_code(paste0( - "process_random_forest_survival_predictions: type was not recognised: ", - type)) - } - - # Combine with the event table. - event_table <- rbind(initial_event_table, event_table) - } - - # Now, interpolate at the given time point. - event_table <- lapply( - split(event_table, by = id_columns), - function(sample_table, time, id_columns) { - # Interpolate values at the given time. - value <- stats::approx( - x = sample_table$event_time, - y = sample_table$value, - xout = time, - rule = 2 - )$y - - # Create an output table - output_table <- data.table::copy(sample_table[1, mget(id_columns)]) - output_table[, "predicted_outcome" := value] - - return(output_table) - }, - time = time, - id_columns = id_columns) - - # Concatenate to single table. - event_table <- data.table::rbindlist(event_table) - } - - if (type == "cumulative_hazard") { - # Remove predicted_outcome from the prediction table. - prediction_table[, "predicted_outcome" := NULL] +.optional_from_slot <- function(object, slot_name, alternative = NULL) { + + if (methods::.hasSlot(object, slot_name)) { + return(methods::slot(object, slot_name)) } else { - # Remove survival_probability from the prediction table. - prediction_table[, "survival_probability" := NULL] - - # Update response column. - data.table::setnames( - event_table, - old = "predicted_outcome", - new = "survival_probability") + return(alternative) } - - # Merge the event table into the prediction table. - prediction_table <- merge( - x = prediction_table, - y = event_table, - by = id_columns) - - return(prediction_table) } @@ -1101,20 +984,20 @@ is_singular_data <- function(x) { # Drop any NA data. x <- x[!is.na(x)] - if (length(x) <= 1) return(TRUE) + if (length(x) <= 1L) return(TRUE) if (any(class_x %in% "factor")) { - return(length(levels(droplevels(x))) == 1) + return(nlevels(droplevels(x)) == 1L) } else if (any(class_x %in% c("numeric", "integer", "logical"))) { # Drop any infinite data x <- x[is.finite(x)] - if (length(x) <= 1) return(TRUE) + if (length(x) <= 1L) return(TRUE) - return(stats::var(x, na.rm = TRUE) == 0) + return(stats::var(x, na.rm = TRUE) == 0.0) } else if (any(class_x %in% c("character"))) { - return(length(unique(x)) == 1) + return(length(unique(x)) == 1L) } else { return(TRUE) @@ -1155,7 +1038,8 @@ is_valid_data <- function(x) { # namespace) methods for an object. associated_methods <- c( associated_methods, - attr(utils::methods(class = object_class), "info")$generic) + attr(utils::methods(class = object_class), "info")$generic + ) } # Keep only unique methods. @@ -1186,17 +1070,14 @@ is_valid_data <- function(x) { if (is(model, "vglm")) { # Check if the package is installed and attached. - require_package( - x = "VGAM", - purpose = "to determine z-scores for multinomial regression models") - - if (is.null(mu)) mu <- VGAM::coefvlm(model) - if (is.null(cov_matrix)) cov_matrix <- VGAM::vcovvlm(model) + ..deprecation_vgam() + return(NULL) } else if (inherits(model, "fastglm")) { require_package( x = "fastglm", - purpose = "to determine z-scores for generalised linear regression models") + purpose = "to determine z-scores for generalised linear regression models" + ) if (is.null(mu)) mu <- stats::coef(model) @@ -1230,7 +1111,7 @@ is_valid_data <- function(x) { # Compute z-score z <- mu / stdevs - if (fix_all_missing && all(!is.finite(z))) z <- mu + if (fix_all_missing && !any(is.finite(z))) z <- mu # Return z-score, as p-values can become very small. return(abs(z)) @@ -1243,7 +1124,8 @@ is_any <- function(object, class2) { return(any(sapply( class2, function(class, object) is(object, class2 = class), - object = object))) + object = object + ))) } @@ -1251,31 +1133,39 @@ is_any <- function(object, class2) { fivenum_summary <- function(x, na.rm = FALSE) { # Compute fivenumber summary y <- stats::fivenum(x = x, na.rm = na.rm) - + # Return as data.table return(data.table::data.table( - "min" = y[1], - "Q1" = y[2], - "median" = y[3], - "Q3" = y[4], - "max" = y[5])) + "min" = y[1L], + "Q1" = y[2L], + "median" = y[3L], + "Q3" = y[4L], + "max" = y[5L] + )) +} + + + +get_percentiles <- function(n) { + return((seq_len(n) - 1.0 / 3.0) / (n + 1.0 / 3.0)) } trim <- function(x, fraction = 0.1) { if (fraction < 0.0 || fraction > 0.5) { - stop("Trimming fraction should be between 0.0 and 0.5.") + ..error("Trimming fraction should be between 0.0 and 0.5.") } # Determine thresholds based on fraction. threshold <- stats::quantile( x = x, - probs = c(fraction, 1 - fraction), - na.rm = TRUE) + probs = c(fraction, 1.0 - fraction), + na.rm = TRUE + ) # Set mask - x_mask <- x >= threshold[1] & x <= threshold[2] + x_mask <- x >= threshold[1L] & x <= threshold[2L] # Return trimmed array return(x[x_mask]) @@ -1285,18 +1175,19 @@ trim <- function(x, fraction = 0.1) { winsor <- function(x, fraction = 0.1) { if (fraction < 0.0 || fraction > 0.5) { - stop("Winsoring fraction should be between 0.0 and 0.5.") + ..error("Winsoring fraction should be between 0.0 and 0.5.") } # Determine thresholds based on fraction. threshold <- stats::quantile( x = x, - probs = c(fraction, 1 - fraction), - na.rm = TRUE) + probs = c(fraction, 1.0 - fraction), + na.rm = TRUE + ) # Values outside valid range are assigned edge values - x[x < threshold[1]] <- threshold[1] - x[x > threshold[2]] <- threshold[2] + x[x < threshold[1L]] <- threshold[1L] + x[x > threshold[2L]] <- threshold[2L] return(x) } @@ -1390,7 +1281,7 @@ is_subclass <- function(class_1, class_2) { # The classes are ordered by distance. Therefore class 2 cannot be a subclass # of class 1 if it is less distant. - if (extending_classes[1] == class_2) return(FALSE) + if (extending_classes[1L] == class_2) return(FALSE) return(TRUE) } @@ -1408,18 +1299,21 @@ is_subclass <- function(class_1, class_2) { "normalisation", "batch_normalisation", "imputation", - "clustering") + "clustering" + ) if (!all(x %in% preprocessing_levels)) { ..error_reached_unreachable_code(paste0( ".as_preprocessing_level: one or more of x could not be matched to ", - "preprocessing levels.")) + "preprocessing levels." + )) } return(factor( x = x, levels = preprocessing_levels, - ordered = TRUE)) + ordered = TRUE + )) } @@ -1448,7 +1342,8 @@ is_subclass <- function(class_1, class_2) { return(element_content) }, x = x, - flatten = flatten) + flatten = flatten + ) names(flattened_list) <- element_names @@ -1478,16 +1373,16 @@ near <- function(x, y, df = 2.0, tol = .Machine$double.eps) { # value in y. .near <- function(x, tol) (x <= tol) - if (length(x) != length(y) && length(y) != 1) { - stop("x and y should have the same length, or y should be a single value.") + if (length(x) != length(y) && length(y) != 1L) { + ..error("x and y should have the same length, or y should be a single value.") } if (!is.numeric(x)) { - stop("x should be a numeric value.") + ..error("x should be a numeric value.") } if (!is.numeric(y)) { - stop("y should be a numeric value.") + ..error("y should be a numeric value.") } return(sapply(abs(x - y), .near, tol = df * tol)) @@ -1505,7 +1400,8 @@ approximately <- function(x, y, tol = sqrt(.Machine$double.eps)) { x = x, y = y, df = 1.0, - tol = tol)) + tol = tol + )) } @@ -1525,7 +1421,7 @@ huber_estimate <- function(x, k = 1.28, tol = 1E-4) { x <- winsor(x, fraction = 0.10) x <- x[is.finite(x)] - if(length(x) <= 1) { + if (length(x) <= 1L) { return(list("mu" = NA_real_, "sigma" = NA_real_)) } @@ -1534,3 +1430,36 @@ huber_estimate <- function(x, k = 1.28, tol = 1E-4) { return(x) } + + + +matrix_pseudo_inverse <- function(x, tol = sqrt(.Machine$double.eps)) { + # Compute matrix Moore-Penrose pseudo-inverse of x using singular value + # decomposition. + + # Compute single value decomposition. + svd_decomp <- svd(x) + + # Find all positive values in the vector of singular values d. + positive <- svd_decomp$d > max(tol * svd_decomp$d[1L], 0.0) + + if (!any(positive)) { + return(matrix(0.0, nrow = ncol(x), ncol = nrow(x))) + + } else { + return( + svd_decomp$v[, positive, drop = FALSE] %*% + ((1.0 / svd_decomp$d[positive]) * t(svd_decomp$u[, positive, drop = FALSE])) + ) + } +} + + + +fam_cut <- function(x, n) { + if (n > 1L) { + return(cut(x, n, labels = FALSE)) + } + # n = 1 + return(rep.int(1L, length(x))) +} diff --git a/R/UtilitiesS4.R b/R/UtilitiesS4.R index 481586f9..d6b10b1e 100644 --- a/R/UtilitiesS4.R +++ b/R/UtilitiesS4.R @@ -15,7 +15,7 @@ setMethod( "is_empty", signature(x = "data.table"), function(x, ...) { - return(ncol(x) == 0 || nrow(x) == 0) + return(ncol(x) == 0L || nrow(x) == 0L) } ) @@ -23,7 +23,7 @@ setMethod( "is_empty", signature(x = "character"), function(x, ...) { - if (length(x) == 0) { + if (length(x) == 0L) { return(TRUE) } else if (all(x == "")) { return(TRUE) @@ -37,13 +37,10 @@ setMethod( "is_empty", signature(x = "dataObject"), function(x, allow_no_features = FALSE, ...) { - if (x@delay_loading) { - # Data is not empty until is has been properly loaded - return(FALSE) - } else if (is.null(x@data)) { + if (is.null(x@data)) { # Data is empty if it is NULL return(TRUE) - } else if (nrow(x@data) == 0) { + } else if (nrow(x@data) == 0L) { # Data is empty if the data table has no rows return(TRUE) } else if (!allow_no_features && !has_feature_data(x)) { @@ -56,11 +53,20 @@ setMethod( } ) +setMethod( + "is_empty", + signature(x = "delayedDataObject"), + function(x, ...) { + # Data is not empty until is has been properly loaded + return(FALSE) + } +) + setMethod( "is_empty", signature(x = "list"), function(x, ...) { - return(length(x) == 0) + return(length(x) == 0L) } ) @@ -76,7 +82,7 @@ setMethod( "is_empty", signature(x = "vector"), function(x, ...) { - return(length(x) == 0) + return(length(x) == 0L) } ) @@ -98,7 +104,7 @@ setMethod( if (x@outcome_type %in% c("binomial", "multinomial")) { return(as.character(x@levels)) } else { - return(character(0)) + return(character(0L)) } } ) @@ -128,8 +134,8 @@ setMethod("get_outcome_class_levels", signature(x = "dataObject"), function(x) { }) .get_outcome_class_levels <- function(data, outcome_type) { - if (outcome_type %in% c("survival", "continuous", "count", "competing_risk")) { - return(character(0)) + if (outcome_type %in% c("survival", "continuous", "competing_risk")) { + return(character(0L)) } else if (outcome_type %in% c("binomial", "multinomial")) { return(as.character(levels(data[[get_outcome_columns(x = outcome_type)]]))) @@ -196,6 +202,7 @@ setMethod( # Pass to the method for character strings. return(get_class_probability_name(x = class_levels)) + } else { return(NULL) } @@ -208,7 +215,8 @@ setMethod( function(x) { # Create column names class_probability_columns <- .replace_illegal_column_name( - column_name = paste0("predicted_class_probability_", x)) + column_name = paste0("predicted_class_probability_", x) + ) return(class_probability_columns) } @@ -266,7 +274,7 @@ setMethod("get_outcome_columns", signature(x = "familiarEnsemble"), function(x) if (outcome_type %in% c("survival")) { outcome_cols <- c("outcome_time", "outcome_event") - } else if (outcome_type %in% c("binomial", "multinomial", "continuous", "count")) { + } else if (outcome_type %in% c("binomial", "multinomial", "continuous")) { outcome_cols <- c("outcome") } else if (outcome_type == "unsupervised") { @@ -330,27 +338,37 @@ setMethod("get_non_feature_columns", signature(x = "familiarEnsemble"), function # get_feature_columns----------------------------------------------------------- -setMethod("get_feature_columns", signature(x = "data.table"), function(x, outcome_type) { - return(.get_feature_columns( - column_names = colnames(x), - outcome_type = outcome_type)) -}) +setMethod( + "get_feature_columns", + signature(x = "data.table"), + function(x, outcome_type) { + return(.get_feature_columns( + column_names = colnames(x), + outcome_type = outcome_type + )) + } +) -setMethod("get_feature_columns", signature(x = "dataObject"), function(x) { - return(.get_feature_columns( - column_names = colnames(x@data), - outcome_type = x@outcome_type)) -}) +setMethod( + "get_feature_columns", + signature(x = "dataObject"), + function(x) { + return(.get_feature_columns( + column_names = colnames(x@data), + outcome_type = x@outcome_type + )) + } +) # Internal function .get_feature_columns <- function(column_names, outcome_type) { if (is.null(column_names)) { # Return 0-length character in case column_names is NULL. - return(character(0)) + return(character(0L)) - } else if (length(column_names) == 0) { + } else if (length(column_names) == 0L) { # Return 0-length character in case column_names has no length. - return(character(0)) + return(character(0L)) } else { # Return all column names that are not related to identifiers and outcome. @@ -371,11 +389,11 @@ setMethod("get_n_features", signature(x = "dataObject"), function(x) { # has_feature_data-------------------------------------------------------------- setMethod("has_feature_data", signature(x = "data.table"), function(x, outcome_type) { - return(get_n_features(x = x, outcome_type = outcome_type) > 0) + return(get_n_features(x = x, outcome_type = outcome_type) > 0L) }) setMethod("has_feature_data", signature(x = "dataObject"), function(x, outcome_type) { - return(get_n_features(x = x) > 0) + return(get_n_features(x = x) > 0L) }) @@ -390,17 +408,21 @@ setMethod( if (is.null(include_batch)) { # Determine if batch identifiers should be included, i.e. the same sample # identifiers appear in different batches. - include_batch <- any(unique( - x[, mget(get_id_columns(id_depth = "sample"))] - )[, list("n" = .N), by = mget(get_id_columns(single_column = "sample"))]$n > 1) + include_batch <- any( + unique( + x[, mget(get_id_columns(id_depth = "sample"))] + )[, list("n" = .N), by = mget(get_id_columns(single_column = "sample"))]$n > 1L + ) } if (is.null(include_series)) { # Determine if series identifiers should be included, i.e. any unique # sample has multiple series. - include_series <- any(unique( - x[, mget(get_id_columns(id_depth = "series"))] - )[, list("n" = .N), by = mget(get_id_columns(id_depth = "sample"))]$n > 1) + include_series <- any( + unique( + x[, mget(get_id_columns(id_depth = "series"))] + )[, list("n" = .N), by = mget(get_id_columns(id_depth = "sample"))]$n > 1L + ) } # Get sample names. @@ -433,23 +455,48 @@ setMethod( return(get_unique_row_names( x = x@data, include_batch = include_batch, - include_series = include_series)) + include_series = include_series + )) } ) # get_n_samples ---------------------------------------------------------------- -setMethod("get_n_samples", signature(x = "data.table"), function(x, id_depth = "sample") { - return(.get_n_samples(x = x, id_depth = id_depth)) -}) +setMethod( + "get_n_samples", + signature(x = "data.table"), + function(x, id_depth = "sample", count_unique = TRUE) { + return(.get_n_samples( + x = x, + id_depth = id_depth, + count_unique = count_unique + )) + } +) -setMethod("get_n_samples", signature(x = "dataObject"), function(x, id_depth = "sample") { - return(.get_n_samples(x = x@data, id_depth = id_depth)) -}) +setMethod( + "get_n_samples", + signature(x = "dataObject"), + function(x, id_depth = "sample", count_unique = TRUE) { + return(.get_n_samples( + x = x@data, + id_depth = id_depth, + count_unique = count_unique + )) + } +) +setMethod( + "get_n_samples", + signature(x = "NULL"), + function(x, id_depth = "sample", ...) { + return(0L) + } +) -.get_n_samples <- function(x, id_depth) { + +.get_n_samples <- function(x, id_depth, count_unique) { # Check if x is empty. if (is_empty(x)) { return(0L) @@ -460,7 +507,12 @@ setMethod("get_n_samples", signature(x = "dataObject"), function(x, id_depth = " # Return the number of rows with unique values for the combination of # identifier columns. - return(nrow(unique(x[, mget(id_columns)]))) + if (count_unique) { + return(nrow(unique(x[, mget(id_columns)]))) + + } else { + return(nrow(x[, mget(id_columns)])) + } } @@ -469,13 +521,15 @@ setMethod( "encode_categorical_variables", signature( data = "dataObject", - object = "ANY"), + object = "ANY" + ), function( object = NULL, data, encoding_method = "effect", drop_levels = TRUE, - feature_columns = NULL) { + feature_columns = NULL + ) { # Obtain feature columns if not provided. if (is.null(feature_columns)) feature_columns <- get_feature_columns(data) @@ -485,14 +539,16 @@ setMethod( object = object, encoding_method = encoding_method, drop_levels = drop_levels, - feature_columns = feature_columns) + feature_columns = feature_columns + ) # Update data data@data <- encoding_data$encoded_data return(list( "encoded_data" = data, - "reference_table" = encoding_data$reference_table)) + "reference_table" = encoding_data$reference_table + )) } ) @@ -501,49 +557,57 @@ setMethod( "encode_categorical_variables", signature( data = "data.table", - object = "ANY"), + object = "ANY" + ), function( object = NULL, data, encoding_method = "effect", drop_levels = TRUE, feature_columns = NULL, - outcome_type = NULL) { + outcome_type = NULL + ) { # Determine columns with factors if (is.null(feature_columns) && !is.null(outcome_type)) { feature_columns <- get_feature_columns( x = data, - outcome_type = outcome_type) + outcome_type = outcome_type + ) } else if (is.null(feature_columns)) { feature_columns <- colnames(data) } # Return original if no variables are available. - if (length(feature_columns) == 0) { + if (length(feature_columns) == 0L) { return(list( "encoded_data" = data, - "reference_table" = NULL)) + "reference_table" = NULL + )) } # Find column classes column_class <- lapply( feature_columns, - function(ii, data) (class(data[[ii]])), data = data) + function(ii, data) (class(data[[ii]])), + data = data + ) # Identify categorical columns factor_columns <- sapply( column_class, function(selected_column_class) { return(any(selected_column_class %in% c("logical", "character", "factor"))) - }) + } + ) factor_columns <- feature_columns[factor_columns] # Return original if no categorical variables are available. - if (length(factor_columns) == 0) { + if (length(factor_columns) == 0L) { return(list( "encoded_data" = data, - "reference_table" = NULL)) + "reference_table" = NULL + )) } # Initialise contrast list and reference list @@ -570,29 +634,36 @@ setMethod( } else if (is.logical(x)) { level_names <- c(FALSE, TRUE) - level_count <- 2 + level_count <- 2L } # Apply coding scheme - if (encoding_method == "effect" || level_count == 1) { + if (encoding_method == "effect" || level_count == 1L) { # Effect/one-hot encoding curr_contrast_list <- lapply( level_names, - function(ii, x) (as.numeric(x == ii)), x = x) + function(ii, x) (as.numeric(x == ii)), + x = x + ) # Check level_names for inconsistencies (i.e. spaces etc) contrast_names <- .replace_illegal_column_name( - column_name = paste0(current_col, "_", level_names)) + column_name = paste0(current_col, "_", level_names) + ) names(curr_contrast_list) <- contrast_names } else if (encoding_method == "dummy") { # Dummy encoding. The first level is used as a reference (0). curr_contrast_list <- lapply( - level_names[2:level_count], function(ii, x) (as.numeric(x == ii)), x = x) + level_names[2L:level_count], + function(ii, x) (as.numeric(x == ii)), + x = x + ) # Check level_names for inconsistencies (i.e. spaces etc) contrast_names <- .replace_illegal_column_name( - column_name = paste0(current_col, "_", level_names[2:level_count])) + column_name = paste0(current_col, "_", level_names[2L:level_count]) + ) names(curr_contrast_list) <- contrast_names } else if (encoding_method == "numeric") { @@ -606,16 +677,18 @@ setMethod( } else { ..error_reached_unreachable_code( - "encode_categorical_variables: unknown encoding method encountered.") + "encode_categorical_variables: unknown encoding method encountered." + ) } # Add list of generated contrast to contrast list - contrast_list <- append(contrast_list, curr_contrast_list) + contrast_list <- c(contrast_list, curr_contrast_list) # Add data table with reference and contrast names to the reference list reference_list[[ii]] <- data.table::data.table( "original_name" = current_col, - "reference_name" = contrast_names) + "reference_name" = contrast_names + ) } # Check if the original data set contained any features other than @@ -627,285 +700,65 @@ setMethod( } else { contrast_table <- cbind( data[, !factor_columns, with = FALSE], - data.table::as.data.table(contrast_list)) + data.table::as.data.table(contrast_list) + ) } # Return as list return(list( "encoded_data" = contrast_table, - "reference_table" = data.table::rbindlist(reference_list))) - } -) - - - -# get_placeholder_prediction_table---------------------------------------------- -setMethod( - "get_placeholder_prediction_table", - signature( - object = "familiarModel", - data = "dataObject"), - function(object, data, type = "default") { - return(get_placeholder_prediction_table( - object = object@outcome_info, - data = data@data, - type = type)) - } -) - -setMethod( - "get_placeholder_prediction_table", - signature( - object = "familiarModel", - data = "data.table"), - function(object, data, type = "default") { - return(get_placeholder_prediction_table( - object = object@outcome_info, - data = data, - type = type)) - } -) - -setMethod( - "get_placeholder_prediction_table", - signature( - object = "familiarEnsemble", - data = "dataObject"), - function(object, data, type = "default") { - return(get_placeholder_prediction_table( - object = object@outcome_info, - data = data@data, - type = type)) - } -) - -setMethod( - "get_placeholder_prediction_table", - signature( - object = "familiarEnsemble", - data = "data.table"), - function(object, data, type = "default") { - return(get_placeholder_prediction_table( - object = object@outcome_info, - data = data, - type = type)) - } -) - -setMethod( - "get_placeholder_prediction_table", - signature( - object = "familiarNoveltyDetector", - data = "dataObject"), - function(object, data, type = "default") { - return(get_placeholder_prediction_table( - object = object, - data = data@data, - type = type)) - } -) - -setMethod( - "get_placeholder_prediction_table", - signature( - object = "familiarNoveltyDetector", - data = "data.table"), - function(object, data, type = "default") { - # Check that the type parameter is valid, - .check_parameter_value_is_valid( - x = type, - var_name = "type", - values = .get_available_prediction_type_arguments()) - - # Find non-feature columns. - non_feature_columns <- get_non_feature_columns(object) - - # Create the prediction table. - prediction_table <- data.table::copy(data[, mget(non_feature_columns)]) - - if ("novelty" %in% type) { - # Add novelty column. - prediction_table[, "novelty" := as.double(NA)] - - } else { - stop("Only novelty predictions can be made.") - } - - return(prediction_table) - } -) - -setMethod( - "get_placeholder_prediction_table", - signature( - object = "outcomeInfo", - data = "dataObject"), - function(object, data, type = "default") { - return(get_placeholder_prediction_table( - object = object, - data = data@data, - type = type)) - } -) - -setMethod( - "get_placeholder_prediction_table", - signature( - object = "outcomeInfo", - data = "data.table"), - function(object, data, type = "default") { - # Check that the type parameter is valid, - .check_parameter_value_is_valid( - x = type, - var_name = "type", - values = .get_available_prediction_type_arguments()) - - # Find non-feature columns. - non_feature_columns <- get_non_feature_columns(object) - if (all(type %in% .get_available_novelty_prediction_type_arguments())) { - non_feature_columns <- setdiff( - non_feature_columns, - get_outcome_columns(object)) - } - - # Create the prediction table. - prediction_table <- data.table::copy(data[, mget(non_feature_columns)]) - - if ("default" %in% type) { - # Add default prediction columns. - - if (object@outcome_type %in% c("survival", "continuous", "count", "competing_risk")) { - # For survival and continuous outcomes, a single predicted outcome - # column is added. - prediction_table[, "predicted_outcome" := as.double(NA)] - } else if (object@outcome_type %in% c("binomial", "multinomial")) { - - # For categorical outcomes, both predicted class and predicted class - # probabilities are added. - prediction_table[, "predicted_class" := as.character(NA)] - - # Assign factor. - prediction_table$predicted_class <- factor( - x = prediction_table$predicted_class, - levels = get_outcome_class_levels(x = object)) - - # Define probabilities columns - outcome_probability_columns <- get_class_probability_name(object) - - for (ii in seq_along(outcome_probability_columns)) { - prediction_table[, (outcome_probability_columns[ii]) := as.double(NA)] - } - - } else { - ..error_no_known_outcome_type(object@outcome_type) - } - } - - if ("survival_probability" %in% type) { - if (object@outcome_type %in% c("survival", "competing_risk")) { - # For survival outcomes, a single predicted outcome column is added. - prediction_table[, "survival_probability" := as.double(NA)] - - } else { - ..error_no_predictions_possible(object@outcome_type, "survival_probability") - } - } - - if ("risk_stratification" %in% type) { - if (object@outcome_type %in% c("survival", "competing_risk")) { - # For survival outcomes, a risk_group column is added. - prediction_table[, "risk_group" := as.character(NA)] - - } else { - ..error_no_predictions_possible(object@outcome_type, "risk_stratification") - } - } - - if ("novelty" %in% type) { - # Add novelty column. - prediction_table[, "novelty" := as.double(NA)] - } - - return(prediction_table) + "reference_table" = data.table::rbindlist(reference_list) + )) } ) -setMethod( - "get_placeholder_prediction_table", - signature( - object = "familiarHyperparameterLearner", - data = "data.table"), - function(object, data, type = "default") { - # Find the id columns. - id_columns <- intersect(c("param_id", "run_id"), colnames(data)) - - if (length(id_columns) > 0) { - # Create a placeholder by only keeping the identifier columns. - prediction_table <- data.table::copy(data[, mget(id_columns)]) - - } else { - # Add a placeholder parameter identifier as scaffolding. - prediction_table <- data.table::data.table(param_id = rep_len(NA_integer_, nrow(data))) - } - - # Add placeholder columns. - if (type == "default") { - prediction_table[, "mu" := as.double(NA)] - - } else if (type == "sd") { - prediction_table[, ":="( - "mu" = as.double(NA), - "sigma" = as.double(NA))] - - } else if (type == "percentile") { - prediction_table[, "percentile" := as.double(NA)] - - } else if (type == "raw") { - prediction_table[, "raw_1" := as.double(NA)] - - } else { - ..error_reached_unreachable_code(paste0( - "get_placeholder_prediction_table,familiarHyperparameterLearner,data.table: ", - "Encountered an unknown prediction type: ", type - )) - } - - return(prediction_table) - } -) # get_bootstrap_sample---------------------------------------------------------- setMethod( "get_bootstrap_sample", signature(data = "dataObject"), - function(data, seed = NULL, ...) { + function( + data, + seed = NULL, + rstream_object = NULL, + n_samples = NULL, + ... + ) { if (.as_preprocessing_level(data) > "none") { # Indicating that some preprocessing has taken please. # Bootstrap the data element. data@data <- get_bootstrap_sample( data = data@data, - seed = seed) + seed = seed, + rstream_object = rstream_object, + n_samples = n_samples + ) - } else if (length(data@sample_set_on_load) > 0) { + } else if (length(data@sample_set_on_load) > 0L) { if (data.table::is.data.table(data@sample_set_on_load)) { data@sample_set_on_load <- get_bootstrap_sample( data = data@sample_set_on_load, - seed = seed) - + seed = seed, + rstream_object = rstream_object, + n_samples = n_samples + ) } else { # Reshuffle the samples -- This is for backward compatibility. data@sample_set_on_load <- fam_sample( x = unique(data@sample_set_on_load), size = length(data@sample_set_on_load), replace = TRUE, - seed = seed) + seed = seed, + rstream_object = rstream_object, + ) } } else { ..error_reached_unreachable_code(paste0( "get_boostrap_sample,dataObject: could not identify a suitable ", - "method for bootstrapping.")) + "method for bootstrapping." + )) } return(data) @@ -915,20 +768,32 @@ setMethod( setMethod( "get_bootstrap_sample", signature(data = "data.table"), - function(data, seed = NULL, ...) { + function( + data, + seed = NULL, + rstream_object = NULL, + n_samples = NULL, + ... + ) { # Find identifier columns at the sample level, i.e. excluding repetitions # and series. id_columns <- intersect( get_id_columns(id_depth = "sample"), - colnames(data)) + colnames(data) + ) - if (length(id_columns) == 0) { + if (length(id_columns) == 0L) { + size <- nrow(data) + if (!is.null(n_samples)) size <- min(n_samples, size) + # Sample rows. row_ids <- fam_sample( x = seq_len(nrow(data)), - size = nrow(data), + size = size, replace = TRUE, - seed = seed) + seed = seed, + rstream_object = rstream_object + ) # Create a subset. data <- data[row_ids, ] @@ -937,12 +802,17 @@ setMethod( # List unique samples. id_table <- unique(data[, mget(id_columns)]) + size <- nrow(id_table) + if (!is.null(n_samples)) size <- min(n_samples, size) + # Sample the unique rows of the identifier table. row_ids <- fam_sample( x = seq_len(nrow(id_table)), - size = nrow(id_table), + size = size, replace = TRUE, - seed = seed) + seed = seed, + rstream_object = rstream_object + ) # Create subsample. id_table <- id_table[row_ids, ] @@ -954,7 +824,8 @@ setMethod( y = unique(data), by = id_columns, all = FALSE, - allow.cartesian = TRUE) + allow.cartesian = TRUE + ) } return(data) @@ -964,7 +835,7 @@ setMethod( setMethod( "get_bootstrap_sample", signature(data = "NULL"), - function(data, seed = NULL, ...) { + function(data, seed = NULL, rstream_object = NULL, ...) { return(NULL) } ) @@ -980,7 +851,8 @@ setMethod( seed = NULL, size = NULL, outcome_type = NULL, - ...) { + ... + ) { # This function randomly selects up to "size" samples from the data. # Set seed for reproducible results. if (!is.null(seed)) { @@ -997,20 +869,23 @@ setMethod( data = data@data, size = size, outcome_type = outcome_type, - rstream_object = rstream_object) + rstream_object = rstream_object + ) - } else if (length(data@sample_set_on_load) > 0) { + } else if (length(data@sample_set_on_load) > 0L) { # Subsample data. data@sample_set_on_load <- get_subsample( data = data@sample_set_on_load, size = size, outcome_type = outcome_type, - rstream_object = rstream_object) + rstream_object = rstream_object + ) } else { ..error_reached_unreachable_code(paste0( "get_boostrap_sample,dataObject: could not identify a suitable ", - "method for bootstrapping.")) + "method for bootstrapping." + )) } return(data) @@ -1027,7 +902,8 @@ setMethod( size = NULL, outcome_type = NULL, rstream_object = NULL, - ...) { + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table .NATURAL <- NULL @@ -1049,15 +925,17 @@ setMethod( # repetitions and series. id_columns <- intersect( get_id_columns(id_depth = "sample"), - colnames(data)) + colnames(data) + ) - if (length(id_columns) == 0) { + if (length(id_columns) == 0L) { # Sample rows. row_ids <- fam_sample( x = seq_len(nrow(data)), size = size, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Create a subset. data <- data[row_ids, ] @@ -1068,7 +946,8 @@ setMethod( x = seq_len(nrow(data)), size = size, replace = FALSE, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Create a subset. data <- data[row_ids, ] @@ -1079,10 +958,11 @@ setMethod( size = size, n_iter = 1L, outcome_type = outcome_type, - rstream_object = rstream_object) + rstream_object = rstream_object + ) # Isolate identifier table. - id_table <- id_table$train_list[[1]] + id_table <- id_table$train_list[[1L]] # Select data. data <- data[id_table, on = .NATURAL] @@ -1113,7 +993,8 @@ setMethod( prob = NULL, seed = NULL, rstream_object = NULL, - ...) { + ... + ) { # This function prevents the documented behaviour of the sample function, # where if x is positive, numeric and only has one element, it interprets x # as a series of x, i.e. x=seq_len(x). That's bad news if x is a sample @@ -1122,11 +1003,11 @@ setMethod( # Set size if it is unset. if (is.null(size)) size <- length(x) - if (length(x) == 1) { + if (length(x) == 1L) { # Check that size is not greater than 1, if items are to be drawn # without replacement. - if (!replace & size > 1) { - stop("cannot take a sample larger than the population when 'replace = FALSE'") + if (!replace & size > 1L) { + ..error("cannot take a sample larger than the population when 'replace = FALSE'") } return(rep_len(x = x, length.out = size)) @@ -1140,7 +1021,8 @@ setMethod( x = x, size = size, replace = replace, - prob = prob)) + prob = prob + )) } else { return(..fam_sample( @@ -1148,7 +1030,8 @@ setMethod( size = size, replace = replace, seed = seed, - rstream_object = rstream_object)) + rstream_object = rstream_object + )) } } } @@ -1164,7 +1047,8 @@ setMethod( prob = NULL, seed = NULL, rstream_object = NULL, - ...) { + ... + ) { # This function prevents the documented behaviour of the sample function, # where if x is positive, numeric and only has one element, it interprets x # as a series of x, i.e. x=seq_len(x). That's bad news if x is a sample @@ -1185,14 +1069,16 @@ setMethod( # Check that batch_id and sample_id columns are present. if (!all(id_columns %in% colnames(x))) { ..error_reached_unreachable_code( - "fam_sample,data.table: batch_id or sample_id columns are not present in x.") + "fam_sample,data.table: batch_id or sample_id columns are not present in x." + ) } # Check that the prob column is present. if (is.logical(prob)) { if (prob && !"prob" %in% colnames(x)) { ..error_reached_unreachable_code( - "fam_sample,data.table: prob column is not present in x.") + "fam_sample,data.table: prob column is not present in x." + ) } # Select unique samples. @@ -1214,7 +1100,8 @@ setMethod( } else { ..error_reached_unreachable_code( - "fam_sample,data.table: the length of prob does not equal the number of instances in x.") + "fam_sample,data.table: the length of prob does not equal the number of instances in x." + ) } } @@ -1222,11 +1109,11 @@ setMethod( if (is.null(size)) size <- nrow(x) # Sample x. - if (nrow(x) == 1) { + if (nrow(x) == 1L) { # Check that size is not greater than 1, if items are to be drawn without # replacement. - if (!replace && size > 1) { - stop("cannot take a sample larger than the population when 'replace = FALSE'") + if (!replace && size > 1L) { + ..error("cannot take a sample larger than the population when 'replace = FALSE'") } # Get row-ids @@ -1252,7 +1139,8 @@ setMethod( x = seq_len(nrow(x)), size = size, replace = replace, - prob = prob) + prob = prob + ) } else { row_id <- ..fam_sample( @@ -1260,7 +1148,8 @@ setMethod( size = size, replace = replace, seed = seed, - rstream_object = rstream_object) + rstream_object = rstream_object + ) } # Create output table y. @@ -1291,7 +1180,7 @@ setMethod("has_optimised_hyperparameters", signature(object = "familiarNoveltyDe default_parameters <- get_default_hyperparameters(object) # If there are no default hyperparameters, return TRUE. - if (length(default_parameters) == 0) return(TRUE) + if (length(default_parameters) == 0L) return(TRUE) # Check if any hyperparameters are present in the object. if (is_empty(object@hyperparameters)) return(FALSE) diff --git a/R/VimpMain.R b/R/VimpMain.R index 8650012a..941f81b1 100644 --- a/R/VimpMain.R +++ b/R/VimpMain.R @@ -20,6 +20,9 @@ setMethod( } else if (method %in% .get_available_multivariate_mutual_information_vimp_method()) { # Multivariate information methods. object <- methods::new("familiarMultivariateMutualInfoVimp", object) + } else if (method %in% .get_available_multivariate_mutual_information_test_vimp_method()) { + # Multivariate test method returning single features. + object <- methods::new("familiarMultivariateInfoVimpTestSingle", object) } else if (method %in% .get_available_correlation_vimp_methods()) { # Correlation-based methods. object <- methods::new("familiarCorrelationVimp", object) @@ -47,7 +50,9 @@ setMethod( # Create a familiarModel and promote to the right class. object <- methods::new( "familiarModel", - fs_method = "none", + vimp_method = "none", + vimp_aggregation_method = object@vimp_aggregation_method, + vimp_rank_threshold = object@vimp_rank_threshold, learner = method, outcome_type = object@outcome_type, hyperparameters = object@hyperparameters, @@ -55,7 +60,8 @@ setMethod( feature_info = object@feature_info, required_features = object@required_features, run_table = object@run_table, - project_id = object@project_id) + project_id = object@project_id + ) # Promote to the correct subclass. object <- promote_learner(object) @@ -66,7 +72,9 @@ setMethod( # Create a familiarModel and promote to the right class. object <- methods::new( "familiarModel", - fs_method = "none", + vimp_method = "none", + vimp_aggregation_method = object@vimp_aggregation_method, + vimp_rank_threshold = object@vimp_rank_threshold, learner = method, outcome_type = object@outcome_type, hyperparameters = object@hyperparameters, @@ -74,7 +82,8 @@ setMethod( feature_info = object@feature_info, required_features = object@required_features, run_table = object@run_table, - project_id = object@project_id) + project_id = object@project_id + ) # Promote to the correct subclass. object <- promote_learner(object) @@ -84,7 +93,9 @@ setMethod( # Create a familiarModel and promote to the right class. object <- methods::new("familiarModel", - fs_method = "none", + vimp_method = "none", + vimp_aggregation_method = object@vimp_aggregation_method, + vimp_rank_threshold = object@vimp_rank_threshold, learner = method, outcome_type = object@outcome_type, hyperparameters = object@hyperparameters, @@ -92,18 +103,23 @@ setMethod( feature_info = object@feature_info, required_features = object@required_features, run_table = object@run_table, - project_id = object@project_id) + project_id = object@project_id + ) # Promote to the correct subclass. object <- promote_learner(object) - } else if (method %in% .get_available_rfsrc_vimp_methods() || - method %in% .get_available_rfsrc_default_vimp_methods()) { + } else if ( + method %in% .get_available_rfsrc_vimp_methods() || + method %in% .get_available_rfsrc_default_vimp_methods() + ) { # Random forest variable importance methods. # Create a familiarModel and promote to the right class. object <- methods::new("familiarModel", - fs_method = "none", + vimp_method = "none", + vimp_aggregation_method = object@vimp_aggregation_method, + vimp_rank_threshold = object@vimp_rank_threshold, learner = ifelse(method %in% .get_available_rfsrc_vimp_methods(), "random_forest_rfsrc", "random_forest_rfsrc_default" @@ -114,7 +130,8 @@ setMethod( feature_info = object@feature_info, required_features = object@required_features, run_table = object@run_table, - project_id = object@project_id) + project_id = object@project_id + ) # Promote to the correct subclass. object <- promote_learner(object) @@ -122,43 +139,52 @@ setMethod( # Set the variable importance parameters for the method. object <- ..set_vimp_parameters(object, method = method) - } else if (method %in% .get_available_ranger_vimp_methods() || - method %in% .get_available_ranger_default_vimp_methods()) { + } else if ( + method %in% .get_available_ranger_vimp_methods() || + method %in% .get_available_ranger_default_vimp_methods() + ) { # Ranger random forest variable importance methods. # Create a familiarModel and promote to the right class. object <- methods::new("familiarModel", - fs_method = "none", + vimp_method = "none", + vimp_aggregation_method = object@vimp_aggregation_method, + vimp_rank_threshold = object@vimp_rank_threshold, learner = ifelse( method %in% .get_available_ranger_vimp_methods(), "random_forest_ranger", - "random_forest_ranger_default"), + "random_forest_ranger_default" + ), outcome_type = object@outcome_type, hyperparameters = object@hyperparameters, outcome_info = object@outcome_info, feature_info = object@feature_info, required_features = object@required_features, run_table = object@run_table, - project_id = object@project_id) + project_id = object@project_id + ) # Promote to the correct subclass. object <- promote_learner(object) # Set the variable importance parameters for the method. object <- ..set_vimp_parameters(object, method = method) + } else if (method %in% .get_available_random_vimp_methods()) { - # Random feature selection.. + # Random variable importances. object <- methods::new("familiarRandomVimp", object) + } else if (method %in% .get_available_none_vimp_methods()) { - # None feature selection methods - all features are equally - # important. + # No variable importance: all features are equally important. object <- methods::new("familiarNoneVimp", object) + } else if (method %in% .get_available_signature_only_vimp_methods()) { # Signature only methods. object <- methods::new("familiarSignatureVimp", object) + } else if (method %in% .get_available_no_features_vimp_methods()) { - # No feature selection methods - no features are selected, leading - # to naive models. + # No variable importance methods - no features are selected, leading to + # naive models. object <- methods::new("familiarNoFeaturesVimp", object) } @@ -172,7 +198,8 @@ setMethod( data, method, outcome_type, - names_only = FALSE) { + names_only = FALSE +) { # Get the outcome type from the data object, if available if (!is.null(data)) outcome_type <- data@outcome_type @@ -180,7 +207,8 @@ setMethod( vimp_method_object <- methods::new( "familiarVimpMethod", vimp_method = method, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Set up the specific model vimp_method_object <- promote_vimp_method(vimp_method_object) @@ -202,12 +230,14 @@ setMethod( .check_vimp_outcome_type <- function( method, outcome_type, - as_flag = FALSE) { + as_flag = FALSE +) { # Create familiarModel vimp_method_object <- methods::new( "familiarVimpMethod", vimp_method = method, - outcome_type = outcome_type) + outcome_type = outcome_type + ) # Set up the specific model vimp_method_object <- promote_vimp_method(vimp_method_object) @@ -218,185 +248,36 @@ setMethod( if (as_flag) return(vimp_method_available) # Check if the vimp method or familiar model has been successfully promoted. - if (!is_subclass(class(vimp_method_object)[1], "familiarVimpMethod") && - !is_subclass(class(vimp_method_object)[1], "familiarModel")) { - stop(paste0( + if ( + !is_subclass(class(vimp_method_object)[1L], "familiarVimpMethod") && + !is_subclass(class(vimp_method_object)[1L], "familiarModel") + ) { + ..error(paste0( method, " is not a valid variable importance method. ", - "Please check the vignette for available methods.")) + "Please check the vignette for available methods." + )) } if (!vimp_method_available) { - stop(paste0(method, " is not available for \"", outcome_type, "\" outcomes.")) + ..error(paste0(method, " is not available for \"", outcome_type, "\" outcomes.")) } # Check that the required package can be loaded. require_package( x = vimp_method_object, purpose = paste0("to assess variable importance using the ", method, " method"), - message_type = "backend_error") + message_type = "backend_error" + ) } -# prepare_vimp_object (data.table) --------------------------------------------- +# add_package_version ---------------------------------------------------------- setMethod( - "prepare_vimp_object", - signature(data = "data.table"), - function( - data, - vimp_method, - vimp_method_parameter_list = list(), - ...) { - # Convert data to dataObject. - data <- do.call( - as_data_object, - args = c( - list("data" = data), - list(...))) - - return(do.call( - prepare_vimp_object, - args = c( - list( - "data" = data, - "vimp_method" = vimp_method, - "vimp_method_parameter_list" = vimp_method_parameter_list), - list(...)))) - } -) - - - -# prepare_vimp_object (dataObject) --------------------------------------------- -setMethod( - "prepare_vimp_object", signature(data = "dataObject"), - function(data, vimp_method, vimp_method_parameter_list = list(), ...) { - # This method is used within unit tests, but not by the main - # familiar workflow. - - # Prepare setting ---------------------------------------------------------- - - # Reconstitute settings from the data. - settings <- extract_settings_from_data(data) - - # Update some missing settings that can be fixed within this method. - settings$data$train_cohorts <- unique(data@data[[get_id_columns(single_column = "batch")]]) - - # Parse the remaining settings that are important. Remove outcome_type from - # ... This prevents an error caused by multiple matching arguments. - dots <- list(...) - dots$parallel <- NULL - dots$fs_method <- NULL - dots$fs_method_parameter <- NULL - dots$learner <- NULL - - if (!is.null(dots$signature)) settings$data$signature <- dots$signature - - # Create setting_hyperparam so that it can be parsed correctly. - if (!vimp_method %in% names(vimp_method_parameter_list) && - length(vimp_method_parameter_list) > 0) { - setting_hyperparam <- list() - setting_hyperparam[[vimp_method]] <- vimp_method_parameter_list - } else { - setting_hyperparam <- vimp_method_parameter_list - } - - settings <- do.call( - .parse_general_settings, - args = c( - list( - "settings" = settings, - "data" = data@data, - "parallel" = FALSE, - "fs_method" = vimp_method, - "learner" = "glm", - "fs_method_parameter" = setting_hyperparam), - dots)) - - # Push settings to the backend. - .assign_settings_to_global(settings = settings) - - # Prepare featureInfo objects ---------------------------------------------- - - # Create a list of featureInfo objects. - feature_info_list <- .get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = settings$data$outcome_type) - - # Extract the generic data. - feature_info_list <- feature_info_list[["generic"]] - - # Add signature info. - feature_info_list <- add_signature_info( - feature_info_list = feature_info_list, - signature = settings$data$signature) - - # Perform some pre-processing (i.e. remove singular features) - feature_info_list <- .determine_preprocessing_parameters( - cl = NULL, - data = data, - feature_info_list = feature_info_list, - settings = settings, - verbose = FALSE) - - # Prepare hyperparameters -------------------------------------------------- - - # Get default hyperparameters. - param_list <- .get_preset_hyperparameters( - data = data, - fs_method = vimp_method, - names_only = FALSE) - - # Update with user-provided settings. - param_list <- .update_hyperparameters( - parameter_list = param_list, - user_list = settings$fs$param[[vimp_method]]) - - # Determine which hyperparameters still need to be specified. - unset_parameters <- sapply( - param_list, - function(hyperparameter_entry) hyperparameter_entry$randomise) - - # Mark sign-size as set, as it is not used for variable importance. - if ("sign_size" %in% names(unset_parameters)) { - unset_parameters["sign_size"] <- FALSE - } - - # Raise an error if any hyperparameters were not set. - if (any(unset_parameters)) { - stop(paste0( - "The following hyperparameters need to be specified: ", - paste_s(names(unset_parameters)[unset_parameters]))) - } - - # Obtain the final list of hyperparameters. - param_list <- lapply( - param_list, - function(hyperparameter_entry) hyperparameter_entry$init_config) - - # Prepare vimp object ------------------------------------------------------ - - # Get required features. - required_features <- get_required_features( - x = data, - feature_info_list = feature_info_list) - - # Create a familiar variable importance method. - object <- methods::new( - "familiarVimpMethod", - outcome_type = settings$data$outcome_type, - vimp_method = vimp_method, - hyperparameters = param_list, - outcome_info = data@outcome_info, - feature_info = feature_info_list[required_features], - required_features = required_features) - - # Promote object to correct subclass. - object <- promote_vimp_method(object) - - # Return in list. - return(object) + "add_package_version", + signature(object = "familiarVimpMethod"), + function(object) { + # Set version of familiar + return(.add_package_version(object = object)) } ) diff --git a/R/VimpS4Concordance.R b/R/VimpS4Concordance.R index 5457ba17..a85908fc 100644 --- a/R/VimpS4Concordance.R +++ b/R/VimpS4Concordance.R @@ -4,7 +4,8 @@ NULL setClass( "familiarConcordanceVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) .get_available_concordance_vimp_method <- function(show_general = TRUE) { @@ -17,6 +18,12 @@ setMethod( "is_available", signature(object = "familiarConcordanceVimp"), function(object, ...) { + + if (object@outcome_type == "count") { + ..deprecation_count() + return(FALSE) + } + return(TRUE) } ) @@ -38,27 +45,63 @@ setMethod( setMethod( "..vimp", signature(object = "familiarConcordanceVimp"), - function(object, data, ...) { + function( + object, + data, + cl = NULL, + ... + ) { if (is_empty(data)) return(callNextMethod()) - + # Use concordance-based measures for variable importance: # - Gini index for binomial and multinomial outcomes # - Kendall's Tau for continuous and counts outcomes # - Concordance index for survival features - + if (object@outcome_type %in% c("binomial", "multinomial")) { # Compute gini index for categorical outcomes. - - # Create a new vimp object, and replace the vimp_method slot. - new_vimp_object <- methods::new("familiarCoreLearnGiniVimp", object) - new_vimp_object@vimp_method <- "gini" - - return(..vimp( - object = new_vimp_object, - data = data)) - } else if (object@outcome_type %in% c("continuous", "count")) { + # Use effect coding to convert categorical data into encoded data - this + # is required to deal with factors with missing/new levels between + # training and test data sets. + encoded_data <- encode_categorical_variables( + data = data, + object = object, + encoding_method = "dummy", + drop_levels = FALSE + ) + + # Find feature columns in the data. + feature_columns <- get_feature_columns(x = encoded_data$encoded_data) + + # Compute auc-roc + auc_roc <- fam_sapply( + cl = cl, + X = encoded_data$encoded_data@data[, mget(feature_columns)], + FUN = .compute_auc_roc, + y_obs = encoded_data$encoded_data@data$outcome, + chopchop = TRUE + ) + + # Map to [0, 1] range. + score <- abs(auc_roc - 0.5) * 2.0 + + # Create variable importance object. + vimp_object <- methods::new( + "vimpTable", + vimp_table = data.table::data.table( + "score" = score, + "name" = feature_columns + ), + encoding_table = encoded_data$reference_table, + score_aggregation = "max", + invert = TRUE + ) + + return(vimp_object) + + } else if (object@outcome_type %in% c("continuous")) { # For continuous outcomes use kendall's tau. # Create a new vimp object, and replace the vimp_method slot. @@ -67,7 +110,9 @@ setMethod( return(..vimp( object = new_vimp_object, - data = data)) + data = data, + cl = cl + )) } else if (object@outcome_type == "survival") { # Compute the concordance index for each feature. @@ -79,26 +124,34 @@ setMethod( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Find feature columns in the data. feature_columns <- get_feature_columns(x = encoded_data$encoded_data) # Compute concordance indices - c_index <- sapply( - encoded_data$encoded_data@data[, mget(feature_columns)], - ..compute_concordance_index, + c_index <- fam_sapply( + X = encoded_data$encoded_data@data[, mget(feature_columns)], + FUN = ..compute_concordance_index, time = encoded_data$encoded_data@data$outcome_time, - event = encoded_data$encoded_data@data$outcome_event) + event = encoded_data$encoded_data@data$outcome_event, + chopchop = TRUE + ) + # Map to [0, 1] range. + score <- abs(c_index - 0.5) * 2.0 + # Create variable importance object. vimp_object <- methods::new("vimpTable", vimp_table = data.table::data.table( - "score" = abs(c_index - 0.5), - "name" = feature_columns), + "score" = score, + "name" = feature_columns + ), encoding_table = encoded_data$reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) diff --git a/R/VimpS4CoreLearn.R b/R/VimpS4CoreLearn.R index 6119ec96..723e8767 100644 --- a/R/VimpS4CoreLearn.R +++ b/R/VimpS4CoreLearn.R @@ -8,19 +8,23 @@ setClass("familiarCoreLearnVimp", setClass( "familiarCoreLearnGiniVimp", - contains = "familiarCoreLearnVimp") + contains = "familiarCoreLearnVimp" +) setClass( "familiarCoreLearnMDLVimp", - contains = "familiarCoreLearnVimp") + contains = "familiarCoreLearnVimp" +) setClass( "familiarCoreLearnRelieffExpRankVimp", - contains = "familiarCoreLearnVimp") + contains = "familiarCoreLearnVimp" +) setClass( "familiarCoreLearnGainRatioVimp", - contains = "familiarCoreLearnVimp") + contains = "familiarCoreLearnVimp" +) # initialize ------------------------------------------------------------------- @@ -80,7 +84,13 @@ setMethod( "is_available", signature(object = "familiarCoreLearnRelieffExpRankVimp"), function(object, ...) { - return(object@outcome_type %in% c("binomial", "multinomial", "count", "continuous")) + + if (object@outcome_type == "count") { + ..deprecation_count() + return(FALSE) + } + + return(object@outcome_type %in% c("binomial", "multinomial", "continuous")) } ) @@ -130,29 +140,33 @@ setMethod( score <- CORElearn::attrEval( formula, data = data@data, - estimator = "Gini") + estimator = "Gini" + ) } else if (is(object, "familiarCoreLearnMDLVimp")) { # MDL method. score <- CORElearn::attrEval( formula, data = data@data, - estimator = "MDL") + estimator = "MDL" + ) } else if (is(object, "familiarCoreLearnRelieffExpRankVimp")) { - if (object@outcome_type %in% c("continuous", "count")) { + if (object@outcome_type %in% c("continuous")) { # RReliefFexpRank method. score <- CORElearn::attrEval( formula, data = data@data, - estimator = "RReliefFexpRank") + estimator = "RReliefFexpRank" + ) } else if (object@outcome_type %in% c("binomial", "multinomial")) { # ReliefFexpRank method. score <- CORElearn::attrEval( formula, data = data@data, - estimator = "ReliefFexpRank") + estimator = "ReliefFexpRank" + ) } else { ..error_outcome_type_not_implemented(object@outcome_type) @@ -162,11 +176,13 @@ setMethod( score <- CORElearn::attrEval( formula, data = data@data, - estimator = "GainRatio") + estimator = "GainRatio" + ) } else { ..error_reached_unreachable_code( - "..vimp,familiarCoreLearnVimp: unknown class encountered.") + "..vimp,familiarCoreLearnVimp: unknown class encountered." + ) } # Create variable importance object. @@ -174,9 +190,11 @@ setMethod( "vimpTable", vimp_table = data.table::data.table( "score" = score, - "name" = names(score)), + "name" = names(score) + ), score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } diff --git a/R/VimpS4Correlation.R b/R/VimpS4Correlation.R index a1a201a6..92a85a6e 100644 --- a/R/VimpS4Correlation.R +++ b/R/VimpS4Correlation.R @@ -4,7 +4,8 @@ NULL setClass( "familiarCorrelationVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) @@ -19,7 +20,13 @@ setMethod( "is_available", signature(object = "familiarCorrelationVimp"), function(object, ...) { - return(object@outcome_type %in% c("continuous", "count", "survival")) + + if (object@outcome_type == "count") { + ..deprecation_count() + return(FALSE) + } + + return(object@outcome_type %in% c("continuous", "survival")) } ) @@ -40,7 +47,12 @@ setMethod( setMethod( "..vimp", signature(object = "familiarCorrelationVimp"), - function(object, data, ...) { + function( + object, + data, + cl = NULL, + ... + ) { # Suppress NOTES due to non-standard evaluation in data.table outcome_event <- NULL @@ -49,7 +61,7 @@ setMethod( # Drop non-event data for censored data analysis for calculating correlation # and set outcome column. if (object@outcome_type == "survival") { - data@data <- data@data[outcome_event == 1, ] + data@data <- data@data[outcome_event == 1L, ] # Check whether the filtered data does not allow for assessing variable # importance. @@ -65,46 +77,39 @@ setMethod( data = data, object = object, encoding_method = "dummy", - drop_levels = FALSE) + drop_levels = FALSE + ) # Find feature columns in the data. feature_columns <- get_feature_columns(x = encoded_data$encoded_data) + if (object@outcome_type =="survival") { + outcome <- encoded_data$encoded_data@data$outcome_time + + } else { + outcome <- encoded_data$encoded_data@data$outcome + } + # Compute correlation coefficients. - correlation_coefficients <- sapply( - feature_columns, - function(feature, data, outcome_type, correlation_method) { - if (outcome_type == "survival") { - # Use the outcome_time column for survival data. - correlation_coefficient <- stats::cor( - x = data[[feature]], - y = data[["outcome_time"]], - method = correlation_method - ) - } else { - # Use the outcome column for continuous and count data. - correlation_coefficient <- stats::cor( - x = data[[feature]], - y = data[["outcome"]], - method = correlation_method - ) - } - - return(correlation_coefficient) - }, - data = encoded_data$encoded_data@data, - outcome_type = object@outcome_type, - correlation_method = object@vimp_method + correlation_coefficients <- fam_sapply( + cl = cl, + X = encoded_data$encoded_data@data[, mget(feature_columns)], + FUN = stats::cor, + y = outcome, + method = object@vimp_method, + chopchop = TRUE ) # Create variable importance object. vimp_object <- methods::new("vimpTable", vimp_table = data.table::data.table( "score" = abs(correlation_coefficients), - "name" = feature_columns), + "name" = feature_columns + ), encoding_table = encoded_data$reference_table, score_aggregation = "max", - invert = TRUE) + invert = TRUE + ) return(vimp_object) } diff --git a/R/VimpS4MutualInformation.R b/R/VimpS4MutualInformation.R index c5ba29f3..1d6416c0 100644 --- a/R/VimpS4MutualInformation.R +++ b/R/VimpS4MutualInformation.R @@ -4,16 +4,25 @@ NULL setClass( "familiarMutualInformationVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) setClass( "familiarUnivariateMutualInfoVimp", - contains = "familiarMutualInformationVimp") + contains = "familiarMutualInformationVimp" +) setClass( "familiarMultivariateMutualInfoVimp", contains = "familiarMutualInformationVimp", - prototype = methods::prototype(multivariate = TRUE)) + prototype = methods::prototype(multivariate = TRUE) +) + +setClass( + "familiarMultivariateInfoVimpTestSingle", + contains = "familiarMultivariateMutualInfoVimp" +) + # initialize ------------------------------------------------------------------- setMethod( @@ -22,10 +31,10 @@ setMethod( function(.Object, ...) { # Update with parent class first. .Object <- callNextMethod() - + # Set the required package .Object@multivariate <- TRUE - + return(.Object) } ) @@ -40,6 +49,10 @@ setMethod( return(c("mifs", "mrmr")) } +.get_available_multivariate_mutual_information_test_vimp_method <- function(show_general = TRUE) { + return(c("familiarMultivariateInfoVimpTestSingle")) +} + # is_available ----------------------------------------------------------------- @@ -47,6 +60,12 @@ setMethod( "is_available", signature(object = "familiarMutualInformationVimp"), function(object, ...) { + + if (object@outcome_type == "count") { + ..deprecation_count() + return(FALSE) + } + return(TRUE) } ) @@ -69,26 +88,29 @@ setMethod( "..vimp", signature(object = "familiarUnivariateMutualInfoVimp"), function(object, data, ...) { - + if (is_empty(data)) return(callNextMethod()) - + # Identify feature columns. feature_columns <- get_feature_columns(data) - + # Calculate mutual information mutual_information <- .compute_mutual_information( data = data, - features = feature_columns) - + features = feature_columns + ) + # Create variable importance object. vimp_object <- methods::new( "vimpTable", vimp_table = data.table::data.table( "score" = mutual_information, - "name" = feature_columns), + "name" = feature_columns + ), score_aggregation = "max", - invert = TRUE) - + invert = TRUE + ) + return(vimp_object) } ) @@ -96,201 +118,273 @@ setMethod( # ..vimp (multivariate) -------------------------------------------------------- setMethod( - "..vimp", signature(object = "familiarMultivariateMutualInfoVimp"), + "..vimp", + signature(object = "familiarMultivariateMutualInfoVimp"), function(object, data, ...) { # - mifs: Mutual information feature selection using greedy search (Battiti # 1994) # - mrmr: Minimum Redundancy Maximum Relevance feature selection using # greedy search (Peng 2005) - + # Suppress NOTES due to non-standard evaluation in data.table objective_score <- available <- name <- mi_redundancy <- mi <- selected <- NULL - + if (is_empty(data)) return(callNextMethod()) - + # Find feature columns in data table. feature_columns <- get_feature_columns(data) - + # Find signature features. signature_feature <- names(object@feature_info)[ - sapply(object@feature_info, is_in_signature)] - + sapply(object@feature_info, is_in_signature) + ] + # Calculate mutual information. mutual_information <- .compute_mutual_information(data = data) - + # Setup mutual information table. mi_data <- data.table::data.table( "name" = feature_columns, "mi" = mutual_information, - "mi_redundancy" = 0, + "mi_redundancy" = 0.0, "objective_score" = mutual_information, "selected" = FALSE, "available" = TRUE, - "selection_step" = 0) - - if (length(signature_feature) > 0) { + "selection_step" = 0L + ) + + if (length(signature_feature) > 0L) { # Iteration counter. - ii <- 1 - + ii <- 1L + for (current_feature in signature_feature) { # Mark the current signature feature. Note that we iterate over the # features, and update mutual information to ensure that we get to the # correct starting point for the non-signature variables. best_feature <- current_feature - mi_data[name %in% best_feature, ":="( - "selected" = TRUE, - "available" = FALSE, - "selection_step" = ii)] - + mi_data[ + name %in% best_feature, + ":="( + "selected" = TRUE, + "available" = FALSE, + "selection_step" = ii + ) + ] + # Update Iteration counter. - ii <- ii + 1 - + ii <- ii + 1L + # Determine the features still available. available_features <- mi_data[available == TRUE, ]$name - if (length(available_features) == 0) break() - + if (length(available_features) == 0L) break + # Also skip if this is the last signature feature -- this is to prevent # overlap with the main while-cycle below. - if (current_feature == tail(signature_feature, n = 1L)) break() - + if (current_feature == tail(signature_feature, n = 1L)) break + # Calculate mutual information of available features and the # current signature feature. current_redundancy_mi <- .compute_mutual_information( data, features = available_features, - with_feature = best_feature) - + with_feature = best_feature + ) + # Update redundancy mi_data[ available == TRUE, - "mi_redundancy" := mi_redundancy + current_redundancy_mi] + "mi_redundancy" := mi_redundancy + current_redundancy_mi + ] if (object@vimp_method == "mifs") { # Update the objective score by subtracting the redundancy score. MIFS # uses beta=1 (Battiti 1994) mi_data[ available == TRUE, - "objective_score" := mi - mi_redundancy] + "objective_score" := mi - mi_redundancy + ] # Only consider features with a valid, non-negative optimisation # score, as redundancy is strictly increasing. Note that signature # features are never removed until they are selected. mi_data[ objective_score < 0.0 & selected == FALSE & !name %in% signature_feature, - "available" := FALSE] + "available" := FALSE + ] } else if (object@vimp_method == "mrmr") { # Calculate optimisation score. MRMR uses beta=1/(ii-1), with ii-1 the # size of the selected feature set. mi_data[ available == TRUE, - "objective_score" := mi - mi_redundancy / (ii - 1)] - + "objective_score" := mi - mi_redundancy / (ii - 1L) + ] + # Only consider features with a valid, non-negative optimisation # score, as redundancy is strictly increasing. Note that signature # features are never removed until they are selected. mi_data[ objective_score < 0.0 & selected == FALSE & !name %in% signature_feature, - "available" := FALSE] + "available" := FALSE + ] } else { ..error_reached_unreachable_code(paste0( "vimp,familiarMultivariateMutualInfoVimp: encountered unknown vimp_method: ", - object@vimp_method)) + object@vimp_method + )) } } } else { # Select initial feature and update mi_data. max_objective_score <- max(mi_data$objective_score) - best_feature <- mi_data[objective_score == max_objective_score, ]$name[1] - mi_data[name %in% best_feature, ":="( - "selected" = TRUE, - "available" = FALSE, - "selection_step" = 1)] - + best_feature <- mi_data[objective_score == max_objective_score, ]$name[1L] + mi_data[ + name %in% best_feature, + ":="( + "selected" = TRUE, + "available" = FALSE, + "selection_step" = 1L + ) + ] + # Determine the features that were not selected. available_features <- mi_data[available == TRUE, ]$name - + # Iteration counter. - ii <- 2 + ii <- 2L } - - - while (length(available_features) > 0) { + + + while (length(available_features) > 0L) { # Calculate mutual information of available features and the selected feature current_redundancy_mi <- .compute_mutual_information( data, features = available_features, - with_feature = best_feature) - + with_feature = best_feature + ) + # Update redundancy mi_data[ available == TRUE, - "mi_redundancy" := mi_redundancy + current_redundancy_mi] - + "mi_redundancy" := mi_redundancy + current_redundancy_mi + ] + if (object@vimp_method == "mifs") { # Update the objective score by subtracting the redundancy score. MIFS # uses beta=1 (Battiti 1994) mi_data[ available == TRUE, - "objective_score" := mi - mi_redundancy] - + "objective_score" := mi - mi_redundancy + ] + # Only consider features with a valid, non-negative optimisation score, # as redundancy is strictly increasing. mi_data[ objective_score < 0.0 & selected == FALSE, - "available" := FALSE] + "available" := FALSE + ] } else if (object@vimp_method == "mrmr") { # Calculate optimisation score. MRMR uses beta=1/(ii-1), with ii-1 the # size of the selected feature set mi_data[ available == TRUE, - "objective_score" := mi - mi_redundancy / (ii - 1)] - + "objective_score" := mi - mi_redundancy / (ii - 1L) + ] + # Only consider features with a valid, non-negative optimisation score, # as redundancy is strictly increasing. mi_data[ objective_score < 0.0 & selected == FALSE, - "available" := FALSE] + "available" := FALSE + ] } else { ..error_reached_unreachable_code(paste0( "vimp,familiarMultivariateMutualInfoVimp: encountered unknown vimp_method: ", - object@vimp_method)) + object@vimp_method + )) } - + # If there are no more available features (i.e. due to negative objective # score), break from the loop. - if (nrow(mi_data[available == TRUE, ]) == 0) break - + if (!any(mi_data$available)) break + # Select best feature and update mi_data. max_objective_score <- max(mi_data[available == TRUE]$objective_score) - best_feature <- mi_data[available == TRUE & objective_score == max_objective_score, ]$name[1] - mi_data[name %in% best_feature, ":="( - "selected" = TRUE, - "available" = FALSE, - "selection_step" = ii)] - + best_feature <- mi_data[available == TRUE & objective_score == max_objective_score, ]$name[1L] + mi_data[ + name %in% best_feature, + ":="( + "selected" = TRUE, + "available" = FALSE, + "selection_step" = ii + ) + ] + # Determine the features still available. available_features <- mi_data[available == TRUE, ]$name - + # Increment iteration counter. - ii <- ii + 1 + ii <- ii + 1L } - + # Create variable importance table from the score table. vimp_table <- mi_data[selected == TRUE, c("name", "objective_score", "selection_step")] - + # Create variable importance object. vimp_object <- methods::new( "vimpTable", vimp_table = data.table::data.table( "score" = vimp_table$selection_step, - "name" = vimp_table$name), + "name" = vimp_table$name + ), score_aggregation = "max", - invert = FALSE) + invert = FALSE + ) + + return(vimp_object) + } +) + + +# ..vimp (multivariate test) --------------------------------------------------- +setMethod( + "..vimp", + signature(object = "familiarMultivariateInfoVimpTestSingle"), + function(object, data, ...) { + # Suppress NOTES due to non-standard evaluation in data.table + score <- NULL + + # Return the single most important feature. + if (is_empty(data)) return(callNextMethod()) + + # Identify feature columns. + feature_columns <- get_feature_columns(data) + + # Calculate mutual information + mutual_information <- .compute_mutual_information( + data = data, + features = feature_columns + ) + + # Set vimp_table, and select only the best feature. + vimp_table <- data.table::data.table( + "score" = mutual_information, + "name" = feature_columns + ) + vimp_table <- vimp_table[score == max(score)] + + # Create variable importance object. + vimp_object <- methods::new( + "vimpTable", + vimp_table = vimp_table, + score_aggregation = "max", + invert = TRUE + ) + return(vimp_object) } ) @@ -300,25 +394,28 @@ setMethod( .compute_mutual_information <- function( data, features = NULL, - with_feature = NULL) { + with_feature = NULL +) { # If the comparison feature is NULL, compare with outcome. if (is.null(with_feature)) { # Set with_feature. with_feature <- get_outcome_columns(data) - + # Set the type of y. y_type <- switch( data@outcome_type, survival = "survival", binomial = "discrete", multinomial = "discrete", - continuous = "continuous", - count = "continuous") - + continuous = "continuous" + ) + if (data@outcome_type %in% c("survival")) { y <- survival::Surv( time = data@data[["outcome_time"]], - event = data@data[["outcome_event"]]) + event = data@data[["outcome_event"]] + ) + } else { y <- data@data[["outcome"]] } @@ -326,16 +423,16 @@ setMethod( } else { # Isolate y-feature y <- data@data[[with_feature]] - + # Set the type of y. y_type <- ..determine_mi_variable_type(y) } - + # Get features. if (is.null(features)) { features <- get_feature_columns(data) } - + # Compute mutual information. mutual_information <- sapply( features, @@ -343,11 +440,13 @@ setMethod( return(..compute_mutual_information( x = data@data[[feature]], y = y, - y_type = y_type)) + y_type = y_type + )) }, data = data, y = y, - y_type = y_type) + y_type = y_type + ) return(mutual_information) } @@ -358,59 +457,66 @@ setMethod( # Determine variable type. if (is.null(x_type)) x_type <- ..determine_mi_variable_type(x) if (is.null(y_type)) y_type <- ..determine_mi_variable_type(y) - + # Convert discrete variables to factors. if (x_type == "discrete" && !is.factor(x)) x <- as.factor(x) if (y_type == "discrete" && !is.factor(y)) y <- as.factor(y) - + # Drop unused levels from factors. if (x_type == "discrete") x <- droplevels(x) if (y_type == "discrete") y <- droplevels(y) - + if (x_type == "continuous" && is.integer(x)) x <- as.numeric(x) if (y_type == "continuous" && is.integer(y)) y <- as.numeric(y) - + if (require_package("praznik", message_type = "silent")) { # Praznik-based computation. - + if (y_type == "survival") { # Mutual information for survival. mutual_information <- ..compute_mutual_information_any_survival( x = x, - y = y) + y = y + ) } else { # Use praznik package. mutual_information <- praznik::miScores( X = x, Y = y, - threads = 1L) + threads = 1L + ) } } else { # Computation using internal methods. - + if (y_type == "survival") { # Mutual information for survival. mutual_information <- ..compute_mutual_information_any_survival( x = x, - y = y) + y = y + ) } else if (y_type == "discrete") { if (x_type == "continuous") { # Mutual information for continuous and discrete variables. mutual_information <- ..compute_mutual_information_continuous_discrete( x = x, - y = y) + y = y + ) } else if (x_type == "discrete") { # Mutual information for two discrete variables. mutual_information <- ..compute_mutual_information_discrete_discrete( x = x, - y = y) + y = y + ) + } else { ..error_reached_unreachable_code( - "..compute_mutual_information: unknown variable type encountered for variable x.") + "..compute_mutual_information: unknown variable type encountered for variable x." + ) } } else if (y_type == "continuous") { @@ -418,31 +524,35 @@ setMethod( # Mutual information for two continuous variables. mutual_information <- ..compute_mutual_information_continuous_continuous( x = x, - y = y) + y = y + ) } else if (x_type == "discrete") { # Mutual information for continuous and discrete variables. Note that # the order is reversed so that y is the discrete variable. mutual_information <- ..compute_mutual_information_continuous_discrete( x = y, - y = x) + y = x + ) } else { ..error_reached_unreachable_code( - "..compute_mutual_information: unknown variable type encountered for variable x.") + "..compute_mutual_information: unknown variable type encountered for variable x." + ) } } else { ..error_reached_unreachable_code( - "..compute_mutual_information: unknown variable type encountered for variable y.") + "..compute_mutual_information: unknown variable type encountered for variable y." + ) } } - + # Check for invalid values. if (!is.finite(mutual_information)) mutual_information <- 0.0 - + # Correct negative values. if (mutual_information < 0.0) mutual_information <- 0.0 - + return(mutual_information) } @@ -463,21 +573,24 @@ setMethod( if (is.factor(x)) { # Expand x by using dummy coding. x <- stats::model.matrix(~ . - 1, data.frame(x)) - + # Calculate concordance indices ci <- apply( - x, 2, + x, + 2L, function(x_data, y_data) { return(..compute_concordance_index( x = x_data, - time = y_data[, 1], - event = y_data[, 2])) + time = y_data[, 1L], + event = y_data[, 2L] + )) }, - y_data = y) - + y_data = y + ) + # Calculate mutual information from the concordance indices - mi <- -0.5 * log(1.0 - (2.0 * (ci - 0.5))^2 + 1E-10) - + mi <- -0.5 * log(1.0 - (2.0 * (ci - 0.5))^2.0 + 1.0E-10) + # Find the maximum mutual information. mi <- max(mi) @@ -485,13 +598,14 @@ setMethod( # Compute the concordance index. ci <- ..compute_concordance_index( x = x, - time = y[, 1], - event = y[, 2]) - + time = y[, 1L], + event = y[, 2L] + ) + # Compute mutual information from the concordance index. - mi <- -0.5 * log(1.0 - (2.0 * (ci - 0.5))^2 + 1E-10) + mi <- -0.5 * log(1.0 - (2.0 * (ci - 0.5))^2.0 + 1.0E-10) } - + return(mi) } @@ -503,24 +617,25 @@ setMethod( # "Calculation of amount of information about a random function contained in # another such function". American Mathematical Society Translations: Series # 2. 12: 199-246 - + # Expand y by using dummy coding. x is the continuous variable. y <- stats::model.matrix(~ . - 1, data.frame(y)) - + # Calculate mutual information using correlation. mi <- apply( - y, 2, + y, + 2L, function(y, x) { - return(-0.5 * log(1.0 - stats::cor( - x = x, - y = y, - method = "spearman")^2 + 1E-10)) + return( + -0.5 * log(1.0 - stats::cor(x = x, y = y, method = "spearman")^2.0 + 1.0E-10) + ) }, - x = x) + x = x + ) # Select the maximum mutual information. mi <- max(mi) - + return(mi) } @@ -530,18 +645,18 @@ setMethod( # Direct, exact, calculation of mutual information for binomial and # multinomial outcomes Mutual information is defined as: I(X,Y) = H(X) - # H(X|Y) = H(Y) - H(Y|X) = H(X) + H(Y) - H(X,Y), and we calculate entropies - + # Calculate probability distributions p <- ..compute_mutual_information_conditional_probability(x = x, y = y) - + # Calculate entropies for marginal and joint distributions - h_j <- -sum(p$prob_j$prob_j * log(p$prob_j$prob_j + 1E-10)) - h_k <- -sum(p$prob_k$prob_k * log(p$prob_k$prob_k + 1E-10)) - h_jk <- -sum(p$prob_kj$prob_kj * log(p$prob_kj$prob_kj + 1E-10)) - + h_j <- -sum(p$prob_j$prob_j * log(p$prob_j$prob_j + 1.0E-10)) + h_k <- -sum(p$prob_k$prob_k * log(p$prob_k$prob_k + 1.0E-10)) + h_jk <- -sum(p$prob_kj$prob_kj * log(p$prob_kj$prob_kj + 1.0E-10)) + # Compute mutual information mi <- h_j + h_k - h_jk - + return(mi) } @@ -553,8 +668,8 @@ setMethod( # "Calculation of amount of information about a random function contained in # another such function". American Mathematical Society Translations: Series # 2. 12: 199-246 - - return(-0.5 * log(1 - stats::cor(x = x, y = y, method = "spearman")^2 + 1E-10)) + + return(-0.5 * log(1.0 - stats::cor(x = x, y = y, method = "spearman")^2.0 + 1.0E-10)) } @@ -562,26 +677,28 @@ setMethod( ..compute_mutual_information_conditional_probability <- function(x, y) { # Suppress NOTES due to non-standard evaluation in data.table value <- NULL - + # Total number of training instances n <- length(x) - + # Create data table from data data <- data.table::data.table( "value" = x, - "class" = y) - + "class" = y + ) + # p(k,j): joint probability for the combination of class k and value j p_kj <- data[, list(prob_kj = .N / n), by = list(value, class)] - + # p(k): marginal probability for class k p_k <- data[, list(prob_k = .N / n), by = class] - + # p(j): marginal probability for value j p_j <- data[, list(prob_j = .N / n), by = value] - + return(list( "prob_kj" = p_kj, "prob_k" = p_k, - "prob_j" = p_j)) + "prob_j" = p_j + )) } diff --git a/R/VimpS4OtherMethods.R b/R/VimpS4OtherMethods.R index d7f6aeef..068f581c 100644 --- a/R/VimpS4OtherMethods.R +++ b/R/VimpS4OtherMethods.R @@ -4,19 +4,23 @@ NULL setClass( "familiarRandomVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) setClass( "familiarNoneVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) setClass( "familiarSignatureVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) setClass( "familiarNoFeaturesVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) diff --git a/R/VimpS4Regression.R b/R/VimpS4Regression.R index 772ed000..fcab87e0 100644 --- a/R/VimpS4Regression.R +++ b/R/VimpS4Regression.R @@ -4,16 +4,19 @@ NULL setClass( "familiarRegressionVimp", - contains = "familiarVimpMethod") + contains = "familiarVimpMethod" +) setClass( "familiarUnivariateRegressionVimp", - contains = "familiarRegressionVimp") + contains = "familiarRegressionVimp" +) setClass( "familiarMultivariateRegressionVimp", contains = "familiarRegressionVimp", - prototype = methods::prototype(multivariate = TRUE)) + prototype = methods::prototype(multivariate = TRUE) +) @@ -24,10 +27,10 @@ setMethod( function(.Object, ...) { # Update with parent class first. .Object <- callNextMethod() - + # Set the required package .Object@multivariate <- TRUE - + return(.Object) } ) @@ -46,6 +49,12 @@ setMethod( "is_available", signature(object = "familiarRegressionVimp"), function(object, ...) { + + if (object@outcome_type == "count") { + ..deprecation_count() + return(FALSE) + } + return(TRUE) } ) @@ -62,78 +71,85 @@ setMethod( param$learner <- list() param$metric <- list() param$drop_rate <- list() - + if (is.null(data)) return(param) - + # number of bootstrap iterations ------------------------------------------- param$n_bootstrap <- .set_hyperparameter( default = 10L, type = "integer", - range = c(1, Inf), - randomise = FALSE) - + range = c(1L, Inf), + randomise = FALSE + ) + # rate at which least performing features are dropped ---------------------- param$drop_rate <- .set_hyperparameter( default = 0.333, type = "numeric", - range = c(0, 1), - randomise = FALSE) - + range = c(0.0, 1.0), + randomise = FALSE + ) + # distribution family to use for linear regression ------------------------- learner_default <- switch( object@outcome_type, "binomial" = "glm_logistic", "multinomial" = "glm_multinomial", "continuous" = "glm_gaussian", - "count" = "glm_poisson", - "survival" = "cox") - + "survival" = "cox" + ) + # Set the learner range, i.e. all generalised linear models. learner_range <- unique(c( .get_available_glm_learners(), .get_available_cox_learners(), - .get_available_survival_regression_learners())) - + .get_available_survival_regression_learners() + )) + # Determine which learners are available for the outcome_type learner_is_available <- sapply( learner_range, .check_learner_outcome_type, outcome_type = object@outcome_type, - as_flag = TRUE) - + as_flag = TRUE + ) + # Create the learner hyperparameter param$learner <- .set_hyperparameter( default = learner_default, type = "factor", range = learner_range[learner_is_available], - randomise = FALSE) - + randomise = FALSE + ) + # performance metric ------------------------------------------------------- metric_default <- switch( object@outcome_type, "binomial" = "auc_roc", "multinomial" = "auc_roc", "continuous" = "mse", - "count" = "msle", - "survival" = "concordance_index") - + "survival" = "concordance_index" + ) + # Get all available metrics. metric_range <- .get_all_metrics() - + # Determine which of the metrics is available for the outcome type. metric_is_available <- sapply( metric_range, .check_metric_outcome_type, outcome_type = object@outcome_type, - as_flag = TRUE) - + as_flag = TRUE + ) + # Create the metric hyperparameter param$metric <- .set_hyperparameter( default = metric_default, type = "factor", range = metric_range[metric_is_available], - randomise = FALSE) - + randomise = FALSE + ) + return(param) } ) @@ -147,59 +163,70 @@ setMethod( function(object, data, ...) { # Suppress NOTES due to non-standard evaluation in data.table score <- name <- available <- selected <- NULL - + if (is_empty(data)) return(callNextMethod()) - + # Aggregate data. data <- aggregate_data(data) - + # Find feature columns in data table. feature_columns <- get_feature_columns(x = data) - + # Generate iteration list. iteration_list <- .create_bootstraps( n_iter = object@hyperparameters$n_bootstrap, outcome_type = object@outcome_type, - data = data@data) - + data = data@data + ) + # Create a generic model. fam_model <- promote_learner( - object = methods::new("familiarModel", - outcome_type = object@outcome_type, - learner = as.character(object@hyperparameters$learner), - fs_method = "none", - feature_info = object@feature_info, - outcome_info = .compute_outcome_distribution_data( - object = object@outcome_info, - data = data))) - + object = methods::new( + "familiarModel", + outcome_type = object@outcome_type, + learner = as.character(object@hyperparameters$learner), + vimp_method = "none", + feature_info = object@feature_info, + outcome_info = .compute_outcome_distribution_data( + object = object@outcome_info, + data = data + ) + ) + ) + # Create metric objects. metric_object_list <- lapply( as.character(object@hyperparameters$metric), as_metric, - object = fam_model) - + outcome_type = object@outcome_type + ) + # Add baseline values for each metric. - metric_object_list <- lapply(metric_object_list, + metric_object_list <- lapply( + metric_object_list, set_metric_baseline_value, object = fam_model, - data = data) - + data = data + ) + # Generate score table. score_table <- data.table::data.table( "name" = feature_columns, "available" = TRUE, "selected" = FALSE, - "select_step" = 0, - "score" = as.double(NA)) - + "select_step" = 0L, + "score" = NA_real_ + ) + # Find signature features, if any. signature_feature <- names(object@feature_info)[sapply(object@feature_info, is_in_signature)] - - if (length(signature_feature) > 0 && - is(object, "familiarMultivariateRegressionVimp")) { + + if ( + length(signature_feature) > 0L && + is(object, "familiarMultivariateRegressionVimp") + ) { # For multivariate regression with features in a signature. - + # Get the objective score for the signature. objective_score <- ..regression_vimp_assess_feature( feature = NULL, @@ -207,25 +234,30 @@ setMethod( metric_objects = metric_object_list, data = data, iteration_list = iteration_list, - fixed_set = signature_feature) - + fixed_set = signature_feature + ) + # Set max_objective_score. max_objective_score <- objective_score$score - + # Update the score table. - score_table[name %in% signature_feature, ":="( - "score" = max_objective_score, - "available" = FALSE, - "selected" = TRUE, - "select_step" = seq_len(length(signature_feature)))] - + score_table[ + name %in% signature_feature, + ":="( + "score" = max_objective_score, + "available" = FALSE, + "selected" = TRUE, + "select_step" = seq_len(length(signature_feature)) + ) + ] + # Iteration counter. - ii <- length(signature_feature) + 1 + ii <- length(signature_feature) + 1L } else { # For multivariate regression without signature features, or univariate # regression. - + # Compute objective score for every feature. objective_score <- lapply( feature_columns, @@ -234,67 +266,76 @@ setMethod( metric_objects = metric_object_list, data = data, iteration_list = iteration_list, - fixed_set = NULL) - + fixed_set = NULL + ) + # Combine into data.table. objective_score <- data.table::rbindlist(objective_score) - + # In case of univariate regression, return at this point. if (is(object, "familiarUnivariateRegressionVimp")) { # Create variable importance object. - vimp_object <- methods::new("vimpTable", + vimp_object <- methods::new( + "vimpTable", vimp_table = data.table::data.table( "score" = objective_score$score, - "name" = objective_score$name), + "name" = objective_score$name + ), score_aggregation = "max", - invert = TRUE) - + invert = TRUE + ) + return(vimp_object) } - + # Proceed with forward selection and multivariate regression. - + # Find the best performing feature. max_objective_score <- max(objective_score$score) best_feature <- objective_score[score == max_objective_score]$name - + # Update the score_table. - score_table[name %in% best_feature, ":="( - "score" = max_objective_score, - "available" = FALSE, - "selected" = TRUE, - "select_step" = 1)] - + score_table[ + name %in% best_feature, + ":="( + "score" = max_objective_score, + "available" = FALSE, + "selected" = TRUE, + "select_step" = 1L + ) + ] + # Identify features to be dropped. n_available <- nrow(objective_score) - length(best_feature) n_dropped <- floor(object@hyperparameters$drop_rate * n_available) - + # Make dropped features unavailable. - if (n_dropped > 0) { + if (n_dropped > 0L) { # Identify the worst performing features. bad_features <- tail(objective_score[(order(-score))], n = n_dropped)$name score_table[name %in% bad_features, "available" := FALSE] } - + # Iteration counter. - ii <- 2 + ii <- 2L } - + # Determine the features still available. available_features <- score_table[available == TRUE, ]$name selected_features <- score_table[selected == TRUE, ]$name - + # Set current objective score. previous_objective_score <- max_objective_score - - - while (length(available_features) > 0) { + + + while (length(available_features) > 0L) { # Generate new iteration list. iteration_list <- .create_bootstraps( n_iter = object@hyperparameters$n_bootstrap, outcome_type = object@outcome_type, - data = data@data) - + data = data@data + ) + # Compute objective score for every feature. objective_score <- lapply( available_features, @@ -303,64 +344,71 @@ setMethod( metric_objects = metric_object_list, data = data, iteration_list = iteration_list, - fixed_set = selected_features) - + fixed_set = selected_features + ) + # Combine into data.table. objective_score <- data.table::rbindlist(objective_score) - + # Find the best performing feature. max_objective_score <- max(objective_score$score) best_feature <- objective_score[score == max_objective_score]$name - + # Only continue adding, if the expected value changed. if (max_objective_score <= previous_objective_score) break - + # Update the score_table. - score_table[name %in% best_feature, ":="( - "score" = max_objective_score, - "available" = FALSE, - "selected" = TRUE, - "select_step" = ii)] - + score_table[ + name %in% best_feature, + ":="( + "score" = max_objective_score, + "available" = FALSE, + "selected" = TRUE, + "select_step" = ii + ) + ] + # Identify features to be dropped. n_available <- nrow(objective_score) - length(best_feature) n_dropped <- floor(object@hyperparameters$drop_rate * n_available) - + # Make dropped features unavailable. - if (n_dropped > 0) { + if (n_dropped > 0L) { # Identify the worst performing features. bad_features <- tail(objective_score[(order(-score))], n = n_dropped)$name score_table[name %in% bad_features, "available" := FALSE] } - + # In addition, drop any features that do not improve upon the previous # best score. bad_features <- objective_score[score < previous_objective_score]$name score_table[name %in% bad_features, "available" := FALSE] - + # Determine the features still available. available_features <- score_table[available == TRUE, ]$name selected_features <- score_table[selected == TRUE, ]$name - + # Update iteration counter. - ii <- ii + 1 - + ii <- ii + 1L + # Set current objective score. previous_objective_score <- max_objective_score } - + # Create variable importance table from the score table. vimp_table <- score_table[selected == TRUE, c("name", "score", "select_step")] - + # Create variable importance object. vimp_object <- methods::new( "vimpTable", vimp_table = data.table::data.table( "score" = vimp_table$select_step, - "name" = vimp_table$name), + "name" = vimp_table$name + ), score_aggregation = "max", - invert = FALSE) - + invert = FALSE + ) + return(vimp_object) } ) @@ -373,15 +421,28 @@ setMethod( metric_objects, data, iteration_list, - fixed_set) { + fixed_set +) { # Make local copy of the data prior to filtering features. data <- data.table::copy(data) - + # Remove features that are neither in feature nor fixed_set. data <- filter_features( data, - available_features = c(feature, fixed_set)) - + available_features = c(feature, fixed_set) + ) + + # Find features that are required for processing the data and building the + # model. + fam_model@required_features <- get_required_features( + x = data, + feature_info_list = fam_model@feature_info + ) + fam_model@model_features <- get_model_features( + x = data, + feature_info_list = fam_model@feature_info + ) + # Iterate over bootstraps. performance_data <- lapply( seq_along(iteration_list$train_list), @@ -389,10 +450,12 @@ setMethod( # Select train and test data. train_data <- select_data_from_samples( data = data, - samples = iteration_list$train_list[[bootstrap_id]]) + samples = iteration_list$train_list[[bootstrap_id]] + ) test_data <- select_data_from_samples( data = data, - samples = iteration_list$valid_list[[bootstrap_id]]) + samples = iteration_list$valid_list[[bootstrap_id]] + ) # Update the familiar model. fam_model@hyperparameters$sign_size <- length(c(feature, fixed_set)) @@ -401,60 +464,70 @@ setMethod( parameter_list <- get_default_hyperparameters( object = fam_model, data = train_data, - user_list = fam_model@hyperparameters) + user_list = fam_model@hyperparameters + ) # Update the parameter list With user-defined variables. parameter_list <- .update_hyperparameters( parameter_list = parameter_list, - user_list = fam_model@hyperparameters) + user_list = fam_model@hyperparameters + ) # Update hyperparameters to set any fixed parameters. fam_model@hyperparameters <- lapply( parameter_list, - function(list_entry) list_entry$init_config) + function(list_entry) list_entry$init_config + ) # Set additional parameters, e.g. the learner family. fam_model <- ..set_vimp_parameters( object = fam_model, - method = fam_model@learner) + method = fam_model@learner + ) # Train the model using the train data. fam_model <- suppressWarnings(.train( object = fam_model, data = train_data, get_additional_info = FALSE, - trim_model = FALSE)) + trim_model = FALSE + )) # Compute score using the metrics. score_table <- mapply( - function(data, data_set, object, metric_objects, settings) { + function(data, data_set, object, metric_objects) { # Get metric names. metric_names <- sapply( metric_objects, - function(metric_object) metric_object@metric) + function(metric_object) metric_object@metric + ) # Predict for the in-bag and out-of-bag datasets. prediction_table <- .predict( object = object, - data = data) + data = data + ) # Compute objective scores. metrics_objective_score <- sapply( metric_objects, compute_objective_score, - data = prediction_table) + data = prediction_table + ) # Return as data.table. return(data.table::data.table( "metric" = metric_names, "data_set" = data_set, - "objective_score" = metrics_objective_score)) + "objective_score" = metrics_objective_score + )) }, data = list(train_data, test_data), data_set = c("training", "validation"), MoreArgs = list( "object" = fam_model, - "metric_objects" = metric_objects), + "metric_objects" = metric_objects + ), SIMPLIFY = FALSE ) @@ -467,7 +540,8 @@ setMethod( # Set the column order. data.table::setcolorder( x = score_table, - neworder = c("run_id")) + neworder = c("run_id") + ) return(score_table) }, @@ -480,15 +554,18 @@ setMethod( # Combine performance data to a single table and compute optimisation scores. performance_data <- .compute_metric_optimisation_score( score_table = data.table::rbindlist(performance_data), - optimisation_function = "max_validation") - + optimisation_function = "max_validation" + ) + # Compute the summary score. performance_data <- .summarise_metric_optimisation_score( score_table = performance_data, - method = "median") - + method = "median" + ) + # Return sample mean and standard deviation of the objective score. return(data.table::data.table( "name" = feature, - "score" = performance_data$optimisation_score)) + "score" = performance_data$optimisation_score + )) } diff --git a/R/VimpTable.R b/R/VimpTable.R index 8e0783a5..42489d57 100644 --- a/R/VimpTable.R +++ b/R/VimpTable.R @@ -19,13 +19,15 @@ setMethod( cat(paste0( "An empty variable importance table for the ", object@vimp_method, " variable importance method ", - "(", .familiar_version_string(object), ").")) + "(", .familiar_version_string(object), ")." + )) } else { cat(paste0( "A variable importance table for the ", object@vimp_method, " variable importance method ", - "(", .familiar_version_string(object), "):\n\n")) + "(", .familiar_version_string(object), "):\n\n" + )) if (object@invert) { show(object@vimp_table[order(-score)]) @@ -87,7 +89,8 @@ setGeneric( "get_vimp_table", function( x, state = "ranked", - ...) { + ... + ) { standardGeneric("get_vimp_table") } ) @@ -116,7 +119,7 @@ setMethod( signature(x = "character"), function(x, state = "ranked", ...) { # Dispatch to list, if x contains more than one element. - if (length(x) > 1) { + if (length(x) > 1L) { return(get_vimp_table(as.list(x), state = state, ...)) } @@ -127,7 +130,8 @@ setMethod( if (is.list(x)) { x <- as_vimp_table_object( x, - project_id = "") + project_id = "" + ) } # Make sure the object is updated. @@ -182,7 +186,7 @@ setMethod( function(x, state = "ranked", ...) { # Check if the attribute has been set. if (is.null(x@vimp_table_list)) { - warning("No variable importance tables are present.") + ..warning("No variable importance tables are present.") return(NULL) } @@ -192,7 +196,8 @@ setMethod( x@vimp_table_list, get_vimp_table, state = state, - ...)) + ... + )) } ) @@ -212,7 +217,8 @@ setMethod( # object. vimp_object <- ..vimp( object = x, - data = data) + data = data + ) # Set up a table with clustering information. cluster_table <- .create_clustering_table(x@feature_info) @@ -234,7 +240,8 @@ setMethod( } else { return(get_vimp_table( x = vimp_object, - state = state)) + state = state + )) } } ) @@ -274,45 +281,55 @@ setMethod( x = data_categorical, y = x@encoding_table, by.x = "name", - by.y = "reference_name") + by.y = "reference_name" + ) # Summarise score by single value according to the method indicated by the # score_aggregation attribute. if (x@score_aggregation == "max") { data_categorical <- suppressWarnings( - data_categorical[, list(score = max(score, na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = max(score, na.rm = TRUE)), by = original_name] + ) } else if (x@score_aggregation == "abs_max") { data_categorical <- suppressWarnings( - data_categorical[, list(score = max(abs(score), na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = max(abs(score), na.rm = TRUE)), by = original_name] + ) } else if (x@score_aggregation == "min") { data_categorical <- suppressWarnings( - data_categorical[, list(score = min(score, na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = min(score, na.rm = TRUE)), by = original_name] + ) } else if (x@score_aggregation == "abs_min") { data_categorical <- suppressWarnings( - data_categorical[, list(score = min(abs(score), na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = min(abs(score), na.rm = TRUE)), by = original_name] + ) } else if (x@score_aggregation == "mean") { data_categorical <- suppressWarnings( - data_categorical[, list(score = mean(score, na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = mean(score, na.rm = TRUE)), by = original_name] + ) } else if (x@score_aggregation == "abs_mean") { data_categorical <- suppressWarnings( - data_categorical[, list(score = mean(abs(score), na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = mean(abs(score), na.rm = TRUE)), by = original_name] + ) } else if (x@score_aggregation == "median") { data_categorical <- suppressWarnings( - data_categorical[, list(score = stats::median(score, na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = stats::median(score, na.rm = TRUE)), by = original_name] + ) } else if (x@score_aggregation == "abs_median") { data_categorical <- suppressWarnings( - data_categorical[, list(score = stats::median(abs(score), na.rm = TRUE)), by = original_name]) + data_categorical[, list(score = stats::median(abs(score), na.rm = TRUE)), by = original_name] + ) } else { ..error_reached_unreachable_code(paste0( - "decode_vimp_table,vimpTable: unknown score aggregation method")) + "decode_vimp_table,vimpTable: unknown score aggregation method" + )) } # Change name of original_name column to name @@ -322,7 +339,8 @@ setMethod( # Combine to single data.table vimp_table <- rbind( data_non_categorical, - data_categorical) + data_categorical + ) # Replace infinite/nan/etc values by NA vimp_table[!is.finite(score), "score" := NA_real_] @@ -347,11 +365,30 @@ setMethod( +# decluster_vimp_table (list) -------------------------------------------------- +setMethod( + "decluster_vimp_table", + signature(x = "list"), + function(x, ...) { + # If the list is empty, return NULL instead. + if (is_empty(x)) return(NULL) + + # Dispatch to method for single variable importance tables. + return(lapply( + x, + decluster_vimp_table + )) + } +) + + + # decluster_vimp_table (vimpTable) --------------------------------------------- setMethod( "decluster_vimp_table", signature(x = "vimpTable"), function(x, show_weights = FALSE, show_cluster_name = FALSE, ...) { + # Check if the table has already been declustered. if (.as_vimp_table_state(x@state) >= "declustered") return(x) @@ -374,17 +411,20 @@ setMethod( by.x = "name", by.y = "cluster_name", all.x = FALSE, - all.y = FALSE) + all.y = FALSE + ) # Adapt table by removing the original name column and renaming the # feature name column. vimp_table[, ":="( "name" = NULL, - "feature_required" = NULL)] + "feature_required" = NULL + )] data.table::setnames( x = vimp_table, old = "feature_name", - new = "name") + new = "name" + ) # Remove weights, unless explicitly stated. if (!show_weights && "weight" %in% colnames(vimp_table)) { @@ -422,7 +462,8 @@ setMethod( # Dispatch to method for single variable importance tables. return(lapply( x, - recluster_vimp_table)) + recluster_vimp_table + )) } ) @@ -462,7 +503,8 @@ setMethod( by.x = "name", by.y = "feature_name", all.x = FALSE, - all.y = TRUE) + all.y = TRUE + ) # Compute mean score for all features in the same cluster. vimp_table <- vimp_table[, list("score" = mean(score, na.rm = TRUE)), by = "cluster_name"] @@ -472,7 +514,8 @@ setMethod( data.table::setnames( x = vimp_table, old = "cluster_name", - new = "name") + new = "name" + ) # Update the vimp_table attribute. x@vimp_table <- vimp_table @@ -522,16 +565,16 @@ setMethod( # Compute dense ranks, with NA ranked as NA. if (x@invert) { - vimp_table[, "rank" := data.table::frank( - -score, - ties.method = "dense", - na.last = "keep")] + vimp_table[ + , + "rank" := data.table::frank(-score, ties.method = "dense", na.last = "keep") + ] } else { - vimp_table[, "rank" := data.table::frank( - score, - ties.method = "dense", - na.last = "keep")] + vimp_table[ + , + "rank" := data.table::frank(score, ties.method = "dense", na.last = "keep") + ] } # Update vimp_table attribute. @@ -607,7 +650,8 @@ setMethod( if (x@state != "initial") { ..error_reached_unreachable_code(paste0( "remove_signature_features,vimpTable: can only remove signature ", - "features from a variable importance table in its initial state.")) + "features from a variable importance table in its initial state." + )) } # If there are no signature features, we don't need to remove them. @@ -624,7 +668,8 @@ setMethod( # Find names of the encoded features as they appear in the variable # importance table. encoded_features <- x@encoding_table[ - original_name %in% encoded_features]$reference_name + original_name %in% encoded_features + ]$reference_name # Combine encoded and non-encoded feature names. features <- c(encoded_features, non_encoded_features) @@ -660,7 +705,8 @@ setMethod( return(lapply( x, update_vimp_table_to_reference, - reference_cluster_table = reference_cluster_table)) + reference_cluster_table = reference_cluster_table + )) } ) @@ -693,7 +739,8 @@ setMethod( by.x = "name", by.y = "feature_name", all.x = FALSE, - all.y = TRUE) + all.y = TRUE + ) # Compute mean score for all features in the same cluster. vimp_table[, "score" := mean(score, na.rm = TRUE), by = "cluster_name"] @@ -739,14 +786,15 @@ setMethod( vimp_method <- unique(sapply(x, function(x) x@vimp_method)) # Dispatch to separate lists. - if (length(vimp_method) > 1) { + if (length(vimp_method) > 1L) { # Initialise list to store variable importance tables. vimp_table_list <- list() for (current_vimp_method in vimp_method) { # Identify elements which use the same variable importance method. same_vimp_method <- sapply( x, - function(x, vimp_method) x@vimp_method == current_vimp_method) + function(x, vimp_method) x@vimp_method == current_vimp_method + ) # Store all elements with the same variable importance method as an # element in the vimp_table_list list. @@ -758,7 +806,8 @@ setMethod( vimp_table_list, aggregate_vimp_table, run_table = run_table, - ...)) + ... + )) } # Select only elements that share the same dataset. @@ -769,7 +818,8 @@ setMethod( # Get a list with identifiers. run_id_list <- .get_iteration_identifiers( run = list("run_table" = run_table), - perturb_level = ii) + perturb_level = ii + ) # Check whether there are any matching data and run ids by checking if # matching creates a non-empty table. @@ -781,7 +831,8 @@ setMethod( } return(!is_empty(x@run_table[ - data_id == run_id_list$data & run_id == run_id_list$run])) + data_id == run_id_list$data & run_id == run_id_list$run + ])) }, run_id_list = run_id_list ) @@ -816,7 +867,8 @@ setMethod( return(collect_vimp_table( x = list(x), run_table = run_table, - ...)) + ... + )) } ) @@ -858,7 +910,8 @@ setGeneric( x, aggregation_method, rank_threshold = NULL, - ...) { + ... + ) { standardGeneric("aggregate_vimp_table") } ) @@ -904,6 +957,25 @@ setMethod( # Keep only non-empty elements. x <- x[!empty_elements] + # Split by variable importance method. + vimp_methods <- sapply(x, function(x) (x@vimp_method)) + if (length(unique(vimp_methods)) > 1L) { + vimp_table_list <- lapply( + unique(vimp_methods), + function(current_vimp_method, vimp_methods, x) { + return(x[vimp_methods == current_vimp_method]) + }, + vimp_methods = vimp_methods, + x = x + ) + return(lapply( + vimp_table_list, + aggregate_vimp_table, + aggregation_method = aggregation_method, + rank_threshold = rank_threshold + )) + } + # Preprocess individual elements prior to merging. x <- lapply(x, preprocess_vimp_table, ...) @@ -927,58 +999,68 @@ setMethod( vimp_table <- data.table::rbindlist(vimp_table, use.names = TRUE) # Create an aggregated variable importance table. - aggregated_vimp_object <- methods::new("vimpTable", x[[1]]) + aggregated_vimp_object <- methods::new("vimpTable", x[[1L]]) # Attach the aggregated variable importance table. aggregated_vimp_object@vimp_table <- vimp_table if (aggregation_method == "none") { aggregated_vimp_object <- .compute_rank_mean_score( - x = aggregated_vimp_object) + x = aggregated_vimp_object + ) } else if (aggregation_method %in% c("mean", "median", "best", "worst")) { # Perform aggregation using simple ensemble methods if (aggregation_method == "mean") { aggregated_vimp_object <- .compute_rank_mean_rank( - x = aggregated_vimp_object) + x = aggregated_vimp_object + ) } else if (aggregation_method == "median") { aggregated_vimp_object <- .compute_rank_median_rank( - x = aggregated_vimp_object) + x = aggregated_vimp_object + ) } else if (aggregation_method == "best") { aggregated_vimp_object <- .compute_rank_best_rank( - x = aggregated_vimp_object) + x = aggregated_vimp_object + ) } else if (aggregation_method == "worst") { aggregated_vimp_object <- .compute_rank_worst_rank( - x = aggregated_vimp_object) + x = aggregated_vimp_object + ) } } else if (aggregation_method %in% c("stability", "exponential")) { # Perform aggregation using occurence-based methods. if (is.null(rank_threshold)) { rank_threshold <- .optimise_feature_occurrence_threshold( - vimp_table = aggregated_vimp_object) + vimp_table = aggregated_vimp_object + ) } if (aggregation_method == "stability") { aggregated_vimp_object <- .compute_rank_stability( x = aggregated_vimp_object, - rank_threshold = rank_threshold) + rank_threshold = rank_threshold + ) } else if (aggregation_method == "exponential") { aggregated_vimp_object <- .compute_rank_exponential( x = aggregated_vimp_object, - rank_threshold = rank_threshold) + rank_threshold = rank_threshold + ) } } else if (aggregation_method %in% c( - "borda", "enhanced_borda", "truncated_borda", "enhanced_truncated_borda")) { + "borda", "enhanced_borda", "truncated_borda", "enhanced_truncated_borda" + )) { # Perform aggregation using Borda-count based methods if (is.null(rank_threshold)) { rank_threshold <- .optimise_feature_occurrence_threshold( - vimp_table = aggregated_vimp_object) + vimp_table = aggregated_vimp_object + ) } if (aggregation_method == "borda") { @@ -986,33 +1068,38 @@ setMethod( x = aggregated_vimp_object, rank_threshold = rank_threshold, truncated = FALSE, - enhanced = FALSE) + enhanced = FALSE + ) } else if (aggregation_method == "enhanced_borda") { aggregated_vimp_object <- .compute_rank_borda( x = aggregated_vimp_object, rank_threshold = rank_threshold, truncated = FALSE, - enhanced = TRUE) + enhanced = TRUE + ) } else if (aggregation_method == "truncated_borda") { aggregated_vimp_object <- .compute_rank_borda( x = aggregated_vimp_object, rank_threshold = rank_threshold, truncated = TRUE, - enhanced = FALSE) + enhanced = FALSE + ) } else if (aggregation_method == "enhanced_truncated_borda") { aggregated_vimp_object <- .compute_rank_borda( x = aggregated_vimp_object, rank_threshold = rank_threshold, truncated = TRUE, - enhanced = TRUE) + enhanced = TRUE + ) } } else { ..error_reached_unreachable_code(paste0( "aggregate_vimp_table,list: encountered an unknown aggregation method:", - aggregation_method)) + aggregation_method + )) } # Force ranking of the aggregated variable importance object. @@ -1042,7 +1129,8 @@ setMethod( x = as.list(x), aggregation_method = aggregation_method, rank_threshold = rank_threshold, - ...)) + ... + )) } ) @@ -1062,7 +1150,8 @@ setMethod( x = list(x), aggregation_method = aggregation_method, rank_threshold = rank_threshold, - ...)) + ... + )) } ) @@ -1090,7 +1179,7 @@ setMethod( function(x, aggregation_method, rank_threshold = NULL, ...) { # Check if the attribute has been set. if (is.null(x@vimp_table_list)) { - warning("No variable importance tables are present.") + ..warning("No variable importance tables are present.") return(NULL) } @@ -1101,7 +1190,8 @@ setMethod( aggregate_vimp_table, aggregation_method = aggregation_method, rank_threshold = rank_threshold, - ...)) + ... + )) } ) @@ -1129,24 +1219,28 @@ setMethod( "declustered", "reclustered", "ranked", - "aggregated") + "aggregated" + ) if (!all(x %in% state_levels)) { ..error_reached_unreachable_code( - ".as_vimp_table_state: one or more of x could not be matched to vimp table states.") + ".as_vimp_table_state: one or more of x could not be matched to vimp table states." + ) } return(factor( x = x, levels = state_levels, - ordered = TRUE)) + ordered = TRUE + )) } as_vimp_table_object <- function( x, - project_id) { + project_id +) { # Helper function for turning variable importance tables generated prior to # version 1.2.0 into vimpTable objects. @@ -1170,7 +1264,7 @@ as_vimp_table_object <- function( vimp_table <- methods::new( "vimpTable", vimp_table = vimp_table, - vimp_method = x$fs_method, + vimp_method = x$vimp_method, run_table = x$run_table, score_aggregation = "max", encoding_table = NULL, @@ -1178,7 +1272,8 @@ as_vimp_table_object <- function( invert = invert, project_id = project_id, familiar_version = "1.2.0", - state = "declustered") + state = "declustered" + ) return(vimp_table) } @@ -1193,7 +1288,8 @@ prepare_vimp_table_object <- function( encoding_table = NULL, cluster_table = NULL, invert, - state) { + state +) { # This function helps prepare a vimpTable object for unit testing. It is not # used as part of the main workflow. @@ -1206,7 +1302,8 @@ prepare_vimp_table_object <- function( encoding_table = encoding_table, cluster_table = cluster_table, invert = invert, - state = state) + state = state + ) # Add package version. proto_vimp_table <- add_package_version(proto_vimp_table) diff --git a/R/aaa.R b/R/aaa.R index cd329dfa..49a338e2 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -1,2 +1,10 @@ # Environment holding global variables and settings. familiar_global_env <- new.env(parent = emptyenv()) + +# Prevents notes on co-routines using the coro package. The coro developers may +# be able to fix this issue at some point. See +# https://github.com/r-lib/coro/issues/40 +utils::globalVariables(c( + "generator_env", + "exits" +)) diff --git a/cran-comments.md b/cran-comments.md index 4b9e67f4..bdaacc37 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,4 +1,4 @@ -Update familiar to version 1.5.0 +Update familiar to version 2.0.0 Vignettes are pre-compiled to avoid long compilation times on build (several minutes). @@ -9,7 +9,6 @@ suite takes several hours. Locally run unit and integrated tests did not produce errors or (unexpected) warnings. - # R CMD check results R CMD check was run on GitHub using @@ -21,13 +20,7 @@ windows-latest: ---------------------------------- macos-latest -0 errors | 0 warnings | 1 note - -* checking installed package size ... NOTE - installed size is 5.4Mb - sub-directories of 1Mb or more: - help 1.2Mb - R 4.0Mb +0 errors | 0 warnings | 0 notes ---------------------------------- ubuntu-latest: @@ -41,46 +34,6 @@ R CMD check (noSuggests) was run on GitHub using https://github.com/alexzwanenburg/familiar/actions/workflows/auto-test-no-suggests-pull.yml (ubuntu-latest) and locally (windows-latest). ----------------------------------- -windows-latest: - -* checking installed package size ... NOTE - installed size is 5.8Mb - sub-directories of 1Mb or more: - R 3.5Mb - help 1.2Mb - ----------------------------------- -ubuntu-latest: -0 errors | 2 warnings | 2 note - -* checking package dependencies ... WARNING - Warning: Skipping vignette re-building - Packages suggested but not available for checking: - 'BART', 'cluster', 'CORElearn', 'coro', 'dynamicTreeCut', 'e1071', - 'Ecdat', 'fastcluster', 'fastglm', 'ggplot2', 'glmnet', 'gtable', - 'harmonicmeanp', 'isotree', 'knitr', 'labeling', 'laGP', 'MASS', - 'maxstat', 'mboost', 'microbenchmark', 'nnet', 'partykit', - 'power.transform', 'praznik', 'proxy', 'qvalue', 'randomForestSRC', - 'ranger', 'rmarkdown', 'scales', 'xml2', 'VGAM', 'xgboost' - VignetteBuilder package required for checking but not installed: 'knitr' - -* checking Rd cross-references ... NOTE - Package unavailable to check Rd xrefs: 'ggplot2' - -* checking files in 'vignettes' ... WARNING - Warning: Files in the 'vignettes' directory but no files in 'inst/doc': - 'CC4_0_BY_88x31.png' 'familiar.svg' 'familiar_logo.html' - 'license.html' 'refs.bib' - -* checking package vignettes ... NOTE - Package has 'vignettes' subdirectory but apparently no vignettes. - Perhaps the 'VignetteBuilder' information is missing from the - DESCRIPTION file? - - -AZ: Warnings and notes are directly due to missing packages (noSuggests). - # Downstream dependencies diff --git a/familiar.Rproj b/familiar.Rproj index c879e035..5777812d 100644 --- a/familiar.Rproj +++ b/familiar.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: 456a2037-d8a1-45fc-8a2d-f92b47951f76 RestoreWorkspace: No SaveWorkspace: No diff --git a/inst/CITATION b/inst/CITATION index 3ec94c5d..3aa67b90 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -5,15 +5,7 @@ bibentry( person("Alex", "Zwanenburg"), person("Steffen", "Löck") ), - year = 2021, - url = "https://github.com/alexzwanenburg/familiar" -) - -bibentry( - bibtype = "Manual", - header = "If you cite the manual, vignettes or other part of the documentation, please use:", - title = "familiar: Vignettes and Documentation", - author = c(person("Alex", "Zwanenburg")), - year = 2021, - url = "https://github.com/alexzwanenburg/familiar", + year = 2025, + url = "https://github.com/oncoray/familiar", + doi = "10.32614/CRAN.package.familiar" ) diff --git a/inst/config.xml b/inst/config.xml index 3d6e92fd..7837c387 100644 --- a/inst/config.xml +++ b/inst/config.xml @@ -10,13 +10,15 @@ required + + @@ -76,7 +78,7 @@ - + @@ -114,21 +116,21 @@ - + - - - required - - + + + required + + - - - + + + required @@ -154,7 +156,7 @@ - + @@ -182,8 +184,16 @@ + + + + + + + + @@ -206,6 +216,8 @@ + + diff --git a/man/as_data_object-methods.Rd b/man/as_data_object-methods.Rd index 984cd977..4b421672 100644 --- a/man/as_data_object-methods.Rd +++ b/man/as_data_object-methods.Rd @@ -14,8 +14,8 @@ as_data_object(data, ...) \S4method{as_data_object}{data.table}( data, object = NULL, - sample_id_column = waiver(), batch_id_column = waiver(), + sample_id_column = waiver(), series_id_column = waiver(), development_batch_id = waiver(), validation_batch_id = waiver(), @@ -30,6 +30,7 @@ as_data_object(data, ...) include_features = waiver(), reference_method = waiver(), check_stringency = "strict", + .no_features_required = FALSE, ... ) @@ -52,12 +53,6 @@ formats.} \item{object}{A \code{familiarEnsemble} or \code{familiarModel} object that is used to check consistency of these objects.} -\item{sample_id_column}{(\strong{recommended}) Name of the column containing -sample or subject identifiers. See \code{batch_id_column} above for more -details. - -If unset, every row will be identified as a single sample.} - \item{batch_id_column}{(\strong{recommended}) Name of the column containing batch or cohort identifiers. This parameter is required if more than one dataset is provided, or if external validation is performed. @@ -81,7 +76,13 @@ the same series of the same sample in the same batch that share the same outcome are encountered. }} -\item{series_id_column}{(\strong{optional}) Name of the column containing series +\item{sample_id_column}{(\strong{recommended}) Name of the column containing +sample or subject identifiers. See \code{batch_id_column} above for more +details. + +If unset, every row will be identified as a single sample.} + +\item{series_id_column}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -104,8 +105,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{outcome_column}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is @@ -116,13 +117,12 @@ status.} \item{outcome_type}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -132,7 +132,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{event_indicator}{(\strong{recommended}) Indicator for events in \code{survival} and \code{competing_risk} analyses. \code{familiar} will automatically recognise \code{1}, @@ -194,12 +195,15 @@ checking data for evaluation and explanation. stringent checks, particularly for identifier and outcome columns, which may be completely absent. Used internally for \code{predict}. }} + +\item{.no_features_required}{Internal flag to signify that data without +features is allowed. Default: FALSE (most processing steps require features).} } \value{ A \code{dataObject} object. } \description{ -Creates \code{dataObject} a object from input data. Input data can be +Creates a \code{dataObject} object from input data. Input data can be a \code{data.frame} or \code{data.table}, a path to such tables on a local or network drive, or a path to tabular data that may be converted to these formats. diff --git a/man/as_familiar_collection-methods.Rd b/man/as_familiar_collection-methods.Rd index 80ee4e65..c891ec29 100644 --- a/man/as_familiar_collection-methods.Rd +++ b/man/as_familiar_collection-methods.Rd @@ -6,6 +6,9 @@ \alias{as_familiar_collection,familiarData-method} \alias{as_familiar_collection,familiarEnsemble-method} \alias{as_familiar_collection,familiarModel-method} +\alias{as_familiar_collection,familiarDataElementPredictionTable-method} +\alias{as_familiar_collection,dataObject-method} +\alias{as_familiar_collection,data.table-method} \alias{as_familiar_collection,list-method} \alias{as_familiar_collection,character-method} \alias{as_familiar_collection,ANY-method} @@ -46,6 +49,27 @@ as_familiar_collection( ... ) +\S4method{as_familiar_collection}{familiarDataElementPredictionTable}( + object, + familiar_data_names = NULL, + collection_name = NULL, + ... +) + +\S4method{as_familiar_collection}{dataObject}( + object, + familiar_data_names = NULL, + collection_name = NULL, + ... +) + +\S4method{as_familiar_collection}{data.table}( + object, + familiar_data_names = NULL, + collection_name = NULL, + ... +) + \S4method{as_familiar_collection}{list}( object, familiar_data_names = NULL, @@ -72,7 +96,12 @@ as_familiar_collection( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{familiar_data_names}{Names of the dataset(s). Only used if the \code{object} parameter is one or more \code{familiarData} objects.} @@ -80,7 +109,7 @@ parameter is one or more \code{familiarData} objects.} \item{collection_name}{Name of the collection.} \item{...}{ - Arguments passed on to \code{\link[=extract_data]{extract_data}} + Arguments passed on to \code{\link[=.extract_data]{.extract_data}} \describe{ \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -94,8 +123,8 @@ risks generated by random forest, or the cut-off value for Uno's concordance index. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -218,14 +247,23 @@ Default is \code{all}, but specific elements can be specified to speed up computations if not all elements are to be computed. This is an internal parameter that is set by, e.g. the \code{export_model_vimp} method.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -269,7 +307,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -353,13 +395,6 @@ stratify samples into two optimally separated risk groups. One or more stratification methods can be selected simultaneously. This parameter is only relevant for \code{survival} outcomes.} - \item{\code{dynamic_model_loading}}{(\emph{optional}) Enables dynamic loading of models -during the evaluation process, if \code{TRUE}. Defaults to \code{FALSE}. Dynamic -loading of models may reduce the overall memory footprint, at the cost of -increased disk or network IO. Models can only be dynamically loaded if they -are found at an accessible disk or network location. Setting this parameter -to \code{TRUE} may help if parallel processing causes out-of-memory issues during -evaluation.} }} } \value{ diff --git a/man/as_familiar_data-methods.Rd b/man/as_familiar_data-methods.Rd index 38cb2281..7a743d23 100644 --- a/man/as_familiar_data-methods.Rd +++ b/man/as_familiar_data-methods.Rd @@ -4,6 +4,8 @@ \alias{as_familiar_data} \alias{as_familiar_data,familiarData-method} \alias{as_familiar_data,familiarEnsemble-method} +\alias{as_familiar_data,familiarDataElementPredictionTable-method} +\alias{as_familiar_data,dataObject-method} \alias{as_familiar_data,familiarModel-method} \alias{as_familiar_data,list-method} \alias{as_familiar_data,character-method} @@ -16,6 +18,10 @@ as_familiar_data(object, ...) \S4method{as_familiar_data}{familiarEnsemble}(object, name = NULL, ...) +\S4method{as_familiar_data}{familiarDataElementPredictionTable}(object, name = NULL, ...) + +\S4method{as_familiar_data}{dataObject}(object, name = NULL, ...) + \S4method{as_familiar_data}{familiarModel}(object, ...) \S4method{as_familiar_data}{list}(object, ...) @@ -30,7 +36,7 @@ as_familiar_data(object, ...) \code{familiarData} object. Paths to such objects can also be provided.} \item{...}{ - Arguments passed on to \code{\link[=extract_data]{extract_data}} + Arguments passed on to \code{\link[=.extract_data]{.extract_data}} \describe{ \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -44,8 +50,8 @@ risks generated by random forest, or the cut-off value for Uno's concordance index. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -168,14 +174,23 @@ Default is \code{all}, but specific elements can be specified to speed up computations if not all elements are to be computed. This is an internal parameter that is set by, e.g. the \code{export_model_vimp} method.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -219,7 +234,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -303,13 +322,6 @@ stratify samples into two optimally separated risk groups. One or more stratification methods can be selected simultaneously. This parameter is only relevant for \code{survival} outcomes.} - \item{\code{dynamic_model_loading}}{(\emph{optional}) Enables dynamic loading of models -during the evaluation process, if \code{TRUE}. Defaults to \code{FALSE}. Dynamic -loading of models may reduce the overall memory footprint, at the cost of -increased disk or network IO. Models can only be dynamically loaded if they -are found at an accessible disk or network location. Setting this parameter -to \code{TRUE} may help if parallel processing causes out-of-memory issues during -evaluation.} }} \item{name}{Name of the \code{familiarData} object. If not set, a name is diff --git a/man/as_familiar_ensemble-methods.Rd b/man/as_familiar_ensemble-methods.Rd index ce1fb7b3..57808abe 100644 --- a/man/as_familiar_ensemble-methods.Rd +++ b/man/as_familiar_ensemble-methods.Rd @@ -4,6 +4,7 @@ \alias{as_familiar_ensemble} \alias{as_familiar_ensemble,familiarEnsemble-method} \alias{as_familiar_ensemble,familiarModel-method} +\alias{as_familiar_ensemble,familiarNoveltyDetector-method} \alias{as_familiar_ensemble,list-method} \alias{as_familiar_ensemble,character-method} \alias{as_familiar_ensemble,ANY-method} @@ -15,6 +16,8 @@ as_familiar_ensemble(object, ...) \S4method{as_familiar_ensemble}{familiarModel}(object, ...) +\S4method{as_familiar_ensemble}{familiarNoveltyDetector}(object, ...) + \S4method{as_familiar_ensemble}{list}(object, ...) \S4method{as_familiar_ensemble}{character}(object, ...) diff --git a/man/as_prediction_table.Rd b/man/as_prediction_table.Rd new file mode 100644 index 00000000..f3e4aa82 --- /dev/null +++ b/man/as_prediction_table.Rd @@ -0,0 +1,130 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PredictionTable.R +\name{as_prediction_table} +\alias{as_prediction_table} +\title{Convert to prediction table object} +\usage{ +as_prediction_table( + x, + type, + y = waiver(), + batch_id = waiver(), + sample_id = waiver(), + series_id = waiver(), + repetition_id = waiver(), + time = waiver(), + class_levels = waiver(), + value_range = waiver(), + event_indicator = waiver(), + censoring_indicator = waiver(), + learner = waiver(), + vimp_method = waiver(), + model_object = NULL, + data = NULL +) +} +\arguments{ +\item{x}{Values predicted using a learner. For all but \code{classification} +problems, predicted values should be a single vector of values in any +format that results in a single-column \code{data.table} using +\code{data.table::as.data.table}. For \code{classification} problems, predicted +values are probabilities for each class. Here, it is recommended to ensure +probabilities can be mapped to their respective class, e.g. using a named +list.} + +\item{type}{The type of prediction table that should be created. The +following types are available: +\itemize{ +\item \code{regression}: The predicted values are values for a regression. +\item \code{classification}: The predicted values are probabilities for specific +classes. +\item \code{hazard_ratio}: The predicted values are hazard ratios. +\item \code{cumulative_hazard}: The predicted values are cumulative hazards at +time \code{time}. +\item \code{expected_survival_time}: The predicted values are expected survival times. +\item \code{survival_probability}: The predicted values are survival probabilities +at time \code{time}. +}} + +\item{y}{Known outcome value corresponding to each entry in \code{x}. For +survival-related outcomes, two sets of values are expected, corresponding +to the observed time and event status, respectively. Alternatively, a +\code{survival::Surv} object can be provided.} + +\item{batch_id}{(\emph{optional}) Array of batch or cohort identifiers. + +In familiar any row of data is organised by four identifiers: +\itemize{ +\item The batch identifier \code{batch_id}: This denotes the group to which a +set of samples belongs, e.g. patients from a single study, samples measured +in a batch, etc. The batch identifier is used for batch normalisation, as +well as selection of development and validation datasets. +\item The sample identifier \code{sample_id}: This denotes the sample level, +e.g. data from a single individual. Subsets of data, e.g. bootstraps or +cross-validation folds, are created at this level. +\item The series identifier \code{series_id}: Indicates measurements on a +single sample that may not share the same outcome value, e.g. a time +series, or the number of cells in a view. +\item The repetition identifier \code{repetition_id}: Indicates repeated measurements +in a single series where any feature values may differ, but the outcome +does not. Repetition identifiers are always implicitly set when multiple +entries for the same series of the same sample in the same batch that share +the same outcome are encountered. +}} + +\item{sample_id}{(\emph{optional}) Array of sample or subject identifiers. See +\code{batch_id} above for more details. + +If unset, every row will be identified as a single sample.} + +\item{series_id}{(\emph{optional}) Array of series identifiers, which distinguish +between measurements that are part of a series for a single sample. See +\code{batch_id} above for more details.} + +\item{repetition_id}{(\emph{optional}) Array of repetition identifiers, which +distinguishes between repeated measurements within a single series. See +\code{batch_id} above for more details.} + +\item{time}{Time point at which the predicted values are generated e.g. the +cumulative risks generated by random forest. + +This parameter is only relevant for \code{survival} outcomes.} + +\item{class_levels}{(\emph{optional}) Class levels for \code{binomial} or \code{multinomial} +outcomes. This argument can be used to specify the ordering of levels for +categorical outcomes. These class levels must exactly match the levels +present in the outcome column.} + +\item{value_range}{Range of observed, \strong{not predicted}, values. + +This parameter is only relevant for \code{continuous} outcomes.} + +\item{event_indicator}{(\strong{recommended}) Indicator for events in \code{survival} +and \code{competing_risk} analyses. \code{familiar} will automatically recognise \code{1}, +\code{true}, \code{t}, \code{y} and \code{yes} as event indicators, including different +capitalisations. If this parameter is set, it replaces the default values.} + +\item{censoring_indicator}{(\strong{recommended}) Indicator for right-censoring in +\code{survival} and \code{competing_risk} analyses. \code{familiar} will automatically +recognise \code{0}, \code{false}, \code{f}, \code{n}, \code{no} as censoring indicators, including +different capitalisations. If this parameter is set, it replaces the +default values.} + +\item{learner}{The type of learner that generated the predictions.} + +\item{vimp_method}{The type of variable importance method for identifying the +features included by the learner that generated the predictions.} + +\item{model_object}{A familiarModel or familiarEnsemble that can be used (and +is used internally) for setting several of the other arguments of this +function.} + +\item{data}{A familiar dataObject object that can be used (and is used +internally) for setting many of the other arguments of this function.} +} +\value{ +A prediction table object. +} +\description{ +Creates a prediction table object from input data. +} diff --git a/man/create_randomised_groups.Rd b/man/create_randomised_groups.Rd deleted file mode 100644 index 5a1f4428..00000000 --- a/man/create_randomised_groups.Rd +++ /dev/null @@ -1,83 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/RandomGrouping.R -\name{create_randomised_groups} -\alias{create_randomised_groups} -\title{Create randomised groups Creates randomised groups, e.g. for tests that -depend on splitting (continuous) data into groups, such as the -Hosmer-Lemeshow test} -\usage{ -create_randomised_groups( - x, - y = NULL, - sample_identifiers, - n_max_groups = NULL, - n_min_groups = NULL, - n_min_y_in_group = NULL, - n_groups_init = 30, - fast_mode = TRUE -) -} -\arguments{ -\item{x}{Vector with data used for sorting. Groups are formed based on -adjacent values.} - -\item{y}{Vector with markers, e.g. the events. Should be 0 or 1 (for an -event).} - -\item{sample_identifiers}{data.table with sample_identifiers. If provide, a -list of grouped sample_identifiers will be returned, and integers -otherwise.} - -\item{n_max_groups}{Maximum number of groups that need to be formed.} - -\item{n_min_groups}{Minimum number of groups that need to be formed.} - -\item{n_min_y_in_group}{Minimum number of y=1 in each group for a valid -group.} - -\item{n_groups_init}{Number of initial groups (default: 30)} - -\item{fast_mode}{Enables fast randomised grouping mode (default: TRUE)} -} -\value{ -List of group sample ids or indices. -} -\description{ -The default fast mode is based on random sampling, whereas the slow mode is -based on probabilistic joining of adjacent groups. As the name suggests, fast -mode operates considerably more efficient. -} -\details{ -Creates randomised groups, e.g. for tests that depend on splitting -(continuous) data into groups, such as the Hosmer-Lemeshow test -\itemize{ -\item Determine maximum number of groups: either 10 or number so that each group -has 5 events (if smaller). -\item Determine minimum number of groups (half the maximum, or 2). Groups cannot -the exceed corresponding group size. -\item Start with 50 very small groups. -\item Iterate while the maximum number of groups has not been reached. -\itemize{ -\item Selection probability is 1/n_j -\item If a group exceeds the maximum group size, selection probability is 0. -\itemize{ -\item Break if all groups have exceeded the maximum size. -} -\item Get cumulative probability and normalise by total. -\item Draw random number between 0 and 1. -\item Select the group which has a cumulative probability range that contains -the random number. -\item Draw a random number to decide whether to join the group with right or -left adjacent group, and assign the group number to the adjacent group. -Probability depends on the size of adjacent groups. Smaller sizes have -greater probability of being joined. No joining with groups already -exceeding the maximum group size. If surrounded on both sides, force -selection probability for current group to 0. If joining is possible, -update group size, and selection probability for the new group. -} -\item Check that 5 events are present in each group. For each group with < 5 -events, try to join with neighbours. -\item Start over if the number of groups is smaller than the minimum number. -} -} -\keyword{internal} diff --git a/man/dataObject-class.Rd b/man/dataObject-class.Rd index fd5c715c..0b4903f3 100644 --- a/man/dataObject-class.Rd +++ b/man/dataObject-class.Rd @@ -20,23 +20,25 @@ already conducted.} \item{\code{outcome_type}}{character, determines the outcome type.} -\item{\code{data_column_info}}{Object containing column information.} +\item{\code{outcome_info}}{Outcome information object, which contains additional +information concerning the outcome, such as class levels.} + +\item{\code{feature_info}}{List of objects containing feature information, e.g., +name, class levels, transformation, normalisation and clustering +parameters. Optional.} -\item{\code{delay_loading}}{logical. Allows delayed loading data, which enables data -parsing downstream without additional workflow complexity or memory -utilisation.} +\item{\code{data_column_info}}{Object containing column information.} -\item{\code{perturb_level}}{numeric. This is the perturbation level for data which -has not been loaded. Used for data retrieval by interacting with the run -table of the accompanying model.} +\item{\code{data_id}}{Data identifier for dataset. Set using internal routines if the +\code{dataObject} was created from a \code{delayedDataObject}} -\item{\code{load_validation}}{logical. This determines which internal data set will -be loaded. If TRUE, the validation data will be loaded, whereas FALSE loads -the development data.} +\item{\code{run_id}}{Run identifier for dataset. Set using internal routines if the +\code{dataObject} was created from a \code{delayedDataObject}} -\item{\code{aggregate_on_load}}{logical. Determines whether data is aggregated after -loading.} +\item{\code{validation}}{Identifies if validation or development samples were loaded. +Set using internal routines if the \code{dataObject} was created from a +\code{delayedDataObject}.} -\item{\code{sample_set_on_load}}{NULL or vector of sample identifiers to be loaded.} +\item{\code{sample_seed}}{Seed used for creating a bootstrap of the data.} }} diff --git a/man/delayedDataObject-class.Rd b/man/delayedDataObject-class.Rd new file mode 100644 index 00000000..840363e5 --- /dev/null +++ b/man/delayedDataObject-class.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FamiliarS4Classes.R +\docType{class} +\name{delayedDataObject-class} +\alias{delayedDataObject-class} +\title{Data object with delayed loading} +\description{ +The delayed loading object provides an interface to the backend data. This +data object is typically used within the evaluation pipeline to load data +when needed. +} +\section{Slots}{ + +\describe{ +\item{\code{data}}{NULL or data table containing the data. If present (not \code{NULL}), +data is considered loaded. This should not happen -- load_data_object auto- +matically creates a dataObject from the delayedDataObject.} + +\item{\code{preprocessing_level}}{character indicating the level of pre-processing +already conducted. \code{"none"} by default.} + +\item{\code{outcome_type}}{character, determines the outcome type.} + +\item{\code{outcome_info}}{Outcome information object, which contains additional +information concerning the outcome, such as class levels.} + +\item{\code{feature_info}}{List of objects containing feature information, e.g., +name, class levels, transformation, normalisation and clustering +parameters. Optional.} + +\item{\code{data_column_info}}{Object containing column information.} + +\item{\code{data_id}}{integer. Defines the data_id of the dataset that should be +loaded.} + +\item{\code{run_id}}{integer. Defines the run_id of the dataset that should be load. +Together with data_id, run_id and validation allows for looking up the +sample set. If run_id is left unset (NA_integer_), this will force the +run_id to be set using the model, vimp_method or ensemble object. This is +used during the evaluation process to load data specifically related to +training, internal validation and external validation. The run-tables +(which contain information about data partitioning) associated with these +objects are used to look-up the run_id based on the data_id (that is always +explicitly set). The perform_task method for familiarTaskEvaluate uses this +aspect explicitly.} + +\item{\code{validation}}{logical. This determines which internal data set will be +loaded. If TRUE, the validation data will be loaded, whereas FALSE loads +the development data.} + +\item{\code{aggregate_on_load}}{logical. Determines whether data is aggregated after +loading.} + +\item{\code{sample_set_on_load}}{NULL or vector of sample identifiers to be loaded. +Overrides any \code{sample_seed} that may have been provided.} +}} + diff --git a/man/dot-calibration_create_randomised_groups.Rd b/man/dot-calibration_create_randomised_groups.Rd new file mode 100644 index 00000000..f37de532 --- /dev/null +++ b/man/dot-calibration_create_randomised_groups.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FamiliarDataComputationCalibrationData.R +\name{.calibration_create_randomised_groups} +\alias{.calibration_create_randomised_groups} +\title{Create randomised groups Creates randomised groups, e.g. for tests that +depend on splitting (continuous) data into groups, such as the +Hosmer-Lemeshow test} +\usage{ +.calibration_create_randomised_groups( + x, + y = NULL, + sample_identifiers, + n_max_groups = NULL, + n_min_groups = NULL, + n_min_y_in_group = NULL, + unique_samples_only = TRUE, + rstream_object = NULL +) +} +\arguments{ +\item{x}{Vector with data used for sorting. Groups are formed based on +adjacent values.} + +\item{y}{Vector with markers, e.g. the events. Should be 0 or 1 (for an +event).} + +\item{sample_identifiers}{data.table with sample_identifiers. If provide, a +list of grouped sample_identifiers will be returned, and integers +otherwise.} + +\item{n_max_groups}{Maximum number of groups that need to be formed.} + +\item{n_min_groups}{Minimum number of groups that need to be formed.} + +\item{n_min_y_in_group}{Minimum number of y=1 in each group for a valid +group.} +} +\value{ +data.table with sample identifiers and random group ids. +} +\description{ +The default fast mode is based on random sampling, whereas the slow mode is +based on probabilistic joining of adjacent groups. As the name suggests, fast +mode operates considerably more efficient. +} +\details{ +Creates randomised groups, e.g. for tests that depend on splitting +(continuous) data into groups, such as the Hosmer-Lemeshow test +} +\keyword{internal} diff --git a/man/dot-check_class_level_plausibility.Rd b/man/dot-check_class_level_plausibility.Rd index 51ac1d40..364389db 100644 --- a/man/dot-check_class_level_plausibility.Rd +++ b/man/dot-check_class_level_plausibility.Rd @@ -17,13 +17,12 @@ \item{outcome_type}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -33,7 +32,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{outcome_column}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is diff --git a/man/dot-check_input_identifier_column.Rd b/man/dot-check_input_identifier_column.Rd index 8a5c685d..444e499f 100644 --- a/man/dot-check_input_identifier_column.Rd +++ b/man/dot-check_input_identifier_column.Rd @@ -24,7 +24,7 @@ identifier column.} \item{signature}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{exclude_features}{(\emph{optional}) Feature columns that will be removed diff --git a/man/dot-check_input_plot_args.Rd b/man/dot-check_input_plot_args.Rd index 5e338f4b..e6c94fba 100644 --- a/man/dot-check_input_plot_args.Rd +++ b/man/dot-check_input_plot_args.Rd @@ -15,6 +15,7 @@ conf_int_alpha = waiver(), conf_int_style = waiver(), conf_int_default = c("step", "ribbon", "none"), + limit_n_features = waiver(), facet_wrap_cols = waiver(), x_label = waiver(), y_label = waiver(), @@ -58,6 +59,10 @@ allowed styles.} \item{conf_int_default}{Sets the default options for the confidence interval.} +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + \item{facet_wrap_cols}{(\emph{optional}) Number of columns to generate when facet wrapping. If NULL, a facet grid is produced instead.} diff --git a/man/dot-check_survival_time_plausibility.Rd b/man/dot-check_survival_time_plausibility.Rd index 7127f058..ff2c0b7a 100644 --- a/man/dot-check_survival_time_plausibility.Rd +++ b/man/dot-check_survival_time_plausibility.Rd @@ -16,13 +16,12 @@ \item{outcome_type}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -32,7 +31,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{outcome_column}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is diff --git a/man/extract_data.Rd b/man/dot-extract_data.Rd similarity index 93% rename from man/extract_data.Rd rename to man/dot-extract_data.Rd index f6638fba..35f8cee7 100644 --- a/man/extract_data.Rd +++ b/man/dot-extract_data.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/FamiliarDataComputation.R -\name{extract_data} -\alias{extract_data} +\name{.extract_data} +\alias{.extract_data} \title{Internal function to create a familiarData object.} \usage{ -extract_data( +.extract_data( object, - data, - data_element = waiver(), + data = NULL, + data_element, is_pre_processed = FALSE, cl = NULL, time_max = waiver(), @@ -26,21 +26,22 @@ extract_data( sample_linkage_method = waiver(), sample_similarity_metric = waiver(), sample_limit = waiver(), + n_important_features = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), confidence_level = waiver(), bootstrap_ci_method = waiver(), icc_type = waiver(), - dynamic_model_loading = FALSE, message_indent = 0L, verbose = FALSE, ... ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -124,8 +125,8 @@ One or more stratification methods can be selected simultaneously. This parameter is only relevant for \code{survival} outcomes.} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -217,14 +218,24 @@ If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects.} \item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + +\item{n_important_features}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{detail_level}{(\emph{optional}) Sets the level at which results are computed and aggregated. @@ -269,7 +280,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: @@ -335,14 +350,6 @@ importance. These types correspond to the types in Shrout and Fleiss (1979). If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects.} -\item{dynamic_model_loading}{(\emph{optional}) Enables dynamic loading of models -during the evaluation process, if \code{TRUE}. Defaults to \code{FALSE}. Dynamic -loading of models may reduce the overall memory footprint, at the cost of -increased disk or network IO. Models can only be dynamically loaded if they -are found at an accessible disk or network location. Setting this parameter -to \code{TRUE} may help if parallel processing causes out-of-memory issues during -evaluation.} - \item{message_indent}{Number of indentation steps for messages shown during computation and extraction of various data elements.} diff --git a/man/dot-finish_data_preparation.Rd b/man/dot-finish_data_preparation.Rd index 8b44a538..772b9f4c 100644 --- a/man/dot-finish_data_preparation.Rd +++ b/man/dot-finish_data_preparation.Rd @@ -17,7 +17,8 @@ event_indicator, competing_risk_indicator, check_stringency = "strict", - reference_method = "auto" + reference_method = "auto", + .no_features_required = FALSE ) } \arguments{ @@ -52,7 +53,7 @@ the same series of the same sample in the same batch that share the same outcome are encountered. }} -\item{series_id_column}{(\strong{optional}) Name of the column containing series +\item{series_id_column}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -68,13 +69,12 @@ status.} \item{outcome_type}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -84,7 +84,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{include_features}{(\emph{optional}) Feature columns that are specifically included in the data set. By default all features are included. Cannot @@ -142,6 +143,9 @@ Automatically detected categorical features are simply sorted, and the first level is then used as the reference level. This was the behaviour prior to familiar version 1.3.0. }} + +\item{.no_features_required}{Internal flag to signify that data without +features is allowed. Default: FALSE (most processing steps require features).} } \value{ data.table with expected column names. diff --git a/man/dot-get_iteration_data.Rd b/man/dot-get_iteration_data.Rd index 5fd03f50..70b40f48 100644 --- a/man/dot-get_iteration_data.Rd +++ b/man/dot-get_iteration_data.Rd @@ -14,7 +14,7 @@ ) } \arguments{ -\item{file_paths}{Set of paths to relevant files and directories.} +\item{file_paths}{Path to directory where iteration files are stored.} \item{data}{Data set as loaded using the \code{.load_data} function.} diff --git a/man/dot-impute_outcome_type.Rd b/man/dot-impute_outcome_type.Rd index ea7d3948..924355af 100644 --- a/man/dot-impute_outcome_type.Rd +++ b/man/dot-impute_outcome_type.Rd @@ -32,7 +32,7 @@ The imputed outcome type. \description{ This function allows for imputation of the most plausible outcome type. This imputation is only done for trivial cases, where there is little doubt. -As a consequence \code{count} and \code{continuous} outcome types are never imputed. +As a consequence \code{continuous} outcome type is never imputed. } \note{ It is highly recommended that the user provides the outcome type. diff --git a/man/dot-parse_evaluation_settings.Rd b/man/dot-parse_evaluation_settings.Rd index 728a0f6f..425afdbb 100644 --- a/man/dot-parse_evaluation_settings.Rd +++ b/man/dot-parse_evaluation_settings.Rd @@ -19,15 +19,20 @@ prep_cluster_similarity_threshold, prep_cluster_similarity_metric, evaluate_top_level_only = waiver(), + evaluation_elements = waiver(), skip_evaluation_elements = waiver(), ensemble_method = waiver(), evaluation_metric = waiver(), sample_limit = waiver(), + n_important_features = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), confidence_level = waiver(), bootstrap_ci_method = waiver(), + shap_tolerance = waiver(), + shap_max_iterations = waiver(), + shap_phi_0 = waiver(), feature_cluster_method = waiver(), feature_cluster_cut_method = waiver(), feature_linkage_method = waiver(), @@ -65,11 +70,10 @@ These identifiers are used to determine the cohorts used to determine a setting for \code{time_max}, if the \code{outcome_type} is \code{survival}, and both \code{time_max} and \code{evaluation_times} are not provided.} -\item{vimp_aggregation_method}{Method for variable importance aggregation that -was used for feature selection.} +\item{vimp_aggregation_method}{Variable importance aggregation method.} -\item{vimp_aggregation_rank_threshold}{Rank threshold for variable importance -aggregation used during feature selection.} +\item{vimp_aggregation_rank_threshold}{Rank threshold used for variable +importance aggregation.} \item{prep_cluster_method}{Cluster method used during pre-processing.} @@ -99,48 +103,64 @@ from both the global layer and the next lower level. Setting the flag to \code{true} saves computation time.} -\item{skip_evaluation_elements}{(\emph{optional}) Specifies which evaluation steps, -if any, should be skipped as part of the evaluation process. Defaults to -\code{none}, which means that all relevant evaluation steps are performed. It can -have one or more of the following values: +\item{evaluation_elements}{(\emph{optional}) Specifies which evaluation steps +should be performed during the evaluation process. Defaults to \code{all}, +indicating that all evaluation steps should be performed. It can have one or +more of the following values: \itemize{ -\item \code{none}, \code{false}: no steps are skipped. -\item \code{all}, \code{true}: all steps are skipped. +\item \code{all}, \code{true}: all evaluation steps are performed. +\item \code{none}, \code{false}: no evaluation is performed. \item \code{auc_data}: data for assessing and plotting the area under the receiver -operating characteristic curve are not computed. +operating characteristic curve are computed. \item \code{calibration_data}: data for assessing and plotting model calibration are -not computed. +computed. \item \code{calibration_info}: data required to assess calibration, such as baseline -survival curves, are not collected. These data will still be present in the +survival curves, are collected. These data will still be present in the models. \item \code{confusion_matrix}: data for assessing and plotting a confusion matrix are -not collected. +collected. \item \code{decision_curve_analyis}: data for performing a decision curve analysis -are not computed. +are computed. \item \code{feature_expressions}: data for assessing and plotting sample clustering -are not computed. -\item \code{feature_similarity}: data for assessing and plotting feature clusters are +are computed. +\item \code{feature_similarity}: data for assessing and plotting feature clusters not computed. \item \code{fs_vimp}: data for assessing and plotting feature selection-based -variable importance are not collected. -\item \code{hyperparameters}: data for assessing model hyperparameters are not +variable importance are collected. +\item \code{hyperparameters}: data for assessing model hyperparameters are collected. These data will still be present in the models. \item \code{ice_data}: data for individual conditional expectation and partial -dependence plots are not created. +dependence plots are created. \item \code{model_performance}: data for assessing and visualising model performance -are not created. +are created. \item \code{model_vimp}: data for assessing and plotting model-based variable -importance are not collected. +importance are collected. \item \code{permutation_vimp}: data for assessing and plotting model-agnostic -permutation variable importance are not computed. -\item \code{prediction_data}: predictions for each sample are not made and exported. +permutation variable importance are computed. +\item \code{prediction_data}: predictions for each sample are made and exported. \item \code{risk_stratification_data}: data for assessing and plotting Kaplan-Meier -survival curves are not collected. +survival curves are collected. \item \code{risk_stratification_info}: data for assessing stratification into risk -groups are not computed. +groups are computed. +\item \code{sample_similarity}: data for assessing sample similarity are computed. +\item \code{shap}: data for assessing marginal contributions of feature values in +a SHAP analysis. \item \code{univariate_analysis}: data for assessing and plotting univariate feature -importance are not computed. -}} +importance are computed. +} + +The logical intersect of the evaluation elements specified by +\code{evaluation_elements} and \code{skip_evaluation_elements} is used to define which +evaluation steps are performed.} + +\item{skip_evaluation_elements}{(\emph{optional}) Specifies which evaluation steps, +if any, should be skipped as part of the evaluation process. Defaults to +\code{none}, which means that all relevant evaluation steps are performed. It can +have one or more of the same values as \code{evaluation_elements}. + +The logical intersect of the evaluation elements specified by +\code{evaluation_elements} and \code{skip_evaluation_elements} is used to define which +evaluation steps are performed.} \item{ensemble_method}{(\emph{optional}) Method for ensembling predictions from models for the same sample. Available methods are: @@ -164,14 +184,24 @@ depends on the value of \code{confidence_level} (Davison and Hinkley, 1997). If unset, the metric in the \code{optimisation_metric} variable is used.} \item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + +\item{n_important_features}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{detail_level}{(\emph{optional}) Sets the level at which results are computed and aggregated. @@ -216,7 +246,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: @@ -275,6 +309,22 @@ Note that the standard method is not implemented because this method is often not suitable due to non-normal distributions. The bias-corrected and accelerated (BCa) method is not implemented yet.} +\item{shap_tolerance}{(\emph{optional}) Relative tolerance for convergence of SHAP +values. The tolerance is scaled with the range in SHAP values. + +The default value is \code{0.05}.} + +\item{shap_max_iterations}{(\emph{optional}) Maximum iterations for convergence of +SHAP values. + +The default value is \code{1000} iterations.} + +\item{shap_phi_0}{(\emph{optional}) Value(s) to use for computing marginal +contributions. By default, the average predicted value in the population is +used. For \code{multinomial} and \code{survival} outcomes, this parameter requires a +value for each class and evaluation time (\code{evaluation_times}), +respectively.} + \item{feature_cluster_method}{(\emph{optional}) Method used to perform clustering of features. The same methods as for the \code{cluster_method} configuration parameter are available: \code{none}, \code{hclust}, \code{agnes}, \code{diana} and \code{pam}. @@ -368,9 +418,9 @@ and 1 if they do not.} \item{eval_aggregation_method}{(\emph{optional}) Method for aggregating variable importances for the purpose of evaluation. Variable importances are -determined during feature selection steps and after training the model. Both -types are evaluated, but feature selection variable importance is only -evaluated at run-time. +determined both during initial variable importance computation steps and +after training the model. Both types are evaluated after training the +model, but only the initial variable importances are evaluated at run-time. See the documentation for the \code{vimp_aggregation_method} argument for information concerning the different methods available.} diff --git a/man/dot-parse_experiment_settings.Rd b/man/dot-parse_experiment_settings.Rd index 01c3af5d..c0ee0ac3 100644 --- a/man/dot-parse_experiment_settings.Rd +++ b/man/dot-parse_experiment_settings.Rd @@ -26,6 +26,7 @@ experimental_design = waiver(), imbalance_correction_method = waiver(), imbalance_n_partitions = waiver(), + iteration_seed = waiver(), ... ) } @@ -61,7 +62,7 @@ details. If unset, every row will be identified as a single sample.} -\item{series_id_column}{(\strong{optional}) Name of the column containing series +\item{series_id_column}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -84,8 +85,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{outcome_column}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is @@ -96,13 +97,12 @@ status.} \item{outcome_type}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -112,7 +112,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{event_indicator}{(\strong{recommended}) Indicator for events in \code{survival} and \code{competing_risk} analyses. \code{familiar} will automatically recognise \code{1}, @@ -138,7 +139,7 @@ present in the outcome column.} \item{signature}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{novelty_features}{(\emph{optional}) One or more names of feature columns @@ -173,10 +174,13 @@ prior to familiar version 1.3.0. \item{experimental_design}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)+ev} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building, and external validation. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building, and external validation. The basic workflow +components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (optional) variable importance computation step. If not explicitly +declared, feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. \item \code{ev}: (optional) external validation. Note that internal validation due to subsampling will always be conducted if the subsampling methods create @@ -242,6 +246,11 @@ that defines the design.} undersampling should be repeated. 10 undersampled subsets with balanced classes are formed by default.} +\item{iteration_seed}{(\emph{optional}) Integer seed used in sampling algorithms +specified by the \code{experimental_design} argument. This allows for creating +the same sample assignments across different experiments -- of course +provided that the same dataset is used. By default a random seed is used.} + \item{...}{Unused arguments.} } \value{ diff --git a/man/dot-parse_general_settings.Rd b/man/dot-parse_general_settings.Rd index 09fd0f43..f242aa70 100644 --- a/man/dot-parse_general_settings.Rd +++ b/man/dot-parse_general_settings.Rd @@ -16,7 +16,7 @@ worklow} \item{data}{Data set as loaded using the \code{.load_data} function.} \item{...}{ - Arguments passed on to \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_feature_selection_settings]{.parse_feature_selection_settings}}, \code{\link[=.parse_model_development_settings]{.parse_model_development_settings}}, \code{\link[=.parse_hyperparameter_optimisation_settings]{.parse_hyperparameter_optimisation_settings}}, \code{\link[=.parse_evaluation_settings]{.parse_evaluation_settings}} + Arguments passed on to \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_variable_importance_settings]{.parse_variable_importance_settings}}, \code{\link[=.parse_model_development_settings]{.parse_model_development_settings}}, \code{\link[=.parse_hyperparameter_optimisation_settings]{.parse_hyperparameter_optimisation_settings}}, \code{\link[=.parse_evaluation_settings]{.parse_evaluation_settings}} \describe{ \item{\code{parallel}}{(\emph{optional}) Enable parallel processing. Defaults to \code{TRUE}. When set to \code{FALSE}, this disables all parallel processing, regardless of @@ -72,7 +72,7 @@ Several method are available: filter, for example, genes that are not differentially expressed. \item \code{univariate_test}: Features undergo a univariate regression using an outcome-appropriate regression model. The p-value of the model coefficient -is collected. Features with coefficient p or q-value above the +is collected. Features with coefficient p-value above the \code{univariate_test_threshold} are subsequently filtered. \item \code{robustness}: Features that are not sufficiently robust according to the intraclass correlation coefficient are filtered. Use of this method @@ -84,18 +84,15 @@ More than one method can be used simultaneously. Features with singular values are always filtered, as these do not contain information.} \item{\code{univariate_test_threshold}}{(\emph{optional}) Numeric value between \code{1.0} and \code{0.0} that determines which features are irrelevant and will be filtered by -the \code{univariate_test}. The p or q-values are compared to this threshold. +the \code{univariate_test}. p-values are compared to this threshold. All features with values above the threshold are filtered. The default value is \code{0.20}.} \item{\code{univariate_test_threshold_metric}}{(\emph{optional}) Metric used with the to -compare the \code{univariate_test_threshold} against. The following metrics can +compare the \code{univariate_test_threshold} against. The following metric can be chosen: \itemize{ \item \code{p_value} (default): The unadjusted p-value of each feature is used for to filter features. -\item \code{q_value}: The q-value (Story, 2002), is used to filter features. Some -data sets may have insufficient samples to compute the q-value. The -\code{qvalue} package must be installed from Bioconductor to use this method. }} \item{\code{univariate_test_max_feature_set_size}}{(\emph{optional}) Maximum size of the feature set after the univariate test. P or q values of features are @@ -146,7 +143,7 @@ methods are available: \item \code{none}: This disables transformation of features. \item \code{yeo_johnson}: Transformation using the location and scale invariant version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -Zwanenburg and Löck, 2023). +Zwanenburg and Löck, 2026). \item \code{yeo_johnson_robust} (default): A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{yeo_johnson_conventional}: As \code{yeo_johnson}, but without optimisation of @@ -154,7 +151,7 @@ location and scale parameters. This method is equivalent to the original transformation proposed by Yeo and Johnson (2001). \item \code{box_cox}: Transformation using the location and scale invariant version of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -2023). +2026). \item \code{box_cox_robust}: A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{box_cox_conventional}: As \code{box_cox}, but without optimisation of @@ -174,12 +171,12 @@ optimisation criteria, of which the following are available: \itemize{ \item \code{mle} (default): Optimisation using maximum likelihood estimation. \item \code{cramer_von_mises}: Optimisation using the Cramér-von Mises -criterion. Zwanenburg and Löck (2023) found that this criterion was +criterion. Zwanenburg and Löck (2026) found that this criterion was relatively robust against outliers. }} \item{\code{transformation_gof_test_p_value}}{(\emph{optional}) Not all transformations will lead to features that are roughly normally distributed. Zwanenburg and -Löck (2023) established a empirical goodness-of-fit test for central +Löck (2026) established a empirical goodness-of-fit test for central normality. This parameter sets the significance for rejecting the null-hypothesis that a feature distribution is centrally normal. When the null-hypothesis is rejected, no transformation is performed. The default @@ -427,18 +424,17 @@ preprocessing workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, this disable the use of parallel processing while preprocessing, regardless of the settings of the \code{parallel} parameter. \code{parallel_preprocessing} is ignored if \code{parallel=FALSE}.} - \item{\code{fs_method}}{(\strong{required}) Feature selection method to be used for -determining variable importance. \code{familiar} implements various feature -selection methods. Please refer to the vignette on feature selection -methods for more details. + \item{\code{vimp_method}}{(\strong{required}) Variable importance method. \code{familiar} +implements various variable importance methods. Please refer to the +vignette on variable importance methods for more details. -More than one feature selection method can be chosen. The experiment will +More than one variable importance method can be chosen. The experiment will then repeated for each feature selection method. -Feature selection methods determines the ranking of features. Actual +Variable importance methods determine the ranking of features. Actual selection of features is done by optimising the signature size model hyperparameter during the hyperparameter optimisation step.} - \item{\code{fs_method_parameter}}{(\emph{optional}) List of lists containing parameters + \item{\code{vimp_method_parameter}}{(\emph{optional}) List of lists containing parameters for feature selection methods. Each sublist should have the name of the feature selection method it corresponds to. @@ -480,17 +476,17 @@ feature rank. The \emph{feature selection methods} vignette provides additional information.} \item{\code{vimp_aggregation_rank_threshold}}{(\emph{optional}) The threshold used to -define the subset of highly important features. If not set, this threshold -is determined by maximising the variance in the occurrence value over all -features over the subset size. +define the subset of highly important features. If set to \code{NULL}, this +threshold is determined by maximising the variance in the occurrence value +over all features over the subset size. The default value is \code{5}. This parameter is only relevant for \code{stability}, \code{exponential}, \code{enhanced_borda}, \code{truncated_borda} and \code{enhanced_truncated_borda} methods.} - \item{\code{parallel_feature_selection}}{(\emph{optional}) Enable parallel processing for -the feature selection workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, + \item{\code{parallel_vimp}}{(\emph{optional}) Enable parallel processing for +variable importance tasks. Defaults to \code{TRUE}. When set to \code{FALSE}, this will disable the use of parallel processing while performing feature selection, regardless of the settings of the \code{parallel} parameter. -\code{parallel_feature_selection} is ignored if \code{parallel=FALSE}.} +\code{parallel_vimp} is ignored if \code{parallel = FALSE}.} \item{\code{learner}}{(\strong{required}) One or more algorithms used for model development. A sizeable number learners is supported in \code{familiar}. Please see the vignette on learners for more information concerning the available @@ -529,16 +525,17 @@ finish before exhausting the set of bootstraps.} \item{\code{optimisation_determine_vimp}}{(\emph{optional}) Logical value that indicates whether variable importance is determined separately for each of the bootstraps created during the optimisation process (\code{TRUE}) or the -applicable results from the feature selection step are used (\code{FALSE}). +applicable results from the variable importance computation step are used +(\code{FALSE}). Determining variable importance increases the initial computational overhead. However, it prevents positive biases for the out-of-bag data due to overlap of these data with the development data set used for the feature selection step. In this case, any hyperparameters of the variable importance method are not determined separately for each bootstrap, but -those obtained during the feature selection step are used instead. In case -multiple of such hyperparameter sets could be applicable, the set that will -be used is randomly selected for each bootstrap. +those obtained during the variable importance computation step are used +instead. In case multiple of such hyperparameter sets could be applicable, +the set that will be used is randomly selected for each bootstrap. This parameter only affects hyperparameter optimisation of learners. The default is \code{TRUE}.} @@ -622,7 +619,6 @@ If unset, the following metrics are used by default: \itemize{ \item \code{auc_roc}: For \code{binomial} and \code{multinomial} models. \item \code{mse}: Mean squared error for \code{continuous} models. -\item \code{msle}: Mean squared logarithmic error for \code{count} models. \item \code{concordance_index}: For \code{survival} models. } @@ -766,48 +762,63 @@ are not computed and shown. When the flag is \code{false}, results are computed from both the global layer and the next lower level. Setting the flag to \code{true} saves computation time.} - \item{\code{skip_evaluation_elements}}{(\emph{optional}) Specifies which evaluation steps, -if any, should be skipped as part of the evaluation process. Defaults to -\code{none}, which means that all relevant evaluation steps are performed. It can -have one or more of the following values: + \item{\code{evaluation_elements}}{(\emph{optional}) Specifies which evaluation steps +should be performed during the evaluation process. Defaults to \code{all}, +indicating that all evaluation steps should be performed. It can have one or +more of the following values: \itemize{ -\item \code{none}, \code{false}: no steps are skipped. -\item \code{all}, \code{true}: all steps are skipped. +\item \code{all}, \code{true}: all evaluation steps are performed. +\item \code{none}, \code{false}: no evaluation is performed. \item \code{auc_data}: data for assessing and plotting the area under the receiver -operating characteristic curve are not computed. +operating characteristic curve are computed. \item \code{calibration_data}: data for assessing and plotting model calibration are -not computed. +computed. \item \code{calibration_info}: data required to assess calibration, such as baseline -survival curves, are not collected. These data will still be present in the +survival curves, are collected. These data will still be present in the models. \item \code{confusion_matrix}: data for assessing and plotting a confusion matrix are -not collected. +collected. \item \code{decision_curve_analyis}: data for performing a decision curve analysis -are not computed. +are computed. \item \code{feature_expressions}: data for assessing and plotting sample clustering -are not computed. -\item \code{feature_similarity}: data for assessing and plotting feature clusters are +are computed. +\item \code{feature_similarity}: data for assessing and plotting feature clusters not computed. \item \code{fs_vimp}: data for assessing and plotting feature selection-based -variable importance are not collected. -\item \code{hyperparameters}: data for assessing model hyperparameters are not +variable importance are collected. +\item \code{hyperparameters}: data for assessing model hyperparameters are collected. These data will still be present in the models. \item \code{ice_data}: data for individual conditional expectation and partial -dependence plots are not created. +dependence plots are created. \item \code{model_performance}: data for assessing and visualising model performance -are not created. +are created. \item \code{model_vimp}: data for assessing and plotting model-based variable -importance are not collected. +importance are collected. \item \code{permutation_vimp}: data for assessing and plotting model-agnostic -permutation variable importance are not computed. -\item \code{prediction_data}: predictions for each sample are not made and exported. +permutation variable importance are computed. +\item \code{prediction_data}: predictions for each sample are made and exported. \item \code{risk_stratification_data}: data for assessing and plotting Kaplan-Meier -survival curves are not collected. +survival curves are collected. \item \code{risk_stratification_info}: data for assessing stratification into risk -groups are not computed. +groups are computed. +\item \code{sample_similarity}: data for assessing sample similarity are computed. +\item \code{shap}: data for assessing marginal contributions of feature values in +a SHAP analysis. \item \code{univariate_analysis}: data for assessing and plotting univariate feature -importance are not computed. -}} +importance are computed. +} + +The logical intersect of the evaluation elements specified by +\code{evaluation_elements} and \code{skip_evaluation_elements} is used to define which +evaluation steps are performed.} + \item{\code{skip_evaluation_elements}}{(\emph{optional}) Specifies which evaluation steps, +if any, should be skipped as part of the evaluation process. Defaults to +\code{none}, which means that all relevant evaluation steps are performed. It can +have one or more of the same values as \code{evaluation_elements}. + +The logical intersect of the evaluation elements specified by +\code{evaluation_elements} and \code{skip_evaluation_elements} is used to define which +evaluation steps are performed.} \item{\code{ensemble_method}}{(\emph{optional}) Method for ensembling predictions from models for the same sample. Available methods are: \itemize{ @@ -828,14 +839,23 @@ depends on the value of \code{confidence_level} (Davison and Hinkley, 1997). If unset, the metric in the \code{optimisation_metric} variable is used.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -879,7 +899,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -933,6 +957,19 @@ method. Note that the standard method is not implemented because this method is often not suitable due to non-normal distributions. The bias-corrected and accelerated (BCa) method is not implemented yet.} + \item{\code{shap_tolerance}}{(\emph{optional}) Relative tolerance for convergence of SHAP +values. The tolerance is scaled with the range in SHAP values. + +The default value is \code{0.05}.} + \item{\code{shap_max_iterations}}{(\emph{optional}) Maximum iterations for convergence of +SHAP values. + +The default value is \code{1000} iterations.} + \item{\code{shap_phi_0}}{(\emph{optional}) Value(s) to use for computing marginal +contributions. By default, the average predicted value in the population is +used. For \code{multinomial} and \code{survival} outcomes, this parameter requires a +value for each class and evaluation time (\code{evaluation_times}), +respectively.} \item{\code{feature_cluster_method}}{(\emph{optional}) Method used to perform clustering of features. The same methods as for the \code{cluster_method} configuration parameter are available: \code{none}, \code{hclust}, \code{agnes}, \code{diana} and \code{pam}. @@ -1018,9 +1055,9 @@ Gower's distance: distance is 0 if the values in a pair of samples match, and 1 if they do not.} \item{\code{eval_aggregation_method}}{(\emph{optional}) Method for aggregating variable importances for the purpose of evaluation. Variable importances are -determined during feature selection steps and after training the model. Both -types are evaluated, but feature selection variable importance is only -evaluated at run-time. +determined both during initial variable importance computation steps and +after training the model. Both types are evaluated after training the +model, but only the initial variable importances are evaluated at run-time. See the documentation for the \code{vimp_aggregation_method} argument for information concerning the different methods available.} @@ -1117,8 +1154,6 @@ worklow } \references{ \enumerate{ -\item Storey, J. D. A direct approach to false discovery rates. J. -R. Stat. Soc. Series B Stat. Methodol. 64, 479–498 (2002). \item Shrout, P. E. & Fleiss, J. L. Intraclass correlations: uses in assessing rater reliability. Psychol. Bull. 86, 420–428 (1979). \item Koo, T. K. & Li, M. Y. A guideline of selecting and reporting intraclass @@ -1130,6 +1165,9 @@ improve normality or symmetry. Biometrika 87, 954–959 (2000). Soc. Series B Stat. Methodol. 26, 211–252 (1964). \item Raymaekers, J., Rousseeuw, P. J. Transforming variables to central normality. Mach Learn. (2021). +\item Zwanenburg, A., & Löck, S. (2026). Location and scale-invariant power +transformations for transforming data to normality. Machine Learning, +115(3), 34. \item Park, M. Y., Hastie, T. & Tibshirani, R. Averaged gene expressions for regression. Biostatistics 8, 212–227 (2007). \item Tolosi, L. & Lengauer, T. Classification with correlated features: diff --git a/man/dot-parse_hyperparameter_optimisation_settings.Rd b/man/dot-parse_hyperparameter_optimisation_settings.Rd index 3a4c825e..e1db4733 100644 --- a/man/dot-parse_hyperparameter_optimisation_settings.Rd +++ b/man/dot-parse_hyperparameter_optimisation_settings.Rd @@ -50,16 +50,17 @@ finish before exhausting the set of bootstraps.} \item{optimisation_determine_vimp}{(\emph{optional}) Logical value that indicates whether variable importance is determined separately for each of the bootstraps created during the optimisation process (\code{TRUE}) or the -applicable results from the feature selection step are used (\code{FALSE}). +applicable results from the variable importance computation step are used +(\code{FALSE}). Determining variable importance increases the initial computational overhead. However, it prevents positive biases for the out-of-bag data due to overlap of these data with the development data set used for the feature selection step. In this case, any hyperparameters of the variable importance method are not determined separately for each bootstrap, but -those obtained during the feature selection step are used instead. In case -multiple of such hyperparameter sets could be applicable, the set that will -be used is randomly selected for each bootstrap. +those obtained during the variable importance computation step are used +instead. In case multiple of such hyperparameter sets could be applicable, +the set that will be used is randomly selected for each bootstrap. This parameter only affects hyperparameter optimisation of learners. The default is \code{TRUE}.} @@ -197,7 +198,6 @@ If unset, the following metrics are used by default: \itemize{ \item \code{auc_roc}: For \code{binomial} and \code{multinomial} models. \item \code{mse}: Mean squared error for \code{continuous} models. -\item \code{msle}: Mean squared logarithmic error for \code{count} models. \item \code{concordance_index}: For \code{survival} models. } diff --git a/man/dot-parse_initial_settings.Rd b/man/dot-parse_initial_settings.Rd index e3f97695..3ad9232d 100644 --- a/man/dot-parse_initial_settings.Rd +++ b/man/dot-parse_initial_settings.Rd @@ -11,7 +11,7 @@ define the experiment} \item{config}{A list of settings, e.g. from an xml file.} \item{...}{ - Arguments passed on to \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}} + Arguments passed on to \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}}, \code{\link[=.parse_setup_settings]{.parse_setup_settings}} \describe{ \item{\code{batch_id_column}}{(\strong{recommended}) Name of the column containing batch or cohort identifiers. This parameter is required if more than one dataset @@ -40,7 +40,7 @@ sample or subject identifiers. See \code{batch_id_column} above for more details. If unset, every row will be identified as a single sample.} - \item{\code{series_id_column}}{(\strong{optional}) Name of the column containing series + \item{\code{series_id_column}}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -60,8 +60,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{\code{outcome_column}}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is provided as an argument. Otherwise an error is raised. Note that \code{survival} @@ -70,13 +70,12 @@ indicate the time-to-event or the time of last follow-up and the event status.} \item{\code{outcome_type}}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -86,7 +85,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{\code{class_levels}}{(\emph{optional}) Class levels for \code{binomial} or \code{multinomial} outcomes. This argument can be used to specify the ordering of levels for categorical outcomes. These class levels must exactly match the levels @@ -107,7 +107,7 @@ unset, all values other than those specified by the \code{event_indicator} and risks.} \item{\code{signature}}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{\code{novelty_features}}{(\emph{optional}) One or more names of feature columns that should be included for the purpose of novelty detection.} @@ -137,10 +137,13 @@ prior to familiar version 1.3.0. }} \item{\code{experimental_design}}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)+ev} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building, and external validation. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building, and external validation. The basic workflow +components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (optional) variable importance computation step. If not explicitly +declared, feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. \item \code{ev}: (optional) external validation. Note that internal validation due to subsampling will always be conducted if the subsampling methods create @@ -203,6 +206,42 @@ that defines the design.} \item{\code{imbalance_n_partitions}}{(\emph{optional}) Number of times random undersampling should be repeated. 10 undersampled subsets with balanced classes are formed by default.} + \item{\code{iteration_seed}}{(\emph{optional}) Integer seed used in sampling algorithms +specified by the \code{experimental_design} argument. This allows for creating +the same sample assignments across different experiments -- of course +provided that the same dataset is used. By default a random seed is used.} + \item{\code{parallel}}{(\emph{optional}) Enable parallel processing. Defaults to \code{TRUE}. +When set to \code{FALSE}, this disables all parallel processing, regardless of +specific parameters such as \code{parallel_preprocessing}. However, when +\code{parallel} is \code{TRUE}, parallel processing of different parts of the +workflow can be disabled by setting respective flags to \code{FALSE}.} + \item{\code{parallel_nr_cores}}{(\emph{optional}) Number of cores available for +parallelisation. Defaults to 2. This setting does nothing if +parallelisation is disabled.} + \item{\code{restart_cluster}}{(\emph{optional}) Restart nodes used for parallel computing +to free up memory prior to starting a parallel process. Note that it does +take time to set up the clusters. Therefore setting this argument to \code{TRUE} +may impact processing speed. This argument is ignored if \code{parallel} is +\code{FALSE} or the cluster was initialised outside of familiar. Default is +\code{FALSE}, which causes the clusters to be initialised only once.} + \item{\code{cluster_type}}{(\emph{optional}) Selection of the cluster type for parallel +processing. Available types are the ones supported by the parallel package +that is part of the base R distribution: \code{psock} (default), \code{fork}, \code{mpi}, +\code{nws}, \code{sock}. In addition, \code{none} is available, which also disables +parallel processing.} + \item{\code{backend_type}}{(\emph{optional}) Selection of the backend for distributing +copies of the data. This backend ensures that only a single master copy is +kept in memory. This limits memory usage during parallel processing. + +Several backend options are available, notably \code{socket_server}, and \code{none} +(default). \code{socket_server} is based on the callr package and R sockets, +comes with \code{familiar} and is available for any OS. \code{none} uses the package +environment of familiar to store data, and is available for any OS. +However, \code{none} requires copying of data to any parallel process, and has a +larger memory footprint.} + \item{\code{server_port}}{(\emph{optional}) Integer indicating the port on which the +socket server or RServe process should communicate. Defaults to port 6311. +Note that ports 0 to 1024 and 49152 to 65535 cannot be used.} }} } \value{ diff --git a/man/dot-parse_preprocessing_settings.Rd b/man/dot-parse_preprocessing_settings.Rd index 33d29fa2..2999eb7e 100644 --- a/man/dot-parse_preprocessing_settings.Rd +++ b/man/dot-parse_preprocessing_settings.Rd @@ -70,7 +70,7 @@ Several method are available: filter, for example, genes that are not differentially expressed. \item \code{univariate_test}: Features undergo a univariate regression using an outcome-appropriate regression model. The p-value of the model coefficient -is collected. Features with coefficient p or q-value above the +is collected. Features with coefficient p-value above the \code{univariate_test_threshold} are subsequently filtered. \item \code{robustness}: Features that are not sufficiently robust according to the intraclass correlation coefficient are filtered. Use of this method @@ -83,19 +83,16 @@ values are always filtered, as these do not contain information.} \item{univariate_test_threshold}{(\emph{optional}) Numeric value between \code{1.0} and \code{0.0} that determines which features are irrelevant and will be filtered by -the \code{univariate_test}. The p or q-values are compared to this threshold. +the \code{univariate_test}. p-values are compared to this threshold. All features with values above the threshold are filtered. The default value is \code{0.20}.} \item{univariate_test_threshold_metric}{(\emph{optional}) Metric used with the to -compare the \code{univariate_test_threshold} against. The following metrics can +compare the \code{univariate_test_threshold} against. The following metric can be chosen: \itemize{ \item \code{p_value} (default): The unadjusted p-value of each feature is used for to filter features. -\item \code{q_value}: The q-value (Story, 2002), is used to filter features. Some -data sets may have insufficient samples to compute the q-value. The -\code{qvalue} package must be installed from Bioconductor to use this method. }} \item{univariate_test_max_feature_set_size}{(\emph{optional}) Maximum size of the @@ -153,7 +150,7 @@ methods are available: \item \code{none}: This disables transformation of features. \item \code{yeo_johnson}: Transformation using the location and scale invariant version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -Zwanenburg and Löck, 2023). +Zwanenburg and Löck, 2026). \item \code{yeo_johnson_robust} (default): A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{yeo_johnson_conventional}: As \code{yeo_johnson}, but without optimisation of @@ -161,7 +158,7 @@ location and scale parameters. This method is equivalent to the original transformation proposed by Yeo and Johnson (2001). \item \code{box_cox}: Transformation using the location and scale invariant version of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -2023). +2026). \item \code{box_cox_robust}: A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{box_cox_conventional}: As \code{box_cox}, but without optimisation of @@ -182,13 +179,13 @@ optimisation criteria, of which the following are available: \itemize{ \item \code{mle} (default): Optimisation using maximum likelihood estimation. \item \code{cramer_von_mises}: Optimisation using the Cramér-von Mises -criterion. Zwanenburg and Löck (2023) found that this criterion was +criterion. Zwanenburg and Löck (2026) found that this criterion was relatively robust against outliers. }} \item{transformation_gof_test_p_value}{(\emph{optional}) Not all transformations will lead to features that are roughly normally distributed. Zwanenburg and -Löck (2023) established a empirical goodness-of-fit test for central +Löck (2026) established a empirical goodness-of-fit test for central normality. This parameter sets the significance for rejecting the null-hypothesis that a feature distribution is centrally normal. When the null-hypothesis is rejected, no transformation is performed. The default @@ -457,8 +454,6 @@ Internal function for parsing settings related to preprocessing } \references{ \enumerate{ -\item Storey, J. D. A direct approach to false discovery rates. J. -R. Stat. Soc. Series B Stat. Methodol. 64, 479–498 (2002). \item Shrout, P. E. & Fleiss, J. L. Intraclass correlations: uses in assessing rater reliability. Psychol. Bull. 86, 420–428 (1979). \item Koo, T. K. & Li, M. Y. A guideline of selecting and reporting intraclass @@ -470,6 +465,9 @@ improve normality or symmetry. Biometrika 87, 954–959 (2000). Soc. Series B Stat. Methodol. 26, 211–252 (1964). \item Raymaekers, J., Rousseeuw, P. J. Transforming variables to central normality. Mach Learn. (2021). +\item Zwanenburg, A., & Löck, S. (2026). Location and scale-invariant power +transformations for transforming data to normality. Machine Learning, +115(3), 34. \item Park, M. Y., Hastie, T. & Tibshirani, R. Averaged gene expressions for regression. Biostatistics 8, 212–227 (2007). \item Tolosi, L. & Lengauer, T. Classification with correlated features: diff --git a/man/dot-parse_feature_selection_settings.Rd b/man/dot-parse_variable_importance_settings.Rd similarity index 74% rename from man/dot-parse_feature_selection_settings.Rd rename to man/dot-parse_variable_importance_settings.Rd index 8c1c09fb..2a684543 100644 --- a/man/dot-parse_feature_selection_settings.Rd +++ b/man/dot-parse_variable_importance_settings.Rd @@ -1,19 +1,20 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ParseSettings.R -\name{.parse_feature_selection_settings} -\alias{.parse_feature_selection_settings} -\title{Internal function for parsing settings related to feature selection} +\name{.parse_variable_importance_settings} +\alias{.parse_variable_importance_settings} +\title{Internal function for parsing settings related to variable importance +computation.} \usage{ -.parse_feature_selection_settings( +.parse_variable_importance_settings( config = NULL, data, parallel, outcome_type, - fs_method = waiver(), - fs_method_parameter = waiver(), + vimp_method = waiver(), + vimp_method_parameter = waiver(), vimp_aggregation_method = waiver(), vimp_aggregation_rank_threshold = waiver(), - parallel_feature_selection = waiver(), + parallel_vimp = waiver(), ... ) } @@ -23,23 +24,22 @@ \item{data}{Data set as loaded using the \code{.load_data} function.} \item{parallel}{Logical value that whether familiar uses parallelisation. If -\code{FALSE} it will override \code{parallel_feature_selection}.} +\code{FALSE} it will override \code{parallel_vimp}.} \item{outcome_type}{Type of outcome found in the data set.} -\item{fs_method}{(\strong{required}) Feature selection method to be used for -determining variable importance. \code{familiar} implements various feature -selection methods. Please refer to the vignette on feature selection -methods for more details. +\item{vimp_method}{(\strong{required}) Variable importance method. \code{familiar} +implements various variable importance methods. Please refer to the +vignette on variable importance methods for more details. -More than one feature selection method can be chosen. The experiment will +More than one variable importance method can be chosen. The experiment will then repeated for each feature selection method. -Feature selection methods determines the ranking of features. Actual +Variable importance methods determine the ranking of features. Actual selection of features is done by optimising the signature size model hyperparameter during the hyperparameter optimisation step.} -\item{fs_method_parameter}{(\emph{optional}) List of lists containing parameters +\item{vimp_method_parameter}{(\emph{optional}) List of lists containing parameters for feature selection methods. Each sublist should have the name of the feature selection method it corresponds to. @@ -83,26 +83,27 @@ feature rank. The \emph{feature selection methods} vignette provides additional information.} \item{vimp_aggregation_rank_threshold}{(\emph{optional}) The threshold used to -define the subset of highly important features. If not set, this threshold -is determined by maximising the variance in the occurrence value over all -features over the subset size. +define the subset of highly important features. If set to \code{NULL}, this +threshold is determined by maximising the variance in the occurrence value +over all features over the subset size. The default value is \code{5}. This parameter is only relevant for \code{stability}, \code{exponential}, \code{enhanced_borda}, \code{truncated_borda} and \code{enhanced_truncated_borda} methods.} -\item{parallel_feature_selection}{(\emph{optional}) Enable parallel processing for -the feature selection workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, +\item{parallel_vimp}{(\emph{optional}) Enable parallel processing for +variable importance tasks. Defaults to \code{TRUE}. When set to \code{FALSE}, this will disable the use of parallel processing while performing feature selection, regardless of the settings of the \code{parallel} parameter. -\code{parallel_feature_selection} is ignored if \code{parallel=FALSE}.} +\code{parallel_vimp} is ignored if \code{parallel = FALSE}.} \item{...}{Unused arguments.} } \value{ -List of parameters related to feature selection. +List of parameters related to variable importance computation. } \description{ -Internal function for parsing settings related to feature selection +Internal function for parsing settings related to variable importance +computation. } \references{ \enumerate{ diff --git a/man/dot-plot_permutation_variable_importance.Rd b/man/dot-plot_permutation_variable_importance.Rd index ad8d469c..9ba8b422 100644 --- a/man/dot-plot_permutation_variable_importance.Rd +++ b/man/dot-plot_permutation_variable_importance.Rd @@ -17,6 +17,7 @@ plot_title, plot_sub_title, caption, + limit_n_features, conf_int_style, conf_int_alpha, x_range, @@ -41,8 +42,15 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette used to fill the bars in case a -non-singular variable was provided to the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -62,6 +70,10 @@ NULL, no subtitle is shown.} \item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no caption is shown.} +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + \item{conf_int_style}{(\emph{optional}) Confidence interval style. See details for allowed styles.} diff --git a/man/dot-plot_univariate_importance.Rd b/man/dot-plot_univariate_importance.Rd index 4a2ede3c..dadffcea 100644 --- a/man/dot-plot_univariate_importance.Rd +++ b/man/dot-plot_univariate_importance.Rd @@ -19,6 +19,7 @@ plot_title, plot_sub_title, caption, + limit_n_features, x_range, x_breaks, significance_level_shown @@ -44,14 +45,27 @@ wrapping. If NULL, a facet grid is produced instead.} \item{show_cluster}{(\emph{optional}) Show which features were clustered together.} -\item{discrete_palette}{(\emph{optional}) Palette used to fill the bars in case a -non-singular variable was provided to the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette}{(\emph{optional}) Palette to use for filling the bars in case the \code{color_by} argument is not set. The bars are then coloured according to their importance. By default, no gradient is used, and the bars are not filled according to importance. Use \code{NULL} to fill the bars -using the default palette in \code{familiar}.} +using the default palette in \code{familiar}. Other palettes are supported by +the \code{paletteer} package, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -71,6 +85,10 @@ NULL, no subtitle is shown.} \item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no caption is shown.} +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + \item{x_range}{(\emph{optional}) Value range for the x-axis.} \item{x_breaks}{(\emph{optional}) Break points on the x-axis of the plot.} diff --git a/man/dot-prepare_familiar_data_sets.Rd b/man/dot-prepare_familiar_data_sets.Rd deleted file mode 100644 index 8b64b572..00000000 --- a/man/dot-prepare_familiar_data_sets.Rd +++ /dev/null @@ -1,38 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Evaluation.R -\name{.prepare_familiar_data_sets} -\alias{.prepare_familiar_data_sets} -\title{Prepare familiarData objects for evaluation at runtime.} -\usage{ -.prepare_familiar_data_sets( - cl = NULL, - only_pooling = FALSE, - message_indent = 0L, - verbose = FALSE -) -} -\arguments{ -\item{cl}{Cluster for parallel processing.} - -\item{only_pooling}{Flag that, if set, forces evaluation of only the -top-level data, and not e.g. ensembles.} - -\item{message_indent}{indent that messages should have.} - -\item{verbose}{Sets verbosity} -} -\value{ -A data.table with created links to created data objects. -} -\description{ -Information concerning models, features and the experiment is -processed and stored in familiarData objects. Information can be extracted -from these objects as csv files, or by plotting, or multiple objects can be -combined into familiarCollection objects, which allows aggregated exports. -} -\details{ -This function generates the names of familiarData object files, and -their corresponding generating ensemble, which allows the familiarData -objects to be created. -} -\keyword{internal} diff --git a/man/dot-update_experimental_design_settings.Rd b/man/dot-update_experimental_design_settings.Rd index 41a1c21c..b9b30af4 100644 --- a/man/dot-update_experimental_design_settings.Rd +++ b/man/dot-update_experimental_design_settings.Rd @@ -4,7 +4,12 @@ \alias{.update_experimental_design_settings} \title{Internal function to check batch assignment to development and validation} \usage{ -.update_experimental_design_settings(section_table, data, settings) +.update_experimental_design_settings( + section_table, + data, + settings, + verbose = FALSE +) } \arguments{ \item{section_table}{data.table generated by the \code{extract_experimental_setup} diff --git a/man/experimentData-class.Rd b/man/experimentData-class.Rd index 91f25f6c..b76153a5 100644 --- a/man/experimentData-class.Rd +++ b/man/experimentData-class.Rd @@ -27,6 +27,10 @@ are assigned to training, validation and test sets.} experimentData object was generated using the \code{precompute_feature_info} or \code{precompute_vimp} functions.} +\item{\code{vimp_hyperparameter_list}}{List of hyperparameters for variable importance +objects. Only available if the experimentData object was created using the +\code{precompute_vimp} function.} + \item{\code{vimp_table_list}}{List of variable importance table objects. Only available if the experimentData object was created using the \code{precompute_vimp} function.} diff --git a/man/export_all-methods.Rd b/man/export_all-methods.Rd index bce43db1..af389221 100644 --- a/man/export_all-methods.Rd +++ b/man/export_all-methods.Rd @@ -23,7 +23,7 @@ will allow export as a structured list of data.tables.} aggregated for export.} \item{...}{ - Arguments passed on to \code{\link[=extract_data]{extract_data}}, \code{\link[=as_familiar_collection]{as_familiar_collection}} + Arguments passed on to \code{\link[=.extract_data]{.extract_data}}, \code{\link[=as_familiar_collection]{as_familiar_collection}} \describe{ \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -37,8 +37,8 @@ risks generated by random forest, or the cut-off value for Uno's concordance index. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -161,14 +161,23 @@ Default is \code{all}, but specific elements can be specified to speed up computations if not all elements are to be computed. This is an internal parameter that is set by, e.g. the \code{export_model_vimp} method.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -212,7 +221,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -280,13 +293,6 @@ stratify samples into two optimally separated risk groups. One or more stratification methods can be selected simultaneously. This parameter is only relevant for \code{survival} outcomes.} - \item{\code{dynamic_model_loading}}{(\emph{optional}) Enables dynamic loading of models -during the evaluation process, if \code{TRUE}. Defaults to \code{FALSE}. Dynamic -loading of models may reduce the overall memory footprint, at the cost of -increased disk or network IO. Models can only be dynamically loaded if they -are found at an accessible disk or network location. Setting this parameter -to \code{TRUE} may help if parallel processing causes out-of-memory issues during -evaluation.} \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} parameter is one or more \code{familiarData} objects.} \item{\code{collection_name}}{Name of the collection.} diff --git a/man/export_auc_data-methods.Rd b/man/export_auc_data-methods.Rd index 062abb32..dc1ab155 100644 --- a/man/export_auc_data-methods.Rd +++ b/man/export_auc_data-methods.Rd @@ -107,7 +107,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ diff --git a/man/export_calibration_data-methods.Rd b/man/export_calibration_data-methods.Rd index 245e6850..e4d82312 100644 --- a/man/export_calibration_data-methods.Rd +++ b/man/export_calibration_data-methods.Rd @@ -52,8 +52,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -112,7 +112,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ diff --git a/man/export_confusion_matrix_data-methods.Rd b/man/export_confusion_matrix_data-methods.Rd index 01bb8a14..5794a2d6 100644 --- a/man/export_confusion_matrix_data-methods.Rd +++ b/man/export_confusion_matrix_data-methods.Rd @@ -101,7 +101,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} parameter is one or more \code{familiarData} objects.} \item{\code{collection_name}}{Name of the collection.} diff --git a/man/export_feature_expressions-methods.Rd b/man/export_feature_expressions-methods.Rd index fa9786f9..1bc4c81a 100644 --- a/man/export_feature_expressions-methods.Rd +++ b/man/export_feature_expressions-methods.Rd @@ -45,7 +45,7 @@ parameter is read from settings used at creation of the underlying \item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} \item{...}{ - Arguments passed on to \code{\link[=extract_feature_expression]{extract_feature_expression}}, \code{\link[=as_familiar_collection]{as_familiar_collection}} + Arguments passed on to \code{\link[=extract_feature_expression]{extract_feature_expression}}, \code{\link[=as_familiar_collection]{as_familiar_collection}}, \code{\link[=as_data_object]{as_data_object}} \describe{ \item{\code{feature_similarity}}{Table containing pairwise distance between sample. This is used to determine cluster information, and indicate which @@ -53,8 +53,8 @@ samples are similar. The table is created by the \code{extract_sample_similarity} method.} \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -131,16 +131,9 @@ Extract and export feature expressions for the features in a familiarCollection. } \details{ -Data is usually collected from a \code{familiarCollection} object. -However, you can also provide one or more \code{familiarData} objects, that will -be internally converted to a \code{familiarCollection} object. It is also -possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} -objects together with the data from which data is computed prior to export. -Paths to the previous files can also be provided. - All parameters aside from \code{object} and \code{dir_path} are only used if \code{object} is not a \code{familiarCollection} object, or a path to one. -Feature expressions are computed by standardising each feature, i.e. sample -mean is 0 and standard deviation is 1. +Feature similarity data can be created from \code{dataObject}, or \code{data.table} objects. +For \code{data.table}, see \code{\link{as_data_object}} for additional arguments. } diff --git a/man/export_feature_similarity-methods.Rd b/man/export_feature_similarity-methods.Rd index d58286d3..badf3b6a 100644 --- a/man/export_feature_similarity-methods.Rd +++ b/man/export_feature_similarity-methods.Rd @@ -109,11 +109,14 @@ element objects.} \item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} \item{...}{ - Arguments passed on to \code{\link[=as_familiar_collection]{as_familiar_collection}} + Arguments passed on to \code{\link[=as_familiar_collection]{as_familiar_collection}}, \code{\link[=as_data_object]{as_data_object}} \describe{ \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} parameter is one or more \code{familiarData} objects.} \item{\code{collection_name}}{Name of the collection.} + \item{\code{data}}{A \code{data.frame} or \code{data.table}, a path to such tables on a local +or network drive, or a path to tabular data that may be converted to these +formats.} }} } \value{ @@ -125,13 +128,9 @@ Extract and export mutual correlation between features in a familiarCollection. } \details{ -Data is usually collected from a \code{familiarCollection} object. -However, you can also provide one or more \code{familiarData} objects, that will -be internally converted to a \code{familiarCollection} object. It is also -possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} -objects together with the data from which data is computed prior to export. -Paths to the previous files can also be provided. - All parameters aside from \code{object} and \code{dir_path} are only used if \code{object} is not a \code{familiarCollection} object, or a path to one. + +Feature similarity data can be created from \code{dataObject}, or \code{data.table} objects. +For \code{data.table}, see \code{\link{as_data_object}} for additional arguments. } diff --git a/man/export_ice_data-methods.Rd b/man/export_ice_data-methods.Rd index 256b12ac..edbd4020 100644 --- a/man/export_ice_data-methods.Rd +++ b/man/export_ice_data-methods.Rd @@ -64,8 +64,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -82,14 +82,23 @@ computation and extraction of various data elements.} \item{\code{message_indent}}{Number of indentation steps for messages shown during computation and extraction of various data elements.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -133,7 +142,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ diff --git a/man/export_model_performance-methods.Rd b/man/export_model_performance-methods.Rd index ce567bc0..0075ae32 100644 --- a/man/export_model_performance-methods.Rd +++ b/man/export_model_performance-methods.Rd @@ -52,8 +52,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -116,7 +116,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ diff --git a/man/export_partial_dependence_data-methods.Rd b/man/export_partial_dependence_data-methods.Rd index a276b69e..c83ad430 100644 --- a/man/export_partial_dependence_data-methods.Rd +++ b/man/export_partial_dependence_data-methods.Rd @@ -64,8 +64,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -82,14 +82,23 @@ computation and extraction of various data elements.} \item{\code{message_indent}}{Number of indentation steps for messages shown during computation and extraction of various data elements.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -133,7 +142,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ diff --git a/man/export_permutation_vimp-methods.Rd b/man/export_permutation_vimp-methods.Rd index 68969503..34b985d4 100644 --- a/man/export_permutation_vimp-methods.Rd +++ b/man/export_permutation_vimp-methods.Rd @@ -52,8 +52,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -115,6 +115,24 @@ creation of the underlying \code{familiarModel} objects.} computation and extraction of various data elements.} \item{\code{message_indent}}{Number of indentation steps for messages shown during computation and extraction of various data elements.} + \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples +that are used during evaluation steps. Cannot be fewer than 20. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("sample_similarity"=100, "permutation_vimp"=1000)}. + +This parameter can be set for the following data elements: +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -158,7 +176,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ diff --git a/man/export_prediction_data-methods.Rd b/man/export_prediction_data-methods.Rd index 9cb12f63..c7944480 100644 --- a/man/export_prediction_data-methods.Rd +++ b/man/export_prediction_data-methods.Rd @@ -1,16 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/FamiliarDataComputationPredictionData.R +% Please edit documentation in R/FamiliarDataComputationPredictionData.R, +% R/PredictionTable.R \name{export_prediction_data} \alias{export_prediction_data} -\alias{export_prediction_data,familiarCollection-method} \alias{export_prediction_data,ANY-method} +\alias{export_prediction_data,familiarCollection-method} \title{Extract and export predicted values.} \usage{ export_prediction_data(object, dir_path = NULL, export_collection = FALSE, ...) -\S4method{export_prediction_data}{familiarCollection}(object, dir_path = NULL, export_collection = FALSE, ...) - \S4method{export_prediction_data}{ANY}(object, dir_path = NULL, export_collection = FALSE, ...) + +\S4method{export_prediction_data}{familiarCollection}(object, dir_path = NULL, export_collection = FALSE, ...) } \arguments{ \item{object}{A \code{familiarCollection} object, or other other objects from which @@ -31,8 +32,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -91,7 +92,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ diff --git a/man/export_risk_stratification_data-methods.Rd b/man/export_risk_stratification_data-methods.Rd index 0e722546..1b469ecd 100644 --- a/man/export_risk_stratification_data-methods.Rd +++ b/man/export_risk_stratification_data-methods.Rd @@ -114,7 +114,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{confidence_level}}{(\emph{optional}) Numeric value for the level at which confidence intervals are determined. In the case bootstraps are used to determine the confidence intervals bootstrap estimation, \code{familiar} uses the diff --git a/man/export_sample_similarity-methods.Rd b/man/export_sample_similarity-methods.Rd index e1d870a7..5f1dab42 100644 --- a/man/export_sample_similarity-methods.Rd +++ b/man/export_sample_similarity-methods.Rd @@ -53,14 +53,14 @@ will allow export as a structured list of data.tables.} aggregated for export.} \item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} \item{sample_cluster_method}{The method used to perform clustering based on distance between samples. These are the same methods as for the @@ -85,11 +85,14 @@ creation of the underlying \code{familiarModel} objects.} \item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} \item{...}{ - Arguments passed on to \code{\link[=as_familiar_collection]{as_familiar_collection}} + Arguments passed on to \code{\link[=as_familiar_collection]{as_familiar_collection}}, \code{\link[=as_data_object]{as_data_object}} \describe{ \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} parameter is one or more \code{familiarData} objects.} \item{\code{collection_name}}{Name of the collection.} + \item{\code{data}}{A \code{data.frame} or \code{data.table}, a path to such tables on a local +or network drive, or a path to tabular data that may be converted to these +formats.} }} } \value{ @@ -101,13 +104,9 @@ Extract and export mutual correlation between features in a familiarCollection. } \details{ -Data is usually collected from a \code{familiarCollection} object. -However, you can also provide one or more \code{familiarData} objects, that will -be internally converted to a \code{familiarCollection} object. It is also -possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} -objects together with the data from which data is computed prior to export. -Paths to the previous files can also be provided. - All parameters aside from \code{object} and \code{dir_path} are only used if \code{object} is not a \code{familiarCollection} object, or a path to one. + +Sample similarity data can be created from \code{dataObject}, or \code{data.table} objects. +For \code{data.table}, see \code{\link{as_data_object}} for additional arguments. } diff --git a/man/export_shap-methods.Rd b/man/export_shap-methods.Rd new file mode 100644 index 00000000..dd72e897 --- /dev/null +++ b/man/export_shap-methods.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FamiliarDataComputationSHAP.R +\name{export_shap} +\alias{export_shap} +\alias{export_shap,familiarCollection-method} +\alias{export_shap,ANY-method} +\title{Extract and export individual conditional expectation data.} +\usage{ +export_shap( + object, + dir_path = NULL, + aggregate_results = TRUE, + export_collection = FALSE, + feature_x = NULL, + feature_y = NULL, + ... +) + +\S4method{export_shap}{familiarCollection}( + object, + dir_path = NULL, + aggregate_results = TRUE, + export_collection = FALSE, + feature_x = NULL, + feature_y = NULL, + ... +) + +\S4method{export_shap}{ANY}( + object, + dir_path = NULL, + aggregate_results = TRUE, + export_collection = FALSE, + feature_x = NULL, + feature_y = NULL, + ... +) +} +\arguments{ +\item{object}{A \code{familiarCollection} object, or other other objects from which +a \code{familiarCollection} can be extracted. See details for more information.} + +\item{dir_path}{Path to folder where extracted data should be saved. \code{NULL} +will allow export as a structured list of data.tables.} + +\item{aggregate_results}{Flag that signifies whether results should be +aggregated for export.} + +\item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} + +\item{feature_x}{(\emph{optional}) Feature(s) whose SHAP values are used for +determining dependence.} + +\item{feature_y}{(\emph{optional}) Feature(s) whose values are used to show +interaction with the feature(s) in \code{feature_x}.} + +\item{...}{ + Arguments passed on to \code{\link[=as_familiar_collection]{as_familiar_collection}} + \describe{ + \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} +parameter is one or more \code{familiarData} objects.} + \item{\code{collection_name}}{Name of the collection.} + }} +} +\value{ +A list of data.tables (if \code{dir_path} is not provided), or nothing, as +all data is exported to \code{csv} files. +} +\description{ +Extract and export individual conditional expectation data. +} +\details{ +Data is usually collected from a \code{familiarCollection} object. +However, you can also provide one or more \code{familiarData} objects, that will +be internally converted to a \code{familiarCollection} object. It is also +possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} +objects together with the data from which data is computed prior to export. +Paths to the previous files can also be provided. + +All parameters aside from \code{object} and \code{dir_path} are only used if \code{object} +is not a \code{familiarCollection} object, or a path to one. +} diff --git a/man/export_univariate_analysis_data-methods.Rd b/man/export_univariate_analysis_data-methods.Rd index 29135ebd..57f9c806 100644 --- a/man/export_univariate_analysis_data-methods.Rd +++ b/man/export_univariate_analysis_data-methods.Rd @@ -40,7 +40,7 @@ will allow export as a structured list of data.tables.} \item{p_adjustment_method}{(\emph{optional}) Indicates type of p-value that is shown. One of \code{holm}, \code{hochberg}, \code{hommel}, \code{bonferroni}, \code{BH}, \code{BY}, \code{fdr}, \code{none}, \code{p_value} or \code{q_value} for adjusted p-values, uncorrected -p-values and q-values. q-values may not be available.} +p-values} \item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} @@ -127,7 +127,7 @@ Paths to the previous files can also be provided. All parameters aside from \code{object} and \code{dir_path} are only used if \code{object} is not a \code{familiarCollection} object, or a path to one. -Univariate analysis includes the computation of p and q-values, as well as +Univariate analysis includes the computation of p-values, as well as robustness (in case of repeated measurements). p-values are derived from Wald's test. } diff --git a/man/extract_auc_data.Rd b/man/extract_auc_data.Rd index ce404ed2..eb80a550 100644 --- a/man/extract_auc_data.Rd +++ b/man/extract_auc_data.Rd @@ -21,8 +21,9 @@ extract_auc_data( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -82,7 +83,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: diff --git a/man/extract_calibration_data.Rd b/man/extract_calibration_data.Rd index c37d1c26..30eb8546 100644 --- a/man/extract_calibration_data.Rd +++ b/man/extract_calibration_data.Rd @@ -22,8 +22,9 @@ extract_calibration_data( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -40,8 +41,8 @@ value for a sample. sample. }} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -89,7 +90,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: diff --git a/man/extract_calibration_info.Rd b/man/extract_calibration_info.Rd index 82d7ec66..0d03525b 100644 --- a/man/extract_calibration_info.Rd +++ b/man/extract_calibration_info.Rd @@ -13,8 +13,9 @@ extract_calibration_info( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{detail_level}{(\emph{optional}) Sets the level at which results are computed and aggregated. @@ -59,7 +60,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{message_indent}{Number of indentation steps for messages shown during computation and extraction of various data elements.} diff --git a/man/extract_confusion_matrix.Rd b/man/extract_confusion_matrix.Rd index d0e6b42c..4171666c 100644 --- a/man/extract_confusion_matrix.Rd +++ b/man/extract_confusion_matrix.Rd @@ -17,8 +17,9 @@ extract_confusion_matrix( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -78,7 +79,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{is_pre_processed}{Flag that indicates whether the data was already pre-processed externally, e.g. normalised and clustered. Only used if the diff --git a/man/extract_decision_curve_data.Rd b/man/extract_decision_curve_data.Rd index b0f3e001..40f77f4b 100644 --- a/man/extract_decision_curve_data.Rd +++ b/man/extract_decision_curve_data.Rd @@ -22,8 +22,9 @@ extract_decision_curve_data( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -40,8 +41,8 @@ value for a sample. sample. }} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -89,7 +90,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: diff --git a/man/extract_experimental_setup.Rd b/man/extract_experimental_setup.Rd index 6e21bdf9..61fa8190 100644 --- a/man/extract_experimental_setup.Rd +++ b/man/extract_experimental_setup.Rd @@ -14,10 +14,13 @@ extract_experimental_setup( \arguments{ \item{experimental_design}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)+ev} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building, and external validation. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building, and external validation. The basic workflow +components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (optional) variable importance computation step. If not explicitly +declared, feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. \item \code{ev}: (optional) external validation. Note that internal validation due to subsampling will always be conducted if the subsampling methods create diff --git a/man/extract_feature_expression.Rd b/man/extract_feature_expression.Rd index 6f3bfa1f..96cccbb2 100644 --- a/man/extract_feature_expression.Rd +++ b/man/extract_feature_expression.Rd @@ -22,8 +22,9 @@ extract_feature_expression( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -94,8 +95,8 @@ the metric name. This reduces the effect of outliers somewhat. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects.} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} diff --git a/man/extract_feature_similarity.Rd b/man/extract_feature_similarity.Rd index 20d5d268..b30ae2b9 100644 --- a/man/extract_feature_similarity.Rd +++ b/man/extract_feature_similarity.Rd @@ -24,8 +24,9 @@ extract_feature_similarity( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} diff --git a/man/extract_fs_vimp.Rd b/man/extract_fs_vimp.Rd index 5c836700..8bf3046a 100644 --- a/man/extract_fs_vimp.Rd +++ b/man/extract_fs_vimp.Rd @@ -14,8 +14,9 @@ extract_fs_vimp( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{aggregation_method}{Method for aggregating variable importances for the purpose of evaluation. Variable importances are determined during feature diff --git a/man/extract_hyperparameters.Rd b/man/extract_hyperparameters.Rd index a7a13fc7..f2f9f156 100644 --- a/man/extract_hyperparameters.Rd +++ b/man/extract_hyperparameters.Rd @@ -7,8 +7,9 @@ extract_hyperparameters(object, message_indent = 0L, verbose = FALSE, ...) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{message_indent}{Number of indentation steps for messages shown during computation and extraction of various data elements.} diff --git a/man/extract_ice.Rd b/man/extract_ice.Rd index 6ef27c47..8c4e4fd0 100644 --- a/man/extract_ice.Rd +++ b/man/extract_ice.Rd @@ -12,10 +12,11 @@ extract_ice( features = NULL, feature_x_range = NULL, feature_y_range = NULL, - n_sample_points = 50L, + n_sample_points = 20L, ensemble_method = waiver(), evaluation_times = waiver(), sample_limit = waiver(), + n_important_features = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), @@ -28,8 +29,9 @@ extract_ice( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -62,21 +64,31 @@ value for a sample. sample. }} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} \item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + +\item{n_important_features}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{detail_level}{(\emph{optional}) Sets the level at which results are computed and aggregated. @@ -121,7 +133,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: diff --git a/man/extract_model_vimp.Rd b/man/extract_model_vimp.Rd index 49cd5f8e..ba9dfa94 100644 --- a/man/extract_model_vimp.Rd +++ b/man/extract_model_vimp.Rd @@ -15,8 +15,9 @@ extract_model_vimp( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} diff --git a/man/extract_performance.Rd b/man/extract_performance.Rd index 20bc819b..d54f8d1d 100644 --- a/man/extract_performance.Rd +++ b/man/extract_performance.Rd @@ -23,8 +23,9 @@ extract_performance( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -46,8 +47,8 @@ value for a sample. sample. }} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -95,7 +96,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: diff --git a/man/extract_permutation_vimp.Rd b/man/extract_permutation_vimp.Rd index 807e373f..1a1c9f4d 100644 --- a/man/extract_permutation_vimp.Rd +++ b/man/extract_permutation_vimp.Rd @@ -17,11 +17,13 @@ extract_permutation_vimp( feature_similarity_threshold = waiver(), metric = waiver(), evaluation_times = waiver(), + sample_limit = waiver(), detail_level = waiver(), estimation_type = waiver(), aggregate_results = waiver(), confidence_level = waiver(), bootstrap_ci_method = waiver(), + n_important_features = waiver(), is_pre_processed = FALSE, message_indent = 0L, verbose = FALSE, @@ -29,8 +31,9 @@ extract_permutation_vimp( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -99,12 +102,22 @@ vignette on performance metrics for the available metrics. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects.} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} +\item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples +that are used during evaluation steps. Cannot be fewer than 20. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("sample_similarity"=100, "permutation_vimp"=1000)}. + +This parameter can be set for the following data elements: +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{detail_level}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -148,7 +161,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: @@ -207,6 +224,16 @@ Note that the standard method is not implemented because this method is often not suitable due to non-normal distributions. The bias-corrected and accelerated (BCa) method is not implemented yet.} +\item{n_important_features}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} + \item{is_pre_processed}{Flag that indicates whether the data was already pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} diff --git a/man/extract_predictions.Rd b/man/extract_predictions.Rd index a8372c0d..ad882e17 100644 --- a/man/extract_predictions.Rd +++ b/man/extract_predictions.Rd @@ -21,8 +21,9 @@ extract_predictions( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -43,8 +44,8 @@ value for a sample. sample. }} -\item{evaluation_times}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -92,7 +93,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{estimation_type}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: diff --git a/man/extract_risk_stratification_data.Rd b/man/extract_risk_stratification_data.Rd index 898b637b..09bd975e 100644 --- a/man/extract_risk_stratification_data.Rd +++ b/man/extract_risk_stratification_data.Rd @@ -18,8 +18,9 @@ extract_risk_stratification_data( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -83,7 +84,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{confidence_level}{(\emph{optional}) Numeric value for the level at which confidence intervals are determined. In the case bootstraps are used to diff --git a/man/extract_risk_stratification_info.Rd b/man/extract_risk_stratification_info.Rd index 8b15056a..1fcb0867 100644 --- a/man/extract_risk_stratification_info.Rd +++ b/man/extract_risk_stratification_info.Rd @@ -13,8 +13,9 @@ extract_risk_stratification_info( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{detail_level}{(\emph{optional}) Sets the level at which results are computed and aggregated. @@ -59,7 +60,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{message_indent}{Number of indentation steps for messages shown during computation and extraction of various data elements.} diff --git a/man/extract_sample_similarity.Rd b/man/extract_sample_similarity.Rd index fd088936..5e47c79b 100644 --- a/man/extract_sample_similarity.Rd +++ b/man/extract_sample_similarity.Rd @@ -19,8 +19,9 @@ extract_sample_similarity( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -33,14 +34,14 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} \item{sample_cluster_method}{The method used to perform clustering based on distance between samples. These are the same methods as for the @@ -85,7 +86,7 @@ computation and extraction of various data elements.} \item{...}{Unused arguments.} } \value{ -A data.table containing pairwise distance between samples. This data +An object containing pairwise distance between samples. This data is only the upper triangular of the complete matrix (i.e. the sparse unitriangular representation). Diagonals will always be 0.0 and the lower triangular is mirrored. diff --git a/man/extract_shap.Rd b/man/extract_shap.Rd new file mode 100644 index 00000000..016f21d3 --- /dev/null +++ b/man/extract_shap.Rd @@ -0,0 +1,176 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FamiliarDataComputationSHAP.R +\name{extract_shap} +\alias{extract_shap} +\title{Internal function for computing SHAP values.} +\usage{ +extract_shap( + object, + data, + cl = NULL, + features = NULL, + n_sample_points = 20L, + shap_tolerance = waiver(), + shap_max_iterations = waiver(), + shap_phi_0 = waiver(), + ensemble_method = waiver(), + evaluation_times = waiver(), + sample_limit = waiver(), + detail_level = waiver(), + aggregate_results = waiver(), + n_important_features = waiver(), + is_pre_processed = FALSE, + message_indent = 0L, + verbose = FALSE, + ... +) +} +\arguments{ +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} + +\item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that +constitutes the data that are assessed.} + +\item{cl}{Cluster created using the \code{parallel} package. This cluster is then +used to speed up computation through parallellisation.} + +\item{features}{Features for whose values SHAP values need to be computed. +defaults to all features in the model.} + +\item{n_sample_points}{Minimum number of values to sample for numeric +features. By default, this is based on input dataset. But if the number of +values of a feature within that dataset is too low, additional values are +drawn from the feature distribution (stored with the model).} + +\item{shap_tolerance}{Relative tolerance for convergence of SHAP values. The +tolerance is scaled with the range in SHAP values. Default: 0.05.} + +\item{shap_max_iterations}{Maximum iterations for convergence of SHAP values. +Default: 1000} + +\item{shap_phi_0}{Reference predicted value(s). Determined from data by +default.} + +\item{ensemble_method}{Method for ensembling predictions from models for the +same sample. Available methods are: +\itemize{ +\item \code{median} (default): Use the median of the predicted values as the ensemble +value for a sample. +\item \code{mean}: Use the mean of the predicted values as the ensemble value for a +sample. +}} + +\item{evaluation_times}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. +calibration. If not provided explicitly, this parameter is read from +settings used at creation of the underlying \code{familiarModel} objects. Only +used for \code{survival} outcomes.} + +\item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples +that are used during evaluation steps. Cannot be fewer than 20. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("sample_similarity"=100, "permutation_vimp"=1000)}. + +This parameter can be set for the following data elements: +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + +\item{detail_level}{(\emph{optional}) Sets the level at which results are computed +and aggregated. +\itemize{ +\item \code{ensemble}: Results are computed at the ensemble level, i.e. over all +models in the ensemble. This means that, for example, bias-corrected +estimates of model performance are assessed by creating (at least) 20 +bootstraps and computing the model performance of the ensemble model for +each bootstrap. +\item \code{hybrid} (default): Results are computed at the level of models in an +ensemble. This means that, for example, bias-corrected estimates of model +performance are directly computed using the models in the ensemble. If there +are at least 20 trained models in the ensemble, performance is computed for +each model, in contrast to \code{ensemble} where performance is computed for the +ensemble of models. If there are less than 20 trained models in the +ensemble, bootstraps are created so that at least 20 point estimates can be +made. +\item \code{model}: Results are computed at the model level. This means that, for +example, bias-corrected estimates of model performance are assessed by +creating (at least) 20 bootstraps and computing the performance of the model +for each bootstrap. +} + +Note that each level of detail has a different interpretation for bootstrap +confidence intervals. For \code{ensemble} and \code{model} these are the confidence +intervals for the ensemble and an individual model, respectively. That is, +the confidence interval describes the range where an estimate produced by a +respective ensemble or model trained on a repeat of the experiment may be +found with the probability of the confidence level. For \code{hybrid}, it +represents the range where any single model trained on a repeat of the +experiment may be found with the probability of the confidence level. By +definition, confidence intervals obtained using \code{hybrid} are at least as +wide as those for \code{ensemble}. \code{hybrid} offers the correct interpretation if +the goal of the analysis is to assess the result of a single, unspecified, +model. + +\code{hybrid} is generally computationally less expensive then \code{ensemble}, which +in turn is somewhat less expensive than \code{model}. + +A non-default \code{detail_level} parameter can be specified for separate +evaluation steps by providing a parameter value in a named list with data +elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. +This parameter can be set for the following data elements: \code{auc_data}, +\code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} + +\item{aggregate_results}{(\emph{optional}) Flag that signifies whether results +should be aggregated during evaluation. If \code{estimation_type} is +\code{bias_correction} or \code{bc}, aggregation leads to a single bias-corrected +estimate. If \code{estimation_type} is \code{bootstrap_confidence_interval} or \code{bci}, +aggregation leads to a single bias-corrected estimate with lower and upper +boundaries of the confidence interval. This has no effect if +\code{estimation_type} is \code{point}. + +The default value is equal to \code{TRUE} except when assessing metrics to assess +model performance, as the default violin plot requires underlying data. + +As with \code{detail_level} and \code{estimation_type}, a non-default +\code{aggregate_results} parameter can be specified for separate evaluation steps +by providing a parameter value in a named list with data elements, e.g. +\code{list("auc_data"=TRUE, , "model_performance"=FALSE)}. This parameter exists +for the same elements as \code{estimation_type}.} + +\item{n_important_features}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} + +\item{is_pre_processed}{Flag that indicates whether the data was already +pre-processed externally, e.g. normalised and clustered. Only used if the +\code{data} argument is a \code{data.table} or \code{data.frame}.} + +\item{message_indent}{Number of indentation steps for messages shown during +computation and extraction of various data elements.} + +\item{verbose}{Flag to indicate whether feedback should be provided on the +computation and extraction of various data elements.} + +\item{...}{Unused arguments.} +} +\value{ +A list of familiarDataElements with SHAP values. +} +\description{ +Computes SHAP values for feature values using a +\code{familiarEnsemble}. +} +\keyword{internal} diff --git a/man/extract_univariate_analysis.Rd b/man/extract_univariate_analysis.Rd index c4ca6070..49133d48 100644 --- a/man/extract_univariate_analysis.Rd +++ b/man/extract_univariate_analysis.Rd @@ -21,8 +21,9 @@ extract_univariate_analysis( ) } \arguments{ -\item{object}{A \code{familiarEnsemble} object, which is an ensemble of one or more -\code{familiarModel} objects.} +\item{object}{A \code{familiarEnsemble}, which is an ensemble of one or more +\code{familiarModel} objects, or a \code{familiarDataElementPredictionTable} object +that contains prediction data.} \item{data}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that constitutes the data that are assessed.} @@ -99,6 +100,6 @@ univariate analysis of important features. \description{ Computes and extracts univariate analysis for the features used in a \code{familiarEnsemble} object. This assessment includes the computation of -p and q-values, as well as robustness (in case of repeated measurements). +p-values, as well as robustness (in case of repeated measurements). } \keyword{internal} diff --git a/man/familiar.Rd b/man/familiar.Rd index 739fcdba..cdbf7a1f 100644 --- a/man/familiar.Rd +++ b/man/familiar.Rd @@ -24,8 +24,8 @@ evaluation process come with confidence intervals. \seealso{ Useful links: \itemize{ - \item \url{https://github.com/alexzwanenburg/familiar} - \item Report bugs at \url{https://github.com/alexzwanenburg/familiar/issues} + \item \url{https://github.com/oncoray/familiar} + \item Report bugs at \url{https://github.com/oncoray/familiar/issues} } } @@ -39,12 +39,8 @@ Authors: Other contributors: \itemize{ - \item Stefan Leger [contributor] - \item Iram Shahzadi [contributor] - \item Asier Rabasco Meneghetti [contributor] - \item Sebastian Starke [contributor] - \item Technische Universität Dresden [copyright holder] \item German Cancer Research Center (DKFZ) [copyright holder] + \item Technische Universität Dresden [copyright holder] } } diff --git a/man/familiarCollection-class.Rd b/man/familiarCollection-class.Rd index 5800c0f8..49f798d4 100644 --- a/man/familiarCollection-class.Rd +++ b/man/familiarCollection-class.Rd @@ -20,8 +20,7 @@ objects. \item{\code{outcome_info}}{Outcome information object, which contains information concerning the outcome, such as class levels.} -\item{\code{fs_vimp}}{Variable importance data collected by feature selection -methods.} +\item{\code{fs_vimp}}{collected for variable importance methods.} \item{\code{model_vimp}}{Variable importance data collected from model-specific algorithms implemented by models created by familiar.} @@ -41,7 +40,8 @@ model, but without imputation.} \item{\code{learner}}{Learning algorithm(s) used for data in the collection.} -\item{\code{fs_method}}{Feature selection method(s) used for data in the collection.} +\item{\code{vimp_method}}{Variable importance method(s) used for data in the +collection.} \item{\code{prediction_data}}{Model predictions for the data in the collection.} @@ -71,6 +71,9 @@ data in the collection.} collection. Partial dependence data are computed on the fly from these data.} +\item{\code{shap_data}}{SHAP values for features included in a model or ensemble of +models.} + \item{\code{univariate_analysis}}{Univariate analysis results of data in the collection.} @@ -89,9 +92,9 @@ See \code{get_data_set_names} and \code{set_data_set_names}.} \item{\code{learner_labels}}{Labels for the different learning algorithms used to create the collection. See \code{get_learner_names} and \code{set_learner_names}.} -\item{\code{fs_method_labels}}{Labels for the different feature selection methods -used to create the collection. See \code{get_fs_method_names} and -\code{set_fs_method_names}.} +\item{\code{vimp_method_labels}}{Labels for the different variable importance methods +used to create the collection. See \code{get_vimp_method_names} and +\code{set_vimp_method_names}.} \item{\code{feature_labels}}{Labels for the features in this collection. See \code{get_feature_names} and \code{set_feature_names}.} diff --git a/man/familiarData-class.Rd b/man/familiarData-class.Rd index be376c6e..d75f7462 100644 --- a/man/familiarData-class.Rd +++ b/man/familiarData-class.Rd @@ -19,8 +19,7 @@ aggregated in a familiarCollection object. \item{\code{outcome_info}}{Outcome information object, which contains additional information concerning the outcome, such as class levels.} -\item{\code{fs_vimp}}{Variable importance data collected from feature selection -methods.} +\item{\code{fs_vimp}}{Data collected for variable importance methods.} \item{\code{model_vimp}}{Variable importance data collected from model-specific algorithms implemented by models created by familiar.} @@ -41,8 +40,8 @@ model or ensemble of models, but without imputation.} \item{\code{learner}}{Learning algorithm used to create the model or ensemble of models.} -\item{\code{fs_method}}{Feature selection method used to determine variable -importance for the model or ensemble of models.} +\item{\code{vimp_method}}{Method used to determine variable importance for the model +or ensemble of models.} \item{\code{pooling_table}}{Run table for the data underlying the familiarData object. Used internally.} @@ -77,6 +76,9 @@ based on the underlying dataset.} in a model or ensemble of models, based on the underlying dataset. Partial dependence data are computed on the fly from these data.} +\item{\code{shap_data}}{SHAP values for features included in a model or ensemble of +models.} + \item{\code{univariate_analysis}}{Univariate analysis of the underlying dataset.} \item{\code{feature_expressions}}{Feature expression values of the underlying @@ -88,12 +90,6 @@ dataset.} \item{\code{sample_similarity}}{Sample similarity information of the underlying dataset.} -\item{\code{is_validation}}{Signifies whether the underlying data forms a validation -dataset. Used internally.} - -\item{\code{generating_ensemble}}{Name of the ensemble that was used to generate the -familiarData object.} - \item{\code{project_id}}{Identifier of the project that generated the familiarData object.} diff --git a/man/familiarEnsemble-class.Rd b/man/familiarEnsemble-class.Rd index 5aae3412..edc9c37c 100644 --- a/man/familiarEnsemble-class.Rd +++ b/man/familiarEnsemble-class.Rd @@ -25,8 +25,8 @@ regarding identifier column names and outcome column names.} \item{\code{learner}}{Learning algorithm used to create the models in the ensemble.} -\item{\code{fs_method}}{Feature selection method used to determine variable -importance for the models in the ensemble.} +\item{\code{vimp_method}}{Method used to determine variable importance for the models +in the ensemble.} \item{\code{feature_info}}{List of objects containing feature information, e.g., name, class levels, transformation, normalisation and clustering @@ -41,6 +41,12 @@ models in the ensemble,} \item{\code{novelty_features}}{The combined set of features that is used to train all novelty detectors in the ensemble.} +\item{\code{data_id}}{Internal identifier for the dataset used to train or +evaluate the ensemble.} + +\item{\code{run_id}}{Internal identifier for the specific subset of the dataset used +used to train or evaluate the ensemble.} + \item{\code{run_table}}{Run table for the data used to train the ensemble. Used internally.} diff --git a/man/familiarModel-class.Rd b/man/familiarModel-class.Rd index cea8aad9..abaf7fad 100644 --- a/man/familiarModel-class.Rd +++ b/man/familiarModel-class.Rd @@ -42,8 +42,16 @@ detect out-of-distribution samples.} \item{\code{learner}}{Learning algorithm used to create the model.} -\item{\code{fs_method}}{Feature selection method used to determine variable -importance for the model.} +\item{\code{vimp_method}}{Method used to determine variable importance for the model.} + +\item{\code{vimp_table}}{Variable importance table or list of variable importance +tables for the model.} + +\item{\code{vimp_aggregation_method}}{Method used for aggregating variable importance +tables if more than one is present.)} + +\item{\code{vimp_rank_threshold}}{Threshold used for some variable importance +aggregation methods.} \item{\code{required_features}}{The set of features required for complete reproduction, i.e. with imputation.} @@ -58,6 +66,11 @@ development cohort.} \item{\code{km_info}}{Data concerning stratification into risk groups.} +\item{\code{data_id}}{Internal identifier for the dataset used to train the model.} + +\item{\code{run_id}}{Internal identifier for the specific subset of the dataset used +used to train the model.} + \item{\code{run_table}}{Run table for the data used to train the model. Used internally.} diff --git a/man/familiarNoveltyDetector-class.Rd b/man/familiarNoveltyDetector-class.Rd index 59b51203..84747bc1 100644 --- a/man/familiarNoveltyDetector-class.Rd +++ b/man/familiarNoveltyDetector-class.Rd @@ -18,8 +18,6 @@ as this not relevant for (prospective) out-of-distribution detection. \describe{ \item{\code{name}}{Name of the familiarNoveltyDetector object.} -\item{\code{learner}}{Learning algorithm used to create the novelty detector.} - \item{\code{model}}{The actual novelty detector trained using a specific algorithm, e.g. a isolation forest from the \code{isotree} package.} @@ -30,16 +28,38 @@ parameters.} \item{\code{data_column_info}}{Data information object containing information regarding identifier column names.} -\item{\code{conversion_parameters}}{Parameters used to convert raw output to -statistical probability of being out-of-distribution. Currently unused.} - \item{\code{hyperparameters}}{Set of hyperparameters used to train the detector.} +\item{\code{hyperparameter_data}}{Information generated during hyperparameter +optimisation. Currently not used.} + +\item{\code{calibration_model}}{Model used to convert raw output to statistical +probability of being out-of-distribution. Currently not used.} + +\item{\code{learner}}{Learning algorithm used to create the novelty detector.} + +\item{\code{vimp_method}}{Method used to determine variable importance for the +novelty detector.} + +\item{\code{vimp_table}}{Variable importance table or list of variable importance +tables for the model.} + +\item{\code{vimp_aggregation_method}}{Method used for aggregating variable importance +tables if more than one is present.)} + +\item{\code{vimp_rank_threshold}}{Threshold used for some variable importance +aggregation methods.} + \item{\code{required_features}}{The set of features required for complete reproduction, i.e. with imputation.} \item{\code{model_features}}{The set of features that is used to train the detector.} +\item{\code{data_id}}{Internal identifier for the dataset used to train the detector.} + +\item{\code{run_id}}{Internal identifier for the specific subset of the dataset used +used to train the detector.} + \item{\code{run_table}}{Run table for the data used to train the detector. Used internally.} @@ -49,6 +69,8 @@ internally.} \item{\code{trimmed_function}}{List of functions whose output has been captured prior to trimming the model.} +\item{\code{messages}}{List of warning and error messages generated during training.} + \item{\code{project_id}}{Identifier of the project that generated the familiarNoveltyDetector object.} diff --git a/man/familiarVimpMethod-class.Rd b/man/familiarVimpMethod-class.Rd index a7495472..678aad80 100644 --- a/man/familiarVimpMethod-class.Rd +++ b/man/familiarVimpMethod-class.Rd @@ -19,6 +19,12 @@ method.} \item{\code{vimp_method}}{The character string indicating the variable importance method.} +\item{\code{vimp_aggregation_method}}{Method used for aggregating variable importance +tables if more than one is present.)} + +\item{\code{vimp_rank_threshold}}{Threshold used for some variable importance +aggregation methods.} + \item{\code{multivariate}}{Flags whether the variable importance method is multivariate vs. univariate.} @@ -40,5 +46,8 @@ importance method. Used internally.} \item{\code{project_id}}{Identifier of the project that generated the familiarVimpMethod object.} + +\item{\code{familiar_version}}{Version of the familiar package used to create this +object.} }} diff --git a/man/featureInfo-class.Rd b/man/featureInfo-class.Rd index 7441c00a..429351a0 100644 --- a/man/featureInfo-class.Rd +++ b/man/featureInfo-class.Rd @@ -91,6 +91,8 @@ features.} \item{\code{required_features}}{Details features required for clustering or imputation.} +\item{\code{project_id}}{Identifier of the project that generated this collection.} + \item{\code{familiar_version}}{Version of the familiar package.} }} diff --git a/man/get_fs_method_names-familiarCollection-method.Rd b/man/get_fs_method_names-familiarCollection-method.Rd deleted file mode 100644 index a27e321e..00000000 --- a/man/get_fs_method_names-familiarCollection-method.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/FamiliarCollection.R -\name{get_fs_method_names,familiarCollection-method} -\alias{get_fs_method_names,familiarCollection-method} -\alias{get_fs_method_names} -\title{Get current feature selection method name labels} -\usage{ -\S4method{get_fs_method_names}{familiarCollection}(x) -} -\arguments{ -\item{x}{A familiarCollection object.} -} -\value{ -An ordered array of feature selection method name labels. -} -\description{ -Feature selection methods in familiarCollection objects can have -custom names for export and plotting. This function retrieves the currently -assigned names. -} -\details{ -Labels convert internal naming of feature selection methods to the -requested label at export or when plotting. Labels can be changed using the -\code{set_fs_method_names} method. -} -\seealso{ -\itemize{ -\item \linkS4class{familiarCollection} for information concerning the familiarCollection class. -\item \code{\link{set_fs_method_names}} for updating the name of feature selection methods and their ordering. -} -} diff --git a/man/get_vimp_method_names-familiarCollection-method.Rd b/man/get_vimp_method_names-familiarCollection-method.Rd new file mode 100644 index 00000000..d775324b --- /dev/null +++ b/man/get_vimp_method_names-familiarCollection-method.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FamiliarCollection.R +\name{get_vimp_method_names,familiarCollection-method} +\alias{get_vimp_method_names,familiarCollection-method} +\alias{get_vimp_method_names} +\title{Get current variable importance method name labels} +\usage{ +\S4method{get_vimp_method_names}{familiarCollection}(x) +} +\arguments{ +\item{x}{A familiarCollection object.} +} +\value{ +An ordered array of variable importance method name labels. +} +\description{ +Variable importance methods in familiarCollection objects can +have custom names for export and plotting. This function retrieves the +currently assigned names. +} +\details{ +Labels convert internal naming of variable importance methods to the +requested label at export or when plotting. Labels can be changed using the +\code{set_vimp_method_names} method. +} +\seealso{ +\itemize{ +\item \linkS4class{familiarCollection} for information concerning the familiarCollection class. +\item \code{\link{set_vimp_method_names}} for updating the name of variable importance methods and their ordering. +} +} diff --git a/man/outcomeInfo-class.Rd b/man/outcomeInfo-class.Rd index 15941980..df4d5b0e 100644 --- a/man/outcomeInfo-class.Rd +++ b/man/outcomeInfo-class.Rd @@ -46,5 +46,8 @@ outcomes. Currently unused.} \item{\code{normalisation_parameters}}{Parameters used for normalising numeric outcomes. Currently unused.} + +\item{\code{familiar_version}}{Version of the familiar package used to create this +object.} }} diff --git a/man/plot_auc_precision_recall_curve-methods.Rd b/man/plot_auc_precision_recall_curve-methods.Rd index 96fb819f..b04e4c1c 100644 --- a/man/plot_auc_precision_recall_curve-methods.Rd +++ b/man/plot_auc_precision_recall_curve-methods.Rd @@ -22,12 +22,12 @@ plot_auc_precision_recall_curve( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -51,12 +51,12 @@ plot_auc_precision_recall_curve( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -80,12 +80,12 @@ plot_auc_precision_recall_curve( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -98,14 +98,19 @@ plot_auc_precision_recall_curve( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} -\item{dir_path}{(\emph{optional}) Path to the directory where the plots of receiver -operating characteristic curves are saved to. Output is saved in the -\code{performance} subdirectory. If \code{NULL} no figures are saved, but are returned -instead.} +\item{dir_path}{(\emph{optional}) Path to the directory where the plots of +receiver operating characteristic curves are saved to. Output is saved in +the \code{performance} subdirectory. If \code{NULL} no figures are saved, but are +returned instead.} \item{split_by}{(\emph{optional}) Splitting variables. This refers to column names on which datasets are split. A separate figure is created for each split. @@ -128,8 +133,15 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to color the different -plot elements in case a value was provided to the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -192,7 +204,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -214,8 +227,8 @@ familiarCollection object. \details{ This function generates area under the precision-recall curve plots. -Available splitting variables are: \code{fs_method}, \code{learner}, \code{data_set} and -\code{positive_class}. By default, the data is split by \code{fs_method} and \code{learner}, +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set} and +\code{positive_class}. By default, the data is split by \code{vimp_method} and \code{learner}, with faceting by \code{data_set} and colouring by \code{positive_class}. Available palettes for \code{discrete_palette} are those listed by @@ -237,7 +250,7 @@ the point estimate of the ROC curve. curve is shown as usual. } -Labelling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_auc_roc_curve-methods.Rd b/man/plot_auc_roc_curve-methods.Rd index 5c2310f0..865c54c1 100644 --- a/man/plot_auc_roc_curve-methods.Rd +++ b/man/plot_auc_roc_curve-methods.Rd @@ -22,12 +22,12 @@ plot_auc_roc_curve( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -51,12 +51,12 @@ plot_auc_roc_curve( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -80,12 +80,12 @@ plot_auc_roc_curve( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -98,14 +98,19 @@ plot_auc_roc_curve( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} -\item{dir_path}{(\emph{optional}) Path to the directory where the plots of receiver -operating characteristic curves are saved to. Output is saved in the -\code{performance} subdirectory. If \code{NULL} no figures are saved, but are returned -instead.} +\item{dir_path}{(\emph{optional}) Path to the directory where the plots of +receiver operating characteristic curves are saved to. Output is saved in +the \code{performance} subdirectory. If \code{NULL} no figures are saved, but are +returned instead.} \item{split_by}{(\emph{optional}) Splitting variables. This refers to column names on which datasets are split. A separate figure is created for each split. @@ -128,8 +133,15 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to color the different -plot elements in case a value was provided to the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -192,7 +204,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -264,7 +277,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -330,17 +347,9 @@ based on data in a familiarCollection object. \details{ This function generates area under the ROC curve plots. -Available splitting variables are: \code{fs_method}, \code{learner}, \code{data_set} and -\code{positive_class}. By default, the data is split by \code{fs_method} and \code{learner}, -with faceting by \code{data_set} and colouring by \code{positive_class}. - -Available palettes for \code{discrete_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set} and +\code{positive_class}. By default, the data is split by \code{vimp_method} and +\code{learner}, with faceting by \code{data_set} and colouring by \code{positive_class}. Bootstrap confidence intervals of the ROC curve (if present) can be shown using various styles set by \code{conf_int_style}: @@ -353,7 +362,7 @@ the point estimate of the ROC curve. curve is shown as usual. } -Labelling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_calibration_data-methods.Rd b/man/plot_calibration_data-methods.Rd index 5a28997c..6b234589 100644 --- a/man/plot_calibration_data-methods.Rd +++ b/man/plot_calibration_data-methods.Rd @@ -25,13 +25,13 @@ plot_calibration_data( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_density = TRUE, show_calibration_fit = TRUE, show_goodness_of_fit = TRUE, @@ -62,13 +62,13 @@ plot_calibration_data( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_density = TRUE, show_calibration_fit = TRUE, show_goodness_of_fit = TRUE, @@ -99,13 +99,13 @@ plot_calibration_data( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_density = TRUE, show_calibration_fit = TRUE, show_goodness_of_fit = TRUE, @@ -122,7 +122,12 @@ plot_calibration_data( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -151,9 +156,15 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to color the different -data points and fit lines in case a non-singular variable was provided to -the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -258,7 +269,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -275,8 +287,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -335,7 +347,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -405,10 +421,10 @@ This function generates a calibration plot for each model in each dataset. Any data used for calibration (e.g. baseline survival) is obtained during model creation. -Available splitting variables are: \code{fs_method}, \code{learner}, \code{data_set} and +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set} and \code{evaluation_time} (survival analysis only) and \code{positive_class} (multinomial endpoints only). By default, separate figures are created for each -combination of \code{fs_method} and \code{learner}, with facetting by \code{data_set}. +combination of \code{vimp_method} and \code{learner}, with facetting by \code{data_set}. Calibration in survival analysis is performed at set time points so that survival probabilities can be computed from the model, and compared with @@ -441,15 +457,7 @@ Greenwood-Nam-D'Agostino (GND) tests are shown. Note that this information is only annotated when \code{color_by} is not used as a splitting variable (i.e. one calibration plot per facet). -Available palettes for \code{discrete_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. - -Labeling methods such as \code{set_risk_group_names} or \code{set_data_set_names} can +Labelling methods such as \code{set_risk_group_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_confusion_matrix-methods.Rd b/man/plot_confusion_matrix-methods.Rd index ce36c4e3..dad5d2b0 100644 --- a/man/plot_confusion_matrix-methods.Rd +++ b/man/plot_confusion_matrix-methods.Rd @@ -83,7 +83,12 @@ plot_confusion_matrix( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -107,9 +112,16 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette used to colour the confusion -matrix. The colour depends on whether each cell of the confusion matrix is -on the diagonal (observed outcome matched expected outcome) or not.} +\item{discrete_palette}{(\emph{optional}) Palette Palette for colouring the cells +of the confusion matrix. The colour depends on whether each cell of the +confusion matrix is on the diagonal (observed outcome matched expected +outcome) or not. \code{familiar} has a default palette. Other palettes are +supported by the \code{paletteer} package, \code{grDevices::palette.pals()} (requires +R >= 4.0.0), \code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, +\code{heat.colors}, \code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which +correspond to the palettes of the same name in \code{grDevices}. You may also +specify your own palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -176,7 +188,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -248,7 +261,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} }} } \value{ @@ -261,19 +278,11 @@ familiarCollection object. \details{ This function generates area under the ROC curve plots. -Available splitting variables are: \code{fs_method}, \code{learner} and \code{data_set}. -By default, the data is split by \code{fs_method} and \code{learner}, with facetting +Available splitting variables are: \code{vimp_method}, \code{learner} and \code{data_set}. +By default, the data is split by \code{vimp_method} and \code{learner}, with facetting by \code{data_set}. -Available palettes for \code{discrete_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. - -Labeling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_decision_curve-methods.Rd b/man/plot_decision_curve-methods.Rd index 11e8989c..2ca03e0d 100644 --- a/man/plot_decision_curve-methods.Rd +++ b/man/plot_decision_curve-methods.Rd @@ -23,13 +23,13 @@ plot_decision_curve( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -54,13 +54,13 @@ plot_decision_curve( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -85,13 +85,13 @@ plot_decision_curve( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -104,7 +104,12 @@ plot_decision_curve( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -134,8 +139,15 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to color the different -plot elements in case a value was provided to the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -202,7 +214,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -219,8 +232,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -279,7 +292,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -345,20 +362,12 @@ familiarCollection object. \details{ This function generates plots for decision curves. -Available splitting variables are: \code{fs_method}, \code{learner}, \code{data_set} and +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set} and \code{positive_class} (categorical outcomes) or \code{evaluation_time} (survival -outcomes). By default, the data is split by \code{fs_method} and \code{learner}, with +outcomes). By default, the data is split by \code{vimp_method} and \code{learner}, with faceting by \code{data_set} and colouring by \code{positive_class} or \code{evaluation_time}. -Available palettes for \code{discrete_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. - Bootstrap confidence intervals of the decision curve (if present) can be shown using various styles set by \code{conf_int_style}: \itemize{ @@ -371,7 +380,7 @@ the point estimate of the decision curve. decision curve is shown as usual. } -Labelling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_feature_similarity-methods.Rd b/man/plot_feature_similarity-methods.Rd index a6886d77..2e72e990 100644 --- a/man/plot_feature_similarity-methods.Rd +++ b/man/plot_feature_similarity-methods.Rd @@ -29,7 +29,7 @@ plot_feature_similarity( plot_sub_title = waiver(), caption = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_dendrogram = c("top", "right"), @@ -64,7 +64,7 @@ plot_feature_similarity( plot_sub_title = waiver(), caption = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_dendrogram = c("top", "right"), @@ -99,7 +99,7 @@ plot_feature_similarity( plot_sub_title = waiver(), caption = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_dendrogram = c("top", "right"), @@ -176,7 +176,14 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} \item{gradient_palette}{(\emph{optional}) Sequential or divergent palette used to -colour the similarity or distance between features in a heatmap.} +colour the similarity or distance between features in a heatmap. +\code{familiar} has a default palette. Other palettes are supported by the +\code{paletteer} package, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette_range}{(\emph{optional}) Numerical range used to span the gradient. This should be a range of two values, e.g. \code{c(0, 1)}. Lower or @@ -275,7 +282,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -370,23 +378,18 @@ more similar features appear together. \details{ This function generates area under the ROC curve plots. -Available splitting variables are: \code{fs_method}, \code{learner}, and \code{data_set}. -By default, the data is split by \code{fs_method} and \code{learner}, with facetting -by \code{data_set}. +Available splitting variables are: \code{vimp_method}, \code{learner}, and \code{data_set}. +By default, the data is split by \code{vimp_method}, \code{learner} and \code{data_set}, +since the features may be ordered differently for each data set. Note that similarity is determined based on the underlying data. Hence the ordering of features may differ between facets, and tick labels are maintained for each panel. -Available palettes for \code{gradient_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. - -Labeling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labeling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. + +This plot can be created from \code{dataObject}, or \code{data.table} objects. +For \code{data.table}, see \code{\link{as_data_object}} for additional arguments. } diff --git a/man/plot_ice-methods.Rd b/man/plot_ice-methods.Rd index c232bad8..77abff6a 100644 --- a/man/plot_ice-methods.Rd +++ b/man/plot_ice-methods.Rd @@ -21,20 +21,20 @@ plot_ice( x_label = waiver(), y_label = waiver(), legend_label = waiver(), - plot_title = NULL, - plot_sub_title = NULL, + plot_title = waiver(), + plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, ice_default_alpha = 0.6, n_max_samples_shown = 50L, show_ice = TRUE, @@ -63,20 +63,20 @@ plot_ice( x_label = waiver(), y_label = waiver(), legend_label = waiver(), - plot_title = NULL, - plot_sub_title = NULL, + plot_title = waiver(), + plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, ice_default_alpha = 0.6, n_max_samples_shown = 50L, show_ice = TRUE, @@ -109,16 +109,16 @@ plot_ice( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, ice_default_alpha = 0.6, n_max_samples_shown = 50L, show_ice = TRUE, @@ -137,7 +137,12 @@ plot_ice( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -167,14 +172,28 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to colour the different -plot elements in case a value was provided to the \code{color_by} argument. For -2D individual conditional expectation plots without novelty, the initial -colour determines the colour of the points indicating sample values.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring plot elements +indicated by the \code{color_by} argument (if any). For 2D individual +conditional expectation plots without novelty, the initial colour +determines the colour of the points indicating sample values. \code{familiar} +has a default palette. Other palettes are supported by the \code{paletteer} +package, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette}{(\emph{optional}) Sequential or divergent palette used to colour the raster in 2D individual conditional expectation or partial -dependence plots. This argument is not used for 1D plots.} +dependence plots. This argument is not used for 1D plots. \code{familiar} has a +default palette. Other palettes are supported by the \code{paletteer} package, +\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} +(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, +\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same +name in \code{grDevices}. You may also specify your own palette by providing a +vector of colour names listed by \code{grDevices::colors()} or through +hexadecimal RGB strings.} \item{gradient_palette_range}{(\emph{optional}) Numerical range used to span the gradient for 2D plots. This should be a range of two values, e.g. \code{c(0, 1)}. By default, values are determined from the data, dependent on the @@ -301,7 +320,8 @@ aggregated for export.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -330,8 +350,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -348,14 +368,23 @@ computation and extraction of various data elements.} \item{\code{message_indent}}{Number of indentation steps for messages shown during computation and extraction of various data elements.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -399,7 +428,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -453,29 +486,18 @@ predicted value as function of a single feature, whereas 2D plots show the predicted value as a function of two features. Available splitting variables are: \code{feature_x}, \code{feature_y} (2D only), -\code{fs_method}, \code{learner}, \code{data_set} and \code{positive_class} (categorical +\code{vimp_method}, \code{learner}, \code{data_set} and \code{positive_class} (categorical outcomes) or \code{evaluation_time} (survival outcomes). By default, for 1D ICE -plots the data are split by \code{feature_x}, \code{fs_method} and \code{learner}, with +plots the data are split by \code{feature_x}, \code{vimp_method} and \code{learner}, with faceting by \code{data_set}, \code{positive_class} or \code{evaluation_time}. If only partial dependence is shown, \code{positive_class} and \code{evaluation_time} are used to set colours instead. For 2D plots, by default the data are split by -\code{feature_x}, \code{fs_method} and \code{learner}, with faceting by \code{data_set}, +\code{feature_x}, \code{vimp_method} and \code{learner}, with faceting by \code{data_set}, \code{positive_class} or \code{evaluation_time}. The \code{color_by} argument cannot be used with 2D plots, and attempting to do so causes an error. Attempting to specify \code{feature_x} or \code{feature_y} for \code{color_by} will likewise result in an error, as multiple features cannot be shown in the same facet. -The splitting variables indicated by \code{color_by} are coloured according to -the \code{discrete_palette} parameter. This parameter is therefore only used for -1D plots. Available palettes for \code{discrete_palette} and \code{gradient_palette} -are those listed by \code{grDevices::palette.pals()} (requires R >= 4.0.0), -\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, -\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the -palettes of the same name in \code{grDevices}. If not specified, a default -palette based on palettes in Tableau are used. You may also specify your -own palette by using colour names listed by \code{grDevices::colors()} or -through hexadecimal RGB strings. - Bootstrap confidence intervals of the partial dependence plots can be shown using various styles set by \code{conf_int_style}: \itemize{ @@ -493,7 +515,7 @@ computed for individual samples in individual conditional expectation plots. To avoid clutter, only point estimates for individual samples are shown. -Labelling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_kaplan_meier-methods.Rd b/man/plot_kaplan_meier-methods.Rd index a9558f7a..d38f39ae 100644 --- a/man/plot_kaplan_meier-methods.Rd +++ b/man/plot_kaplan_meier-methods.Rd @@ -27,14 +27,14 @@ plot_kaplan_meier( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = c(0, 1), - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, confidence_level = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, censoring = TRUE, censor_shape = "plus", show_logrank = TRUE, @@ -67,14 +67,14 @@ plot_kaplan_meier( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = c(0, 1), - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, confidence_level = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, censoring = TRUE, censor_shape = "plus", show_logrank = TRUE, @@ -107,14 +107,14 @@ plot_kaplan_meier( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = c(0, 1), - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, confidence_level = NULL, conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, censoring = TRUE, censor_shape = "plus", show_logrank = TRUE, @@ -131,7 +131,12 @@ plot_kaplan_meier( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -169,9 +174,15 @@ is to be shared by multiple aesthetics, such as those specified by \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to color the different -risk strata in case a non-singular variable was provided to the \code{color_by} -argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -250,7 +261,7 @@ vignette \emph{Aesthetic specifications}. By default a plus shape is used.} \item{show_logrank}{(\emph{optional}) Specifies whether the results of a logrank test to assess differences between the risk strata is annotated in the plot. A log-rank test can only be shown when \code{color_by} and \code{linestyle_by} -are either unset, or only contain \code{risk_group}.} +are either unset, or only contain \code{group}.} \item{show_survival_table}{(\emph{optional}) Specifies whether a survival table is shown below the Kaplan-Meier survival curves. Survival in the risk strata @@ -279,7 +290,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -351,7 +363,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} }} } \value{ @@ -369,19 +385,11 @@ group stratification by the learners. survival the y-axis represents. It is therefore recommended to provide \code{x_label} and \code{y_label} arguments. -Available splitting variables are: \code{fs_method}, \code{learner}, \code{data_set}, -\code{risk_group} and \code{stratification_method}. By default, separate figures are -created for each combination of \code{fs_method} and \code{learner}, with faceting by +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set}, +\code{group} and \code{stratification_method}. By default, separate figures are +created for each combination of \code{vimp_method} and \code{learner}, with faceting by \code{data_set}, colouring of the strata in each individual plot by -\code{risk_group}. - -Available palettes for \code{discrete_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. +\code{group}. Greenwood confidence intervals of the Kaplan-Meier curve can be shown using various styles set by \code{conf_int_style}: diff --git a/man/plot_model_performance-methods.Rd b/man/plot_model_performance-methods.Rd index 71513beb..5c982499 100644 --- a/man/plot_model_performance-methods.Rd +++ b/man/plot_model_performance-methods.Rd @@ -29,7 +29,7 @@ plot_model_performance( caption = NULL, rotate_x_tick_labels = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), @@ -62,7 +62,7 @@ plot_model_performance( caption = NULL, rotate_x_tick_labels = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), @@ -95,7 +95,7 @@ plot_model_performance( caption = NULL, rotate_x_tick_labels = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), @@ -110,7 +110,12 @@ plot_model_performance( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -159,13 +164,25 @@ is not used for \code{heatmap} and \code{y_axis_by} is only used by \code{heatma \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to color the different -plot elements in case a value was provided to the \code{color_by} argument. Only -used when \code{plot_type} is not \code{heatmap}.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring plot elements +indicated by the \code{color_by} argument (if any). Only used if \code{plot_type} is +not \code{heatmap}. \code{familiar} has a default palette. Other palettes are +supported by the \code{paletteer} package, \code{grDevices::palette.pals()} (requires +R >= 4.0.0), \code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, +\code{heat.colors}, \code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which +correspond to the palettes of the same name in \code{grDevices}. You may also +specify your own palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette}{(\emph{optional}) Sequential or divergent palette used to color the raster in \code{heatmap} plots. This argument is not used for other -\code{plot_type} value.} +\code{plot_type} value. \code{familiar} has a default palette. Other palettes are +supported by the \code{paletteer} package, \code{grDevices::palette.pals()} (requires +R >= 4.0.0), \code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, +\code{heat.colors}, \code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which +correspond to the palettes of the same name in \code{grDevices}. You may also +specify your own palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette_range}{(\emph{optional}) Numerical range used to span the gradient. This should be a range of two values, e.g. \code{c(0, 1)}. Lower or @@ -228,8 +245,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -292,7 +309,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -355,7 +376,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -379,12 +401,12 @@ types of plots, as determined by \code{plot_type}. This function plots model performance based on empirical bootstraps, using various plot representations. -Available splitting variables are: \code{fs_method}, \code{learner}, \code{data_set}, +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set}, \code{evaluation_time} (survival outcome only) and \code{metric}. The default for \code{heatmap} is to split by \code{metric}, facet by \code{data_set} and -\code{evaluation_time}, position \code{learner} along the x-axis and \code{fs_method} +\code{evaluation_time}, position \code{learner} along the x-axis and \code{vimp_method} along the y-axis. The \code{color_by} argument is not used. The only valid -options for \code{x_axis_by} and \code{y_axis_by} are \code{learner} and \code{fs_method}. +options for \code{x_axis_by} and \code{y_axis_by} are \code{learner} and \code{vimp_method}. For other plot types (\code{barplot}, \code{boxplot} and \code{violinplot}), depends on the number of learners and feature selection methods: @@ -394,25 +416,16 @@ the number of learners and feature selection methods: \item \emph{one feature selection and multiple learners}: the default is to split by \code{metric}, facet by \code{data_set} and have \code{learner} along the x-axis. \item \emph{multiple feature selection methods and one learner}: the default is to -split by \code{metric}, facet by \code{data_set} and have \code{fs_method} along the +split by \code{metric}, facet by \code{data_set} and have \code{vimp_method} along the x-axis. \item \emph{multiple feature selection methods and learners}: the default is to split -by \code{metric}, facet by \code{data_set}, colour by \code{fs_method} and have \code{learner} +by \code{metric}, facet by \code{data_set}, colour by \code{vimp_method} and have \code{learner} along the x-axis. } If applicable, additional faceting is performed for \code{evaluation_time}. -Available palettes for \code{discrete_palette} and \code{gradient_palette} are those -listed by \code{grDevices::palette.pals()} (requires R >= 4.0.0), -\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, -\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the -palettes of the same name in \code{grDevices}. If not specified, a default -palette based on palettes in Tableau are used. You may also specify your -own palette by using colour names listed by \code{grDevices::colors()} or -through hexadecimal RGB strings. - -Labeling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labeling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_pd-methods.Rd b/man/plot_pd-methods.Rd index a1301a80..0fcd6b95 100644 --- a/man/plot_pd-methods.Rd +++ b/man/plot_pd-methods.Rd @@ -24,16 +24,16 @@ plot_pd( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_novelty = TRUE, anchor_values = NULL, width = waiver(), @@ -62,16 +62,16 @@ plot_pd( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, novelty_range = NULL, value_scales = waiver(), novelty_scales = waiver(), conf_int_style = c("ribbon", "step", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, show_novelty = TRUE, anchor_values = NULL, width = waiver(), @@ -86,7 +86,12 @@ plot_pd( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -116,14 +121,28 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use to colour the different -plot elements in case a value was provided to the \code{color_by} argument. For -2D individual conditional expectation plots without novelty, the initial -colour determines the colour of the points indicating sample values.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring plot elements +indicated by the \code{color_by} argument (if any). For 2D individual +conditional expectation plots without novelty, the initial colour +determines the colour of the points indicating sample values. \code{familiar} +has a default palette. Other palettes are supported by the \code{paletteer} +package, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette}{(\emph{optional}) Sequential or divergent palette used to colour the raster in 2D individual conditional expectation or partial -dependence plots. This argument is not used for 1D plots.} +dependence plots. This argument is not used for 1D plots. \code{familiar} has a +default palette. Other palettes are supported by the \code{paletteer} package, +\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} +(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, +\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same +name in \code{grDevices}. You may also specify your own palette by providing a +vector of colour names listed by \code{grDevices::colors()} or through +hexadecimal RGB strings.} \item{gradient_palette_range}{(\emph{optional}) Numerical range used to span the gradient for 2D plots. This should be a range of two values, e.g. \code{c(0, 1)}. By default, values are determined from the data, dependent on the @@ -232,7 +251,8 @@ aggregated for export.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -261,8 +281,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -279,14 +299,23 @@ computation and extraction of various data elements.} \item{\code{message_indent}}{Number of indentation steps for messages shown during computation and extraction of various data elements.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -330,7 +359,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -384,13 +417,13 @@ function of a single feature, whereas 2D plots show the predicted value as a function of two features. Available splitting variables are: \code{feature_x}, \code{feature_y} (2D only), -\code{fs_method}, \code{learner}, \code{data_set} and \code{positive_class} (categorical +\code{vimp_method}, \code{learner}, \code{data_set} and \code{positive_class} (categorical outcomes) or \code{evaluation_time} (survival outcomes). By default, for 1D ICE -plots the data are split by \code{feature_x}, \code{fs_method} and \code{learner}, with +plots the data are split by \code{feature_x}, \code{vimp_method} and \code{learner}, with faceting by \code{data_set}, \code{positive_class} or \code{evaluation_time}. If only partial dependence is shown, \code{positive_class} and \code{evaluation_time} are used to set colours instead. For 2D plots, by default the data are split by -\code{feature_x}, \code{fs_method} and \code{learner}, with faceting by \code{data_set}, +\code{feature_x}, \code{vimp_method} and \code{learner}, with faceting by \code{data_set}, \code{positive_class} or \code{evaluation_time}. The \code{color_by} argument cannot be used with 2D plots, and attempting to do so causes an error. Attempting to specify \code{feature_x} or \code{feature_y} for \code{color_by} will likewise result in @@ -419,7 +452,7 @@ the point estimate of the partial dependence. partial dependence is shown as usual. } -Labelling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_permutation_variable_importance-methods.Rd b/man/plot_permutation_variable_importance-methods.Rd index a9bec8b7..84d5cc0d 100644 --- a/man/plot_permutation_variable_importance-methods.Rd +++ b/man/plot_permutation_variable_importance-methods.Rd @@ -22,11 +22,12 @@ plot_permutation_variable_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, conf_int_style = c("point_line", "line", "bar_line", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -50,11 +51,12 @@ plot_permutation_variable_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, conf_int_style = c("point_line", "line", "bar_line", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -78,11 +80,12 @@ plot_permutation_variable_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, conf_int_style = c("point_line", "line", "bar_line", "none"), - conf_int_alpha = 0.4, + conf_int_alpha = 0.2, width = waiver(), height = waiver(), units = waiver(), @@ -95,7 +98,12 @@ plot_permutation_variable_importance( objects, that will be internally converted to a \code{familiarCollection} object. It is also possible to provide a \code{familiarEnsemble} or one or more \code{familiarModel} objects together with the data from which data is computed -prior to export. Paths to such files can also be provided.} +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -124,8 +132,15 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette used to fill the bars in case a -non-singular variable was provided to the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -145,6 +160,10 @@ NULL, no subtitle is shown.} \item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no caption is shown.} +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + \item{x_range}{(\emph{optional}) Value range for the x-axis.} \item{x_n_breaks}{(\emph{optional}) Number of breaks to show on the x-axis of the @@ -184,7 +203,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -201,8 +221,8 @@ pre-processed externally, e.g. normalised and clustered. Only used if the \code{data} argument is a \code{data.table} or \code{data.frame}.} \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallellisation.} - \item{\code{evaluation_times}}{One or more time points that are used for in analysis of -survival problems when data has to be assessed at a set time, e.g. + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. calibration. If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects. Only used for \code{survival} outcomes.} @@ -264,6 +284,24 @@ creation of the underlying \code{familiarModel} objects.} computation and extraction of various data elements.} \item{\code{message_indent}}{Number of indentation steps for messages shown during computation and extraction of various data elements.} + \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples +that are used during evaluation steps. Cannot be fewer than 20. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("sample_similarity"=100, "permutation_vimp"=1000)}. + +This parameter can be set for the following data elements: +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -307,7 +345,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -378,7 +420,7 @@ feature is randomly permuted. The following splitting variables are available for \code{split_by}, \code{color_by} and \code{facet_by}: \itemize{ -\item \code{fs_method}: feature selection methods. +\item \code{vimp_method}: variable importance methods. \item \code{learner}: learners. \item \code{data_set}: data sets. \item \code{metric}: the model performance metrics. @@ -387,19 +429,11 @@ and \code{facet_by}: of features to permute simultaneously. } -By default, the data is split by \code{fs_method}, \code{learner} and \code{metric}, +By default, the data is split by \code{vimp_method}, \code{learner} and \code{metric}, faceted by \code{data_set} and \code{evaluation_time}, and coloured by \code{similarity_threshold}. -Available palettes for \code{discrete_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. - -Labelling methods such as \code{set_fs_method_names} or \code{set_feature_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_feature_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. diff --git a/man/plot_sample_clustering-methods.Rd b/man/plot_sample_clustering-methods.Rd index 7d8f1a1f..d4d0b698 100644 --- a/man/plot_sample_clustering-methods.Rd +++ b/man/plot_sample_clustering-methods.Rd @@ -35,10 +35,10 @@ plot_sample_clustering( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 3, + x_n_breaks = 3L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_feature_dendrogram = TRUE, @@ -85,10 +85,10 @@ plot_sample_clustering( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 3, + x_n_breaks = 3L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_feature_dendrogram = TRUE, @@ -135,10 +135,10 @@ plot_sample_clustering( plot_sub_title = waiver(), caption = NULL, x_range = NULL, - x_n_breaks = 3, + x_n_breaks = 3L, x_breaks = NULL, y_range = NULL, - y_n_breaks = 3, + y_n_breaks = 3L, y_breaks = NULL, rotate_x_tick_labels = waiver(), show_feature_dendrogram = TRUE, @@ -197,14 +197,14 @@ If not provided explicitly, this parameter is read from settings used at creation of the underlying \code{familiarModel} objects.} \item{sample_limit}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} \item{draw}{(\emph{optional}) Draws the plot if TRUE.} @@ -241,20 +241,27 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} \item{gradient_palette}{(\emph{optional}) Sequential or divergent palette used to -colour the similarity or distance between features in a heatmap.} +colour the similarity or distance between features in a heatmap. \code{familiar} +has a default palette. Other palettes are supported by the \code{paletteer} +package, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette_range}{(\emph{optional}) Numerical range used to span the gradient. This should be a range of two values, e.g. \code{c(0, 1)}. Lower or upper boundary can be unset by using \code{NA}. If not set, the full metric-specific range is used.} -\item{outcome_palette}{(\emph{optional}) Sequential (\code{continuous}, \code{count} -outcomes) or qualitative (other outcome types) palette used to show outcome -values. This argument is ignored if the outcome is not shown.} +\item{outcome_palette}{(\emph{optional}) Sequential (\code{continuous} outcomes) or +qualitative (other outcome types) palette used to show outcome values. This +argument is ignored if the outcome is not shown.} \item{outcome_palette_range}{(\emph{optional}) Numerical range used to span the -gradient of numeric (\code{continuous}, \code{count}) outcome values. This argument -is ignored for other outcome types or if the outcome is not shown.} +gradient of numeric (\code{continuous}) outcome values. This argument is ignored +for other outcome types or if the outcome is not shown.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -290,7 +297,7 @@ legend will not have a name.} \item{outcome_legend_label}{(\emph{optional}) Label to provide to the legend for outcome data. If NULL, the legend will not have a name. By default, \code{class}, \code{value} and \code{event} are used for \code{binomial} and \code{multinomial}, -\code{continuous} and \code{count}, and \code{survival} outcome types, respectively.} +\code{continuous}, and \code{survival} outcome types, respectively.} \item{plot_title}{(\emph{optional}) Label to provide as figure title. If NULL, no title is shown.} @@ -416,7 +423,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -470,10 +478,10 @@ more similar features appear together. \details{ This function generates area under the ROC curve plots. -Available splitting variables are: \code{fs_method}, \code{learner}, and \code{data_set}. -By default, the data is split by \code{fs_method} and \code{learner} and \code{data_set}, +Available splitting variables are: \code{vimp_method}, \code{learner}, and \code{data_set}. +By default, the data is split by \code{vimp_method} and \code{learner} and \code{data_set}, since the number of samples will typically differ between data sets, even -for the same feature selection method and learner. +for the same variable importance method and learner. The \code{x_axis_by} and \code{y_axis_by} arguments determine what data are shown along which axis. Each argument takes one of \code{feature} and \code{sample}, and @@ -484,15 +492,10 @@ Note that similarity is determined based on the underlying data. Hence the ordering of features may differ between facets, and tick labels are maintained for each panel. -Available palettes for \code{gradient_palette} are those listed by -\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} -(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, -\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same -name in \code{grDevices}. If not specified, a default palette based on palettes -in Tableau are used. You may also specify your own palette by using colour -names listed by \code{grDevices::colors()} or through hexadecimal RGB strings. - -Labeling methods such as \code{set_fs_method_names} or \code{set_data_set_names} can +Labeling methods such as \code{set_vimp_method_names} or \code{set_data_set_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. + +This plot can be created from \code{dataObject}, or \code{data.table} objects. +For \code{data.table}, see \code{\link{as_data_object}} for additional arguments. } diff --git a/man/plot_shap_dependence-methods.Rd b/man/plot_shap_dependence-methods.Rd new file mode 100644 index 00000000..b76eeb37 --- /dev/null +++ b/man/plot_shap_dependence-methods.Rd @@ -0,0 +1,388 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotShapDependence.R +\name{plot_shap_dependence} +\alias{plot_shap_dependence} +\alias{plot_shap_dependence,ANY-method} +\alias{plot_shap_dependence,familiarCollection-method} +\title{Create SHAP dependence plot.} +\usage{ +plot_shap_dependence( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + shap_feature = NULL, + interaction_feature = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_dependence}{ANY}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + shap_feature = NULL, + interaction_feature = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_dependence}{familiarCollection}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + shap_feature = NULL, + interaction_feature = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) +} +\arguments{ +\item{object}{\code{familiarCollection} object, or one or more \code{familiarData} +objects, that will be internally converted to a \code{familiarCollection} +object. It is also possible to provide a \code{familiarEnsemble} or one or more +\code{familiarModel} objects together with the data from which data is computed +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} + +\item{draw}{(\emph{optional}) Draws the plot if TRUE.} + +\item{dir_path}{(\emph{optional}) Path to the directory where created SHAP +dependence plots are saved to. Output is saved in the \code{explanation} +subdirectory. If \code{NULL} no figures are saved, but are returned instead.} + +\item{split_by}{(\emph{optional}) Splitting variables. This refers to column names +on which datasets are split. A separate figure is created for each split. +See details for available variables.} + +\item{facet_by}{(\emph{optional}) Variables used to determine how and if facets of +each figure appear. In case the \code{facet_wrap_cols} argument is \code{NULL}, the +first variable is used to define columns, and the remaing variables are +used to define rows of facets. The variables cannot overlap with those +provided to the \code{split_by} argument, but may overlap with other arguments. +See details for available variables.} + +\item{facet_wrap_cols}{(\emph{optional}) Number of columns to generate when facet +wrapping. If NULL, a facet grid is produced instead.} + +\item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} + +\item{discrete_palette}{(\emph{optional}) Divergent or sequential palette used to +colour the elements of dependence plots for interactions with another +\strong{categorical} feature. \code{familiar} has a default palette. Other palettes +are supported by the \code{paletteer} package, \code{grDevices::palette.pals()} +(requires R >= 4.0.0), \code{grDevices::hcl.pals()} (requires R >= 3.6.0) and +\code{rainbow}, \code{heat.colors}, \code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, +which correspond to the palettes of the same name in \code{grDevices}. You may +also specify your own palette by providing a vector of colour names listed +by \code{grDevices::colors()} or through hexadecimal RGB strings. + +If no \code{interaction_feature} is set, or is a numerical feature, the gradient +palette is not used.} + +\item{gradient_palette}{(\emph{optional}) Divergent or sequential palette used to +colour the elements of dependence plots for interactions with another +\strong{numeric} feature. \code{familiar} has a default palette. Other palettes are +supported by the \code{paletteer} package, \code{grDevices::palette.pals()} (requires +R >= 4.0.0), \code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, +\code{heat.colors}, \code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which +correspond to the palettes of the same name in \code{grDevices}. You may also +specify your own palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings. + +If no \code{interaction_feature} is set, or is a categorical feature, the +gradient palette is not used.} + +\item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label +is shown.} + +\item{y_label}{(\emph{optional}) Label to provide to the y-axis. If NULL, no label +is shown.} + +\item{legend_label}{(\emph{optional}) Label to provide to the legend. If NULL, the +legend will not have a name.} + +\item{plot_title}{(\emph{optional}) Label to provide as figure title. If NULL, no +title is shown.} + +\item{plot_sub_title}{(\emph{optional}) Label to provide as figure subtitle. If +NULL, no subtitle is shown.} + +\item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no +caption is shown.} + +\item{x_range}{(\emph{optional}) Value range for the x-axis.} + +\item{x_n_breaks}{(\emph{optional}) Number of breaks to show on the x-axis of the +plot. \code{x_n_breaks} is used to determine the \code{x_breaks} argument in case it +is unset.} + +\item{x_breaks}{(\emph{optional}) Break points on the x-axis of the plot.} + +\item{y_range}{(\emph{optional}) Value range for the y-axis.} + +\item{y_n_breaks}{(\emph{optional}) Number of breaks to show on the y-axis of the +plot. \code{y_n_breaks} is used to determine the \code{y_breaks} argument in case it +is unset.} + +\item{y_breaks}{(\emph{optional}) Break points on the y-axis of the plot.} + +\item{shap_feature}{(\emph{optional}) Feature(s) whose SHAP values are used for +creating the SHAP dependence plot.} + +\item{interaction_feature}{(\emph{optional}) Feature(s) whose values are used to +colour points of the \code{shap_feature}.} + +\item{width}{(\emph{optional}) Width of the plot. A default value is derived from +the number of facets.} + +\item{height}{(\emph{optional}) Height of the plot. A default value is derived +from the number of features and the number of facets.} + +\item{units}{(\emph{optional}) Plot size unit. Either \code{cm} (default), \code{mm} or +\verb{in}.} + +\item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} + +\item{...}{ + Arguments passed on to \code{\link[=extract_performance]{extract_performance}}, \code{\link[=as_familiar_collection]{as_familiar_collection}}, \code{\link[ggplot2:ggsave]{ggplot2::ggsave}} + \describe{ + \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that +constitutes the data that are assessed.} + \item{\code{is_pre_processed}}{Flag that indicates whether the data was already +pre-processed externally, e.g. normalised and clustered. Only used if the +\code{data} argument is a \code{data.table} or \code{data.frame}.} + \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then +used to speed up computation through parallellisation.} + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. +calibration. If not provided explicitly, this parameter is read from +settings used at creation of the underlying \code{familiarModel} objects. Only +used for \code{survival} outcomes.} + \item{\code{ensemble_method}}{Method for ensembling predictions from models for the +same sample. Available methods are: +\itemize{ +\item \code{median} (default): Use the median of the predicted values as the ensemble +value for a sample. +\item \code{mean}: Use the mean of the predicted values as the ensemble value for a +sample. +}} + \item{\code{metric}}{One or more metrics for assessing model performance. See the +vignette on performance metrics for the available metrics. If not provided +explicitly, this parameter is read from settings used at creation of the +underlying \code{familiarModel} objects.} + \item{\code{verbose}}{Flag to indicate whether feedback should be provided on the +computation and extraction of various data elements.} + \item{\code{message_indent}}{Number of indentation steps for messages shown during +computation and extraction of various data elements.} + \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed +and aggregated. +\itemize{ +\item \code{ensemble}: Results are computed at the ensemble level, i.e. over all +models in the ensemble. This means that, for example, bias-corrected +estimates of model performance are assessed by creating (at least) 20 +bootstraps and computing the model performance of the ensemble model for +each bootstrap. +\item \code{hybrid} (default): Results are computed at the level of models in an +ensemble. This means that, for example, bias-corrected estimates of model +performance are directly computed using the models in the ensemble. If there +are at least 20 trained models in the ensemble, performance is computed for +each model, in contrast to \code{ensemble} where performance is computed for the +ensemble of models. If there are less than 20 trained models in the +ensemble, bootstraps are created so that at least 20 point estimates can be +made. +\item \code{model}: Results are computed at the model level. This means that, for +example, bias-corrected estimates of model performance are assessed by +creating (at least) 20 bootstraps and computing the performance of the model +for each bootstrap. +} + +Note that each level of detail has a different interpretation for bootstrap +confidence intervals. For \code{ensemble} and \code{model} these are the confidence +intervals for the ensemble and an individual model, respectively. That is, +the confidence interval describes the range where an estimate produced by a +respective ensemble or model trained on a repeat of the experiment may be +found with the probability of the confidence level. For \code{hybrid}, it +represents the range where any single model trained on a repeat of the +experiment may be found with the probability of the confidence level. By +definition, confidence intervals obtained using \code{hybrid} are at least as +wide as those for \code{ensemble}. \code{hybrid} offers the correct interpretation if +the goal of the analysis is to assess the result of a single, unspecified, +model. + +\code{hybrid} is generally computationally less expensive then \code{ensemble}, which +in turn is somewhat less expensive than \code{model}. + +A non-default \code{detail_level} parameter can be specified for separate +evaluation steps by providing a parameter value in a named list with data +elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. +This parameter can be set for the following data elements: \code{auc_data}, +\code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} + \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be +possible. This has the following options: +\itemize{ +\item \code{point}: Point estimates. +\item \code{bias_correction} or \code{bc}: Bias-corrected estimates. A bias-corrected +estimate is computed from (at least) 20 point estimates, and \code{familiar} may +bootstrap the data to create them. +\item \code{bootstrap_confidence_interval} or \code{bci} (default): Bias-corrected +estimates with bootstrap confidence intervals (Efron and Hastie, 2016). The +number of point estimates required depends on the \code{confidence_level} +parameter, and \code{familiar} may bootstrap the data to create them. +} + +As with \code{detail_level}, a non-default \code{estimation_type} parameter can be +specified for separate evaluation steps by providing a parameter value in a +named list with data elements, e.g. \code{list("auc_data"="bci", "model_performance"="point")}. This parameter can be set for the following +data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, +\code{permutation_vimp}, \code{ice_data}, and \code{prediction_data}.} + \item{\code{aggregate_results}}{(\emph{optional}) Flag that signifies whether results +should be aggregated during evaluation. If \code{estimation_type} is +\code{bias_correction} or \code{bc}, aggregation leads to a single bias-corrected +estimate. If \code{estimation_type} is \code{bootstrap_confidence_interval} or \code{bci}, +aggregation leads to a single bias-corrected estimate with lower and upper +boundaries of the confidence interval. This has no effect if +\code{estimation_type} is \code{point}. + +The default value is equal to \code{TRUE} except when assessing metrics to assess +model performance, as the default violin plot requires underlying data. + +As with \code{detail_level} and \code{estimation_type}, a non-default +\code{aggregate_results} parameter can be specified for separate evaluation steps +by providing a parameter value in a named list with data elements, e.g. +\code{list("auc_data"=TRUE, , "model_performance"=FALSE)}. This parameter exists +for the same elements as \code{estimation_type}.} + \item{\code{confidence_level}}{(\emph{optional}) Numeric value for the level at which +confidence intervals are determined. In the case bootstraps are used to +determine the confidence intervals bootstrap estimation, \code{familiar} uses the +rule of thumb \eqn{n = 20 / ci.level} to determine the number of required +bootstraps. + +The default value is \code{0.95}.} + \item{\code{bootstrap_ci_method}}{(\emph{optional}) Method used to determine bootstrap +confidence intervals (Efron and Hastie, 2016). The following methods are +implemented: +\itemize{ +\item \code{percentile} (default): Confidence intervals obtained using the percentile +method. +\item \code{bc}: Bias-corrected confidence intervals. +} + +Note that the standard method is not implemented because this method is +often not suitable due to non-normal distributions. The bias-corrected and +accelerated (BCa) method is not implemented yet.} + \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} +parameter is one or more \code{familiarData} objects.} + \item{\code{collection_name}}{Name of the collection.} + \item{\code{device}}{Device to use. Can either be a device function +(e.g. \link{png}), or one of "eps", "ps", "tex" (pictex), +"pdf", "jpeg", "tiff", "png", "bmp", "svg" or "wmf" (windows only). If +\code{NULL} (default), the device is guessed based on the \code{filename} extension.} + \item{\code{scale}}{Multiplicative scaling factor.} + \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} + \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not +save images larger than 50x50 inches, to prevent the common error of +specifying dimensions in pixels.} + \item{\code{bg}}{Background colour. If \code{NULL}, uses the \code{plot.background} fill value +from the plot theme.} + \item{\code{create.dir}}{Whether to create new directories if a non-existing +directory is specified in the \code{filename} or \code{path} (\code{TRUE}) or return an +error (\code{FALSE}, default). If \code{FALSE} and run in an interactive session, +a prompt will appear asking to create a new directory when necessary.} + }} +} +\value{ +\code{NULL} or list of plot objects, if \code{dir_path} is \code{NULL}. +} +\description{ +This method creates a SHAP dependence plot that shows the +dependence of the SHAP value of a feature against its value. +} +\details{ +This function creates SHAP dependence plots, which show how the +marginal contributions of a feature to the predicted value depend on its +value. + +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set}, +\code{evaluation_time} (survival outcome only) and \code{positive_class} (categorical +outcomes). The default is to facet by \code{evaluation_time} or +\code{positive_class}, and split by \code{vimp_method}, \code{learner} and \code{data_set}. +\code{color_by} is not used. + +Labelling methods such as \code{set_vimp_method_names} or \code{set_learner_names} +can be applied to the \code{familiarCollection} object to update labels, and +order the output in the figure. +} diff --git a/man/plot_shap_force-methods.Rd b/man/plot_shap_force-methods.Rd new file mode 100644 index 00000000..e81d1526 --- /dev/null +++ b/man/plot_shap_force-methods.Rd @@ -0,0 +1,399 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotShapForce.R +\name{plot_shap_force} +\alias{plot_shap_force} +\alias{plot_shap_force,ANY-method} +\alias{plot_shap_force,familiarCollection-method} +\title{Create SHAP force plot} +\usage{ +plot_shap_force( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + x_label = waiver(), + x_label_shared = "column", + y_label = waiver(), + y_label_shared = "row", + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + highlight_feature = NULL, + sample_order = "prediction", + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_force}{ANY}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + x_label = waiver(), + x_label_shared = "column", + y_label = waiver(), + y_label_shared = "row", + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + highlight_feature = NULL, + sample_order = "prediction", + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_force}{familiarCollection}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + discrete_palette = NULL, + x_label = waiver(), + x_label_shared = "column", + y_label = waiver(), + y_label_shared = "row", + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + y_range = NULL, + y_n_breaks = 5L, + y_breaks = NULL, + highlight_feature = NULL, + sample_order = "prediction", + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) +} +\arguments{ +\item{object}{\code{familiarCollection} object, or one or more \code{familiarData} +objects, that will be internally converted to a \code{familiarCollection} +object. It is also possible to provide a \code{familiarEnsemble} or one or more +\code{familiarModel} objects together with the data from which data is computed +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} + +\item{draw}{(\emph{optional}) Draws the plot if TRUE.} + +\item{dir_path}{(\emph{optional}) Path to the directory where created SHAP force +plots are saved to. Output is saved in the \code{explanation} subdirectory. If +\code{NULL} no figures are saved, but are returned instead.} + +\item{split_by}{(\emph{optional}) Splitting variables. This refers to column names +on which datasets are split. A separate figure is created for each split. +See details for available variables.} + +\item{x_axis_by}{(\emph{optional}) Variable plotted along the x-axis of a plot. +The variable cannot overlap with variables provided to the \code{split_by} and +\code{y_axis_by} arguments (if used), but may overlap with other arguments. Only +one variable is allowed for this argument. See details for available +variables.} + +\item{y_axis_by}{(\emph{optional}) Variable plotted along the y-axis of a plot. +The variable cannot overlap with variables provided to the \code{split_by} and +\code{x_axis_by} arguments (if used), but may overlap with other arguments. Only +one variable is allowed for this argument. See details for available +variables.} + +\item{facet_by}{(\emph{optional}) Variables used to determine how and if facets of +each figure appear. In case the \code{facet_wrap_cols} argument is \code{NULL}, the +first variable is used to define columns, and the remaing variables are +used to define rows of facets. The variables cannot overlap with those +provided to the \code{split_by} argument, but may overlap with other arguments. +See details for available variables.} + +\item{facet_wrap_cols}{(\emph{optional}) Number of columns to generate when facet +wrapping. If NULL, a facet grid is produced instead.} + +\item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} + +\item{discrete_palette}{(\emph{optional}) Discrete palette used to colour the +elements of force plots. \code{familiar} has a default palette. Other palettes +are supported by the \code{paletteer} package, \code{grDevices::palette.pals()} +(requires R >= 4.0.0), \code{grDevices::hcl.pals()} (requires R >= 3.6.0). You +may also specify your own palette by providing a vector of colour names +listed by \code{grDevices::colors()} or through hexadecimal RGB strings.} + +\item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label +is shown.} + +\item{x_label_shared}{(\emph{optional}) Sharing of x-axis labels between facets. +One of three values: +\itemize{ +\item \code{overall}: A single label is placed at the bottom of the figure. Tick +text (but not the ticks themselves) is removed for all but the bottom facet +plot(s). +\item \code{column}: A label is placed at the bottom of each column. Tick text (but +not the ticks themselves) is removed for all but the bottom facet plot(s). +\item \code{individual}: A label is placed below each facet plot. Tick text is kept. +}} + +\item{y_label}{(\emph{optional}) Label to provide to the y-axis. If NULL, no label +is shown.} + +\item{y_label_shared}{(\emph{optional}) Sharing of y-axis labels between facets. +One of three values: +\itemize{ +\item \code{overall}: A single label is placed to the left of the figure. Tick text +(but not the ticks themselves) is removed for all but the left-most facet +plot(s). +\item \code{row}: A label is placed to the left of each row. Tick text (but not the +ticks themselves) is removed for all but the left-most facet plot(s). +\item \code{individual}: A label is placed below each facet plot. Tick text is kept. +}} + +\item{legend_label}{(\emph{optional}) Label to provide to the legend. If NULL, the +legend will not have a name.} + +\item{plot_title}{(\emph{optional}) Label to provide as figure title. If NULL, no +title is shown.} + +\item{plot_sub_title}{(\emph{optional}) Label to provide as figure subtitle. If +NULL, no subtitle is shown.} + +\item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no +caption is shown.} + +\item{y_range}{(\emph{optional}) Value range for the y-axis.} + +\item{y_n_breaks}{(\emph{optional}) Number of breaks to show on the y-axis of the +plot. \code{y_n_breaks} is used to determine the \code{y_breaks} argument in case it +is unset.} + +\item{y_breaks}{(\emph{optional}) Break points on the y-axis of the plot.} + +\item{highlight_feature}{(\emph{optional}) Name of one or more features that +should be highlighted in the force plot.} + +\item{sample_order}{(\emph{optional}) Ordering of samples, one of: +\itemize{ +\item \code{prediction}: samples are ordered by increasing predicted value. Sample +order between facets may differ. +\item \code{original}: samples retain the original ordering. Sample order between +facets is consistent. +}} + +\item{width}{(\emph{optional}) Width of the plot. A default value is derived from +the number of facets.} + +\item{height}{(\emph{optional}) Height of the plot. A default value is derived +from the number of features and the number of facets.} + +\item{units}{(\emph{optional}) Plot size unit. Either \code{cm} (default), \code{mm} or +\verb{in}.} + +\item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} + +\item{...}{ + Arguments passed on to \code{\link[=extract_performance]{extract_performance}}, \code{\link[=as_familiar_collection]{as_familiar_collection}}, \code{\link[ggplot2:ggsave]{ggplot2::ggsave}} + \describe{ + \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that +constitutes the data that are assessed.} + \item{\code{is_pre_processed}}{Flag that indicates whether the data was already +pre-processed externally, e.g. normalised and clustered. Only used if the +\code{data} argument is a \code{data.table} or \code{data.frame}.} + \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then +used to speed up computation through parallellisation.} + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. +calibration. If not provided explicitly, this parameter is read from +settings used at creation of the underlying \code{familiarModel} objects. Only +used for \code{survival} outcomes.} + \item{\code{ensemble_method}}{Method for ensembling predictions from models for the +same sample. Available methods are: +\itemize{ +\item \code{median} (default): Use the median of the predicted values as the ensemble +value for a sample. +\item \code{mean}: Use the mean of the predicted values as the ensemble value for a +sample. +}} + \item{\code{metric}}{One or more metrics for assessing model performance. See the +vignette on performance metrics for the available metrics. If not provided +explicitly, this parameter is read from settings used at creation of the +underlying \code{familiarModel} objects.} + \item{\code{verbose}}{Flag to indicate whether feedback should be provided on the +computation and extraction of various data elements.} + \item{\code{message_indent}}{Number of indentation steps for messages shown during +computation and extraction of various data elements.} + \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed +and aggregated. +\itemize{ +\item \code{ensemble}: Results are computed at the ensemble level, i.e. over all +models in the ensemble. This means that, for example, bias-corrected +estimates of model performance are assessed by creating (at least) 20 +bootstraps and computing the model performance of the ensemble model for +each bootstrap. +\item \code{hybrid} (default): Results are computed at the level of models in an +ensemble. This means that, for example, bias-corrected estimates of model +performance are directly computed using the models in the ensemble. If there +are at least 20 trained models in the ensemble, performance is computed for +each model, in contrast to \code{ensemble} where performance is computed for the +ensemble of models. If there are less than 20 trained models in the +ensemble, bootstraps are created so that at least 20 point estimates can be +made. +\item \code{model}: Results are computed at the model level. This means that, for +example, bias-corrected estimates of model performance are assessed by +creating (at least) 20 bootstraps and computing the performance of the model +for each bootstrap. +} + +Note that each level of detail has a different interpretation for bootstrap +confidence intervals. For \code{ensemble} and \code{model} these are the confidence +intervals for the ensemble and an individual model, respectively. That is, +the confidence interval describes the range where an estimate produced by a +respective ensemble or model trained on a repeat of the experiment may be +found with the probability of the confidence level. For \code{hybrid}, it +represents the range where any single model trained on a repeat of the +experiment may be found with the probability of the confidence level. By +definition, confidence intervals obtained using \code{hybrid} are at least as +wide as those for \code{ensemble}. \code{hybrid} offers the correct interpretation if +the goal of the analysis is to assess the result of a single, unspecified, +model. + +\code{hybrid} is generally computationally less expensive then \code{ensemble}, which +in turn is somewhat less expensive than \code{model}. + +A non-default \code{detail_level} parameter can be specified for separate +evaluation steps by providing a parameter value in a named list with data +elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. +This parameter can be set for the following data elements: \code{auc_data}, +\code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} + \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be +possible. This has the following options: +\itemize{ +\item \code{point}: Point estimates. +\item \code{bias_correction} or \code{bc}: Bias-corrected estimates. A bias-corrected +estimate is computed from (at least) 20 point estimates, and \code{familiar} may +bootstrap the data to create them. +\item \code{bootstrap_confidence_interval} or \code{bci} (default): Bias-corrected +estimates with bootstrap confidence intervals (Efron and Hastie, 2016). The +number of point estimates required depends on the \code{confidence_level} +parameter, and \code{familiar} may bootstrap the data to create them. +} + +As with \code{detail_level}, a non-default \code{estimation_type} parameter can be +specified for separate evaluation steps by providing a parameter value in a +named list with data elements, e.g. \code{list("auc_data"="bci", "model_performance"="point")}. This parameter can be set for the following +data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, +\code{permutation_vimp}, \code{ice_data}, and \code{prediction_data}.} + \item{\code{aggregate_results}}{(\emph{optional}) Flag that signifies whether results +should be aggregated during evaluation. If \code{estimation_type} is +\code{bias_correction} or \code{bc}, aggregation leads to a single bias-corrected +estimate. If \code{estimation_type} is \code{bootstrap_confidence_interval} or \code{bci}, +aggregation leads to a single bias-corrected estimate with lower and upper +boundaries of the confidence interval. This has no effect if +\code{estimation_type} is \code{point}. + +The default value is equal to \code{TRUE} except when assessing metrics to assess +model performance, as the default violin plot requires underlying data. + +As with \code{detail_level} and \code{estimation_type}, a non-default +\code{aggregate_results} parameter can be specified for separate evaluation steps +by providing a parameter value in a named list with data elements, e.g. +\code{list("auc_data"=TRUE, , "model_performance"=FALSE)}. This parameter exists +for the same elements as \code{estimation_type}.} + \item{\code{confidence_level}}{(\emph{optional}) Numeric value for the level at which +confidence intervals are determined. In the case bootstraps are used to +determine the confidence intervals bootstrap estimation, \code{familiar} uses the +rule of thumb \eqn{n = 20 / ci.level} to determine the number of required +bootstraps. + +The default value is \code{0.95}.} + \item{\code{bootstrap_ci_method}}{(\emph{optional}) Method used to determine bootstrap +confidence intervals (Efron and Hastie, 2016). The following methods are +implemented: +\itemize{ +\item \code{percentile} (default): Confidence intervals obtained using the percentile +method. +\item \code{bc}: Bias-corrected confidence intervals. +} + +Note that the standard method is not implemented because this method is +often not suitable due to non-normal distributions. The bias-corrected and +accelerated (BCa) method is not implemented yet.} + \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} +parameter is one or more \code{familiarData} objects.} + \item{\code{collection_name}}{Name of the collection.} + \item{\code{device}}{Device to use. Can either be a device function +(e.g. \link{png}), or one of "eps", "ps", "tex" (pictex), +"pdf", "jpeg", "tiff", "png", "bmp", "svg" or "wmf" (windows only). If +\code{NULL} (default), the device is guessed based on the \code{filename} extension.} + \item{\code{scale}}{Multiplicative scaling factor.} + \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} + \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not +save images larger than 50x50 inches, to prevent the common error of +specifying dimensions in pixels.} + \item{\code{bg}}{Background colour. If \code{NULL}, uses the \code{plot.background} fill value +from the plot theme.} + \item{\code{create.dir}}{Whether to create new directories if a non-existing +directory is specified in the \code{filename} or \code{path} (\code{TRUE}) or return an +error (\code{FALSE}, default). If \code{FALSE} and run in an interactive session, +a prompt will appear asking to create a new directory when necessary.} + }} +} +\value{ +\code{NULL} or list of plot objects, if \code{dir_path} is \code{NULL}. +} +\description{ +This method creates plots that show stacked SHAP force values +obtained from the data stored in a familiarCollection object. +} +\details{ +This function plots model performance based on empirical bootstraps, +using various plot representations. + +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set}, +\code{evaluation_time} (survival outcome only) and \code{positive_class} (categorical +outcomes). The default for is to facet by \code{evaluation_time} or +\code{positive_class}, and split by \code{vimp_method}, \code{learner} and \code{data_set}. +\code{color_by} is not used. + +Labelling methods such as \code{set_vimp_method_names} or \code{set_learner_names} +can be applied to the \code{familiarCollection} object to update labels, and +order the output in the figure. +} diff --git a/man/plot_shap_summary-methods.Rd b/man/plot_shap_summary-methods.Rd new file mode 100644 index 00000000..6fc1286a --- /dev/null +++ b/man/plot_shap_summary-methods.Rd @@ -0,0 +1,419 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotShapSummary.R +\name{plot_shap_summary} +\alias{plot_shap_summary} +\alias{plot_shap_summary,ANY-method} +\alias{plot_shap_summary,familiarCollection-method} +\title{Plot SHAP summary.} +\usage{ +plot_shap_summary( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + color_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + plot_type = NULL, + value_representation = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_summary}{ANY}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + color_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + plot_type = NULL, + value_representation = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_summary}{familiarCollection}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + color_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + plot_type = NULL, + value_representation = NULL, + ggtheme = NULL, + discrete_palette = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) +} +\arguments{ +\item{object}{\code{familiarCollection} object, or one or more \code{familiarData} +objects, that will be internally converted to a \code{familiarCollection} +object. It is also possible to provide a \code{familiarEnsemble} or one or more +\code{familiarModel} objects together with the data from which data is computed +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} + +\item{draw}{(\emph{optional}) Draws the plot if TRUE.} + +\item{dir_path}{(\emph{optional}) Path to the directory where created SHAP summary +plots are saved to. Output is saved in the \code{explanation} subdirectory. If +\code{NULL} no figures are saved, but are returned instead.} + +\item{split_by}{(\emph{optional}) Splitting variables. This refers to column names +on which datasets are split. A separate figure is created for each split. +See details for available variables.} + +\item{x_axis_by}{(\emph{optional}) Variable plotted along the x-axis of a plot. +The variable cannot overlap with variables provided to the \code{split_by} and +\code{y_axis_by} arguments (if used), but may overlap with other arguments. Only +one variable is allowed for this argument. See details for available +variables.} + +\item{y_axis_by}{(\emph{optional}) Variable plotted along the y-axis of a plot. +The variable cannot overlap with variables provided to the \code{split_by} and +\code{x_axis_by} arguments (if used), but may overlap with other arguments. Only +one variable is allowed for this argument. See details for available +variables.} + +\item{color_by}{(\emph{optional}) Variables used to determine fill colour of plot +objects. The variables cannot overlap with those provided to the \code{split_by} +argument, but may overlap with other arguments. See details for available +variables.} + +\item{facet_by}{(\emph{optional}) Variables used to determine how and if facets of +each figure appear. In case the \code{facet_wrap_cols} argument is \code{NULL}, the +first variable is used to define columns, and the remaing variables are +used to define rows of facets. The variables cannot overlap with those +provided to the \code{split_by} argument, but may overlap with other arguments. +See details for available variables.} + +\item{facet_wrap_cols}{(\emph{optional}) Number of columns to generate when facet +wrapping. If NULL, a facet grid is produced instead.} + +\item{plot_type}{(\emph{optional}) Type of plot to draw. This is one of +\code{swarmplot} (draws a beeswarm plot), \code{barplot} (draws a barplot), +\code{boxplot} (draws a boxplot) and \code{violinplot} (draws a violin plot). +Defaults to \code{boxplot} if a single SHAP value is available for each feature, +and \code{swarmplot} otherwise. + +The choice for \code{plot_type} affects several other arguments.} + +\item{value_representation}{(\emph{optional}) Indicates how SHAP values are +represented, with the following options: +\itemize{ +\item \code{raw} (default for \code{swarmplot}, \code{boxplot}, and \code{violinplot} plot +types): uses SHAP values as they are. +\item \code{abs}: uses absolute value of SHAP values. +\item \code{abs_mean} (default for \code{barplot} plot type): uses mean absolute value of +SHAP values. Only used by \code{barplot}. +\item \code{abs_max}: uses maximum absolute value of SHAP values. Only used by +\code{barplot}. +\item \code{abs_min}: uses minimum absolute value of SHAP values. Only used by +\code{barplot}. +} + +If \code{abs_mean}, \code{abs_max} or \code{abs_min} are chosen, \code{plot_type} automatically +switches to \code{barplot}.} + +\item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} + +\item{discrete_palette}{(\emph{optional}) Palette for colouring plot elements +indicated by the \code{color_by} argument (if any). Only used if \code{plot_type} is +not \code{swarmplot}. \code{familiar} has a default palette. Other palettes are +supported by the \code{paletteer} package, \code{grDevices::palette.pals()} (requires +R >= 4.0.0), \code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, +\code{heat.colors}, \code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which +correspond to the palettes of the same name in \code{grDevices}. You may also +specify your own palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} + +\item{gradient_palette}{(\emph{optional}) Sequential or divergent palette used to +colour the points the raster in the default \code{swarmplot} plots. This +argument is not used for other \code{plot_type} value. \code{familiar} has a default +palette. Other palettes are supported by the \code{paletteer} package, +\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} +(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, +\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same +name in \code{grDevices}. You may also specify your own palette by providing a +vector of colour names listed by \code{grDevices::colors()} or through +hexadecimal RGB strings.} + +\item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label +is shown.} + +\item{y_label}{(\emph{optional}) Label to provide to the y-axis. If NULL, no label +is shown.} + +\item{legend_label}{(\emph{optional}) Label to provide to the legend. If NULL, the +legend will not have a name.} + +\item{plot_title}{(\emph{optional}) Label to provide as figure title. If NULL, no +title is shown.} + +\item{plot_sub_title}{(\emph{optional}) Label to provide as figure subtitle. If +NULL, no subtitle is shown.} + +\item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no +caption is shown.} + +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + +\item{x_range}{(\emph{optional}) Value range for the x-axis.} + +\item{x_n_breaks}{(\emph{optional}) Number of breaks to show on the x-axis of the +plot. \code{x_n_breaks} is used to determine the \code{x_breaks} argument in case it +is unset.} + +\item{x_breaks}{(\emph{optional}) Break points on the x-axis of the plot.} + +\item{width}{(\emph{optional}) Width of the plot. A default value is derived from +the number of facets.} + +\item{height}{(\emph{optional}) Height of the plot. A default value is derived +from the number of features and the number of facets.} + +\item{units}{(\emph{optional}) Plot size unit. Either \code{cm} (default), \code{mm} or +\verb{in}.} + +\item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} + +\item{...}{ + Arguments passed on to \code{\link[=extract_performance]{extract_performance}}, \code{\link[=as_familiar_collection]{as_familiar_collection}}, \code{\link[ggplot2:ggsave]{ggplot2::ggsave}} + \describe{ + \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that +constitutes the data that are assessed.} + \item{\code{is_pre_processed}}{Flag that indicates whether the data was already +pre-processed externally, e.g. normalised and clustered. Only used if the +\code{data} argument is a \code{data.table} or \code{data.frame}.} + \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then +used to speed up computation through parallellisation.} + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. +calibration. If not provided explicitly, this parameter is read from +settings used at creation of the underlying \code{familiarModel} objects. Only +used for \code{survival} outcomes.} + \item{\code{ensemble_method}}{Method for ensembling predictions from models for the +same sample. Available methods are: +\itemize{ +\item \code{median} (default): Use the median of the predicted values as the ensemble +value for a sample. +\item \code{mean}: Use the mean of the predicted values as the ensemble value for a +sample. +}} + \item{\code{metric}}{One or more metrics for assessing model performance. See the +vignette on performance metrics for the available metrics. If not provided +explicitly, this parameter is read from settings used at creation of the +underlying \code{familiarModel} objects.} + \item{\code{verbose}}{Flag to indicate whether feedback should be provided on the +computation and extraction of various data elements.} + \item{\code{message_indent}}{Number of indentation steps for messages shown during +computation and extraction of various data elements.} + \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed +and aggregated. +\itemize{ +\item \code{ensemble}: Results are computed at the ensemble level, i.e. over all +models in the ensemble. This means that, for example, bias-corrected +estimates of model performance are assessed by creating (at least) 20 +bootstraps and computing the model performance of the ensemble model for +each bootstrap. +\item \code{hybrid} (default): Results are computed at the level of models in an +ensemble. This means that, for example, bias-corrected estimates of model +performance are directly computed using the models in the ensemble. If there +are at least 20 trained models in the ensemble, performance is computed for +each model, in contrast to \code{ensemble} where performance is computed for the +ensemble of models. If there are less than 20 trained models in the +ensemble, bootstraps are created so that at least 20 point estimates can be +made. +\item \code{model}: Results are computed at the model level. This means that, for +example, bias-corrected estimates of model performance are assessed by +creating (at least) 20 bootstraps and computing the performance of the model +for each bootstrap. +} + +Note that each level of detail has a different interpretation for bootstrap +confidence intervals. For \code{ensemble} and \code{model} these are the confidence +intervals for the ensemble and an individual model, respectively. That is, +the confidence interval describes the range where an estimate produced by a +respective ensemble or model trained on a repeat of the experiment may be +found with the probability of the confidence level. For \code{hybrid}, it +represents the range where any single model trained on a repeat of the +experiment may be found with the probability of the confidence level. By +definition, confidence intervals obtained using \code{hybrid} are at least as +wide as those for \code{ensemble}. \code{hybrid} offers the correct interpretation if +the goal of the analysis is to assess the result of a single, unspecified, +model. + +\code{hybrid} is generally computationally less expensive then \code{ensemble}, which +in turn is somewhat less expensive than \code{model}. + +A non-default \code{detail_level} parameter can be specified for separate +evaluation steps by providing a parameter value in a named list with data +elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. +This parameter can be set for the following data elements: \code{auc_data}, +\code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} + \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be +possible. This has the following options: +\itemize{ +\item \code{point}: Point estimates. +\item \code{bias_correction} or \code{bc}: Bias-corrected estimates. A bias-corrected +estimate is computed from (at least) 20 point estimates, and \code{familiar} may +bootstrap the data to create them. +\item \code{bootstrap_confidence_interval} or \code{bci} (default): Bias-corrected +estimates with bootstrap confidence intervals (Efron and Hastie, 2016). The +number of point estimates required depends on the \code{confidence_level} +parameter, and \code{familiar} may bootstrap the data to create them. +} + +As with \code{detail_level}, a non-default \code{estimation_type} parameter can be +specified for separate evaluation steps by providing a parameter value in a +named list with data elements, e.g. \code{list("auc_data"="bci", "model_performance"="point")}. This parameter can be set for the following +data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, +\code{permutation_vimp}, \code{ice_data}, and \code{prediction_data}.} + \item{\code{aggregate_results}}{(\emph{optional}) Flag that signifies whether results +should be aggregated during evaluation. If \code{estimation_type} is +\code{bias_correction} or \code{bc}, aggregation leads to a single bias-corrected +estimate. If \code{estimation_type} is \code{bootstrap_confidence_interval} or \code{bci}, +aggregation leads to a single bias-corrected estimate with lower and upper +boundaries of the confidence interval. This has no effect if +\code{estimation_type} is \code{point}. + +The default value is equal to \code{TRUE} except when assessing metrics to assess +model performance, as the default violin plot requires underlying data. + +As with \code{detail_level} and \code{estimation_type}, a non-default +\code{aggregate_results} parameter can be specified for separate evaluation steps +by providing a parameter value in a named list with data elements, e.g. +\code{list("auc_data"=TRUE, , "model_performance"=FALSE)}. This parameter exists +for the same elements as \code{estimation_type}.} + \item{\code{confidence_level}}{(\emph{optional}) Numeric value for the level at which +confidence intervals are determined. In the case bootstraps are used to +determine the confidence intervals bootstrap estimation, \code{familiar} uses the +rule of thumb \eqn{n = 20 / ci.level} to determine the number of required +bootstraps. + +The default value is \code{0.95}.} + \item{\code{bootstrap_ci_method}}{(\emph{optional}) Method used to determine bootstrap +confidence intervals (Efron and Hastie, 2016). The following methods are +implemented: +\itemize{ +\item \code{percentile} (default): Confidence intervals obtained using the percentile +method. +\item \code{bc}: Bias-corrected confidence intervals. +} + +Note that the standard method is not implemented because this method is +often not suitable due to non-normal distributions. The bias-corrected and +accelerated (BCa) method is not implemented yet.} + \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} +parameter is one or more \code{familiarData} objects.} + \item{\code{collection_name}}{Name of the collection.} + \item{\code{device}}{Device to use. Can either be a device function +(e.g. \link{png}), or one of "eps", "ps", "tex" (pictex), +"pdf", "jpeg", "tiff", "png", "bmp", "svg" or "wmf" (windows only). If +\code{NULL} (default), the device is guessed based on the \code{filename} extension.} + \item{\code{scale}}{Multiplicative scaling factor.} + \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} + \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not +save images larger than 50x50 inches, to prevent the common error of +specifying dimensions in pixels.} + \item{\code{bg}}{Background colour. If \code{NULL}, uses the \code{plot.background} fill value +from the plot theme.} + \item{\code{create.dir}}{Whether to create new directories if a non-existing +directory is specified in the \code{filename} or \code{path} (\code{TRUE}) or return an +error (\code{FALSE}, default). If \code{FALSE} and run in an interactive session, +a prompt will appear asking to create a new directory when necessary.} + }} +} +\value{ +\code{NULL} or list of plot objects, if \code{dir_path} is \code{NULL}. +} +\description{ +This method creates plots that show a summary of SHAP values +obtained from the data stored in a familiarCollection object. +} +\details{ +This function creates SHAP summary plots, which provide an overview +of marginal contributions of feature values to the predicted values. + +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set}, +\code{evaluation_time} (survival outcome only) and \code{positive_class} (categorical +outcomes). The default for \code{value_representation = "raw"} is to facet by +\code{evaluation_time} or \code{positive_class}, and split by \code{vimp_method} and +\code{learner}. \code{color_by} is not used. The default for other +\code{value_representation} is to \code{color_by} \code{evaluation_time} or +\code{positive_class}, and split by \code{vimp_method}, \code{learner} and \code{data_set}. + +Labelling methods such as \code{set_vimp_method_names} or \code{set_learner_names} +can be applied to the \code{familiarCollection} object to update labels, and +order the output in the figure. +} diff --git a/man/plot_shap_waterfall-methods.Rd b/man/plot_shap_waterfall-methods.Rd new file mode 100644 index 00000000..75f7eca4 --- /dev/null +++ b/man/plot_shap_waterfall-methods.Rd @@ -0,0 +1,364 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotShapWaterfall.R +\name{plot_shap_waterfall} +\alias{plot_shap_waterfall} +\alias{plot_shap_waterfall,ANY-method} +\alias{plot_shap_waterfall,familiarCollection-method} +\title{Create SHAP waterfall plot} +\usage{ +plot_shap_waterfall( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_waterfall}{ANY}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) + +\S4method{plot_shap_waterfall}{familiarCollection}( + object, + draw = FALSE, + dir_path = NULL, + split_by = NULL, + x_axis_by = NULL, + y_axis_by = NULL, + facet_by = NULL, + facet_wrap_cols = NULL, + ggtheme = NULL, + gradient_palette = NULL, + x_label = waiver(), + y_label = waiver(), + legend_label = waiver(), + plot_title = waiver(), + plot_sub_title = waiver(), + caption = NULL, + limit_n_features = waiver(), + x_range = NULL, + x_n_breaks = 5L, + x_breaks = NULL, + width = waiver(), + height = waiver(), + units = waiver(), + export_collection = FALSE, + ... +) +} +\arguments{ +\item{object}{\code{familiarCollection} object, or one or more \code{familiarData} +objects, that will be internally converted to a \code{familiarCollection} +object. It is also possible to provide a \code{familiarEnsemble} or one or more +\code{familiarModel} objects together with the data from which data is computed +prior to export. Paths to such files can also be provided. + +Additionally, some \code{familiarData} objects can be created from prediction +tables (\code{familiarDataElementPredictionTable}). Other \code{familiarData} objects +can be created from data (\code{dataObject}, or \code{data.table}). Please +check \emph{details} for more information.} + +\item{draw}{(\emph{optional}) Draws the plot if TRUE.} + +\item{dir_path}{(\emph{optional}) Path to the directory where created +plots are saved to. Output is saved in the \code{explanation} subdirectory. If +\code{NULL} no figures are saved, but are returned instead.} + +\item{split_by}{(\emph{optional}) Splitting variables. This refers to column names +on which datasets are split. A separate figure is created for each split. +See details for available variables.} + +\item{x_axis_by}{(\emph{optional}) Variable plotted along the x-axis of a plot. +The variable cannot overlap with variables provided to the \code{split_by} and +\code{y_axis_by} arguments (if used), but may overlap with other arguments. Only +one variable is allowed for this argument. See details for available +variables.} + +\item{y_axis_by}{(\emph{optional}) Variable plotted along the y-axis of a plot. +The variable cannot overlap with variables provided to the \code{split_by} and +\code{x_axis_by} arguments (if used), but may overlap with other arguments. Only +one variable is allowed for this argument. See details for available +variables.} + +\item{facet_by}{(\emph{optional}) Variables used to determine how and if facets of +each figure appear. In case the \code{facet_wrap_cols} argument is \code{NULL}, the +first variable is used to define columns, and the remaing variables are +used to define rows of facets. The variables cannot overlap with those +provided to the \code{split_by} argument, but may overlap with other arguments. +See details for available variables.} + +\item{facet_wrap_cols}{(\emph{optional}) Number of columns to generate when facet +wrapping. If NULL, a facet grid is produced instead.} + +\item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} + +\item{gradient_palette}{(\emph{optional}) Divergent palette used to +colour the elements of waterfall plots. \code{familiar} has a default +palette. Other palettes are supported by the \code{paletteer} package, +\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} +(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, +\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same +name in \code{grDevices}. You may also specify your own palette by providing a +vector of colour names listed by \code{grDevices::colors()} or through +hexadecimal RGB strings.} + +\item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label +is shown.} + +\item{y_label}{(\emph{optional}) Label to provide to the y-axis. If NULL, no label +is shown.} + +\item{legend_label}{(\emph{optional}) Label to provide to the legend. If NULL, the +legend will not have a name.} + +\item{plot_title}{(\emph{optional}) Label to provide as figure title. If NULL, no +title is shown.} + +\item{plot_sub_title}{(\emph{optional}) Label to provide as figure subtitle. If +NULL, no subtitle is shown.} + +\item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no +caption is shown.} + +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + +\item{x_range}{(\emph{optional}) Value range for the x-axis.} + +\item{x_n_breaks}{(\emph{optional}) Number of breaks to show on the x-axis of the +plot. \code{x_n_breaks} is used to determine the \code{x_breaks} argument in case it +is unset.} + +\item{x_breaks}{(\emph{optional}) Break points on the x-axis of the plot.} + +\item{width}{(\emph{optional}) Width of the plot. A default value is derived from +the number of facets.} + +\item{height}{(\emph{optional}) Height of the plot. A default value is derived +from the number of features and the number of facets.} + +\item{units}{(\emph{optional}) Plot size unit. Either \code{cm} (default), \code{mm} or +\verb{in}.} + +\item{export_collection}{(\emph{optional}) Exports the collection if TRUE.} + +\item{...}{ + Arguments passed on to \code{\link[=extract_performance]{extract_performance}}, \code{\link[=as_familiar_collection]{as_familiar_collection}}, \code{\link[ggplot2:ggsave]{ggplot2::ggsave}} + \describe{ + \item{\code{data}}{A \code{dataObject} object, \code{data.table} or \code{data.frame} that +constitutes the data that are assessed.} + \item{\code{is_pre_processed}}{Flag that indicates whether the data was already +pre-processed externally, e.g. normalised and clustered. Only used if the +\code{data} argument is a \code{data.table} or \code{data.frame}.} + \item{\code{cl}}{Cluster created using the \code{parallel} package. This cluster is then +used to speed up computation through parallellisation.} + \item{\code{evaluation_times}}{One or more time points that are used for in analysis +of survival problems when data has to be assessed at a set time, e.g. +calibration. If not provided explicitly, this parameter is read from +settings used at creation of the underlying \code{familiarModel} objects. Only +used for \code{survival} outcomes.} + \item{\code{ensemble_method}}{Method for ensembling predictions from models for the +same sample. Available methods are: +\itemize{ +\item \code{median} (default): Use the median of the predicted values as the ensemble +value for a sample. +\item \code{mean}: Use the mean of the predicted values as the ensemble value for a +sample. +}} + \item{\code{metric}}{One or more metrics for assessing model performance. See the +vignette on performance metrics for the available metrics. If not provided +explicitly, this parameter is read from settings used at creation of the +underlying \code{familiarModel} objects.} + \item{\code{verbose}}{Flag to indicate whether feedback should be provided on the +computation and extraction of various data elements.} + \item{\code{message_indent}}{Number of indentation steps for messages shown during +computation and extraction of various data elements.} + \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed +and aggregated. +\itemize{ +\item \code{ensemble}: Results are computed at the ensemble level, i.e. over all +models in the ensemble. This means that, for example, bias-corrected +estimates of model performance are assessed by creating (at least) 20 +bootstraps and computing the model performance of the ensemble model for +each bootstrap. +\item \code{hybrid} (default): Results are computed at the level of models in an +ensemble. This means that, for example, bias-corrected estimates of model +performance are directly computed using the models in the ensemble. If there +are at least 20 trained models in the ensemble, performance is computed for +each model, in contrast to \code{ensemble} where performance is computed for the +ensemble of models. If there are less than 20 trained models in the +ensemble, bootstraps are created so that at least 20 point estimates can be +made. +\item \code{model}: Results are computed at the model level. This means that, for +example, bias-corrected estimates of model performance are assessed by +creating (at least) 20 bootstraps and computing the performance of the model +for each bootstrap. +} + +Note that each level of detail has a different interpretation for bootstrap +confidence intervals. For \code{ensemble} and \code{model} these are the confidence +intervals for the ensemble and an individual model, respectively. That is, +the confidence interval describes the range where an estimate produced by a +respective ensemble or model trained on a repeat of the experiment may be +found with the probability of the confidence level. For \code{hybrid}, it +represents the range where any single model trained on a repeat of the +experiment may be found with the probability of the confidence level. By +definition, confidence intervals obtained using \code{hybrid} are at least as +wide as those for \code{ensemble}. \code{hybrid} offers the correct interpretation if +the goal of the analysis is to assess the result of a single, unspecified, +model. + +\code{hybrid} is generally computationally less expensive then \code{ensemble}, which +in turn is somewhat less expensive than \code{model}. + +A non-default \code{detail_level} parameter can be specified for separate +evaluation steps by providing a parameter value in a named list with data +elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. +This parameter can be set for the following data elements: \code{auc_data}, +\code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} + \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be +possible. This has the following options: +\itemize{ +\item \code{point}: Point estimates. +\item \code{bias_correction} or \code{bc}: Bias-corrected estimates. A bias-corrected +estimate is computed from (at least) 20 point estimates, and \code{familiar} may +bootstrap the data to create them. +\item \code{bootstrap_confidence_interval} or \code{bci} (default): Bias-corrected +estimates with bootstrap confidence intervals (Efron and Hastie, 2016). The +number of point estimates required depends on the \code{confidence_level} +parameter, and \code{familiar} may bootstrap the data to create them. +} + +As with \code{detail_level}, a non-default \code{estimation_type} parameter can be +specified for separate evaluation steps by providing a parameter value in a +named list with data elements, e.g. \code{list("auc_data"="bci", "model_performance"="point")}. This parameter can be set for the following +data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, +\code{permutation_vimp}, \code{ice_data}, and \code{prediction_data}.} + \item{\code{aggregate_results}}{(\emph{optional}) Flag that signifies whether results +should be aggregated during evaluation. If \code{estimation_type} is +\code{bias_correction} or \code{bc}, aggregation leads to a single bias-corrected +estimate. If \code{estimation_type} is \code{bootstrap_confidence_interval} or \code{bci}, +aggregation leads to a single bias-corrected estimate with lower and upper +boundaries of the confidence interval. This has no effect if +\code{estimation_type} is \code{point}. + +The default value is equal to \code{TRUE} except when assessing metrics to assess +model performance, as the default violin plot requires underlying data. + +As with \code{detail_level} and \code{estimation_type}, a non-default +\code{aggregate_results} parameter can be specified for separate evaluation steps +by providing a parameter value in a named list with data elements, e.g. +\code{list("auc_data"=TRUE, , "model_performance"=FALSE)}. This parameter exists +for the same elements as \code{estimation_type}.} + \item{\code{confidence_level}}{(\emph{optional}) Numeric value for the level at which +confidence intervals are determined. In the case bootstraps are used to +determine the confidence intervals bootstrap estimation, \code{familiar} uses the +rule of thumb \eqn{n = 20 / ci.level} to determine the number of required +bootstraps. + +The default value is \code{0.95}.} + \item{\code{bootstrap_ci_method}}{(\emph{optional}) Method used to determine bootstrap +confidence intervals (Efron and Hastie, 2016). The following methods are +implemented: +\itemize{ +\item \code{percentile} (default): Confidence intervals obtained using the percentile +method. +\item \code{bc}: Bias-corrected confidence intervals. +} + +Note that the standard method is not implemented because this method is +often not suitable due to non-normal distributions. The bias-corrected and +accelerated (BCa) method is not implemented yet.} + \item{\code{familiar_data_names}}{Names of the dataset(s). Only used if the \code{object} +parameter is one or more \code{familiarData} objects.} + \item{\code{collection_name}}{Name of the collection.} + \item{\code{device}}{Device to use. Can either be a device function +(e.g. \link{png}), or one of "eps", "ps", "tex" (pictex), +"pdf", "jpeg", "tiff", "png", "bmp", "svg" or "wmf" (windows only). If +\code{NULL} (default), the device is guessed based on the \code{filename} extension.} + \item{\code{scale}}{Multiplicative scaling factor.} + \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} + \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not +save images larger than 50x50 inches, to prevent the common error of +specifying dimensions in pixels.} + \item{\code{bg}}{Background colour. If \code{NULL}, uses the \code{plot.background} fill value +from the plot theme.} + \item{\code{create.dir}}{Whether to create new directories if a non-existing +directory is specified in the \code{filename} or \code{path} (\code{TRUE}) or return an +error (\code{FALSE}, default). If \code{FALSE} and run in an interactive session, +a prompt will appear asking to create a new directory when necessary.} + }} +} +\value{ +\code{NULL} or list of plot objects, if \code{dir_path} is \code{NULL}. +} +\description{ +This method creates plots that show a waterfall of SHAP values +obtained from the data stored in a familiarCollection object. +} +\details{ +This function creates SHAP waterfall plots, which show the +individual marginal contributions of feature values to the predicted value. + +Available splitting variables are: \code{vimp_method}, \code{learner}, \code{data_set}, +\code{evaluation_time} (survival outcome only) and \code{positive_class} (categorical +outcomes), \code{sample_id}. The default for is to facet by \code{evaluation_time} or +\code{positive_class}, and split by \code{vimp_method}, +\code{learner}, \code{data_set}, and \code{sample_id}. \code{color_by} is not used. + +Labelling methods such as \code{set_vimp_method_names} or \code{set_learner_names} +can be applied to the \code{familiarCollection} object to update labels, and +order the output in the figure. +} diff --git a/man/plot_univariate_importance-methods.Rd b/man/plot_univariate_importance-methods.Rd index 747071f0..dd1bb076 100644 --- a/man/plot_univariate_importance-methods.Rd +++ b/man/plot_univariate_importance-methods.Rd @@ -29,8 +29,9 @@ plot_univariate_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, significance_level_shown = 0.05, width = waiver(), @@ -64,8 +65,9 @@ plot_univariate_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, significance_level_shown = 0.05, width = waiver(), @@ -99,8 +101,9 @@ plot_univariate_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), x_range = NULL, - x_n_breaks = 5, + x_n_breaks = 5L, x_breaks = NULL, significance_level_shown = 0.05, width = waiver(), @@ -162,7 +165,7 @@ NULL no figures are saved, but are returned instead.} \item{p_adjustment_method}{(\emph{optional}) Indicates type of p-value that is shown. One of \code{holm}, \code{hochberg}, \code{hommel}, \code{bonferroni}, \code{BH}, \code{BY}, \code{fdr}, \code{none}, \code{p_value} or \code{q_value} for adjusted p-values, uncorrected -p-values and q-values. q-values may not be available.} +p-values} \item{split_by}{(\emph{optional}) Splitting variables. This refers to column names on which datasets are split. A separate figure is created for each split. @@ -187,14 +190,27 @@ wrapping. If NULL, a facet grid is produced instead.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette used to fill the bars in case a -non-singular variable was provided to the \code{color_by} argument.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{gradient_palette}{(\emph{optional}) Palette to use for filling the bars in case the \code{color_by} argument is not set. The bars are then coloured according to their importance. By default, no gradient is used, and the bars are not filled according to importance. Use \code{NULL} to fill the bars -using the default palette in \code{familiar}.} +using the default palette in \code{familiar}. Other palettes are supported by +the \code{paletteer} package, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -214,6 +230,10 @@ NULL, no subtitle is shown.} \item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no caption is shown.} +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + \item{x_range}{(\emph{optional}) Value range for the x-axis.} \item{x_n_breaks}{(\emph{optional}) Number of breaks to show on the x-axis of the @@ -251,7 +271,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -293,7 +314,7 @@ familiarCollection object. \details{ This function generates a horizontal barplot with the length of the bars corresponding to the 10-logarithm of the (multiple-testing corrected) -p-value or q-value. +p-value. Features are assessed univariately using one-sample location t-tests after fitting a suitable regression model. The fitted model coefficient and the @@ -302,27 +323,19 @@ covariance matrix are then used to compute a p-value. The following splitting variables are available for \code{split_by}, \code{color_by} and \code{facet_by}: \itemize{ -\item \code{fs_method}: feature selection methods +\item \code{vimp_method}: variable importance methods \item \code{learner}: learners \item \code{data_set}: data sets } -Unlike for plots of feature ranking in feature selection and after -modelling (as assessed by model-specific routines), clusters of features -are now found during creation of underlying \code{familiarData} objects, instead -of through consensus clustering. Hence, clustering results may differ due -to differences in the underlying datasets. - -Available palettes for \code{discrete_palette} and \code{gradient_palette} are those -listed by \code{grDevices::palette.pals()} (requires R >= 4.0.0), -\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, -\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the -palettes of the same name in \code{grDevices}. If not specified, a default -palette based on palettes in Tableau are used. You may also specify your -own palette by using colour names listed by \code{grDevices::colors()} or -through hexadecimal RGB strings. +Unlike for plots of feature ranking in initial variable importance +computation and after modelling (as assessed by model-specific routines), +clusters of features are now found during creation of underlying +\code{familiarData} objects, instead of through consensus clustering. Hence, +clustering results may differ due to differences in the underlying +datasets. -Labelling methods such as \code{set_fs_method_names} or \code{set_feature_names} can +Labelling methods such as \code{set_vimp_method_names} or \code{set_feature_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/plot_variable_importance-methods.Rd b/man/plot_variable_importance-methods.Rd index a9c54cfd..d640a377 100644 --- a/man/plot_variable_importance-methods.Rd +++ b/man/plot_variable_importance-methods.Rd @@ -37,8 +37,9 @@ plot_variable_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), @@ -73,8 +74,9 @@ plot_variable_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), @@ -109,8 +111,9 @@ plot_variable_importance( plot_title = waiver(), plot_sub_title = waiver(), caption = NULL, + limit_n_features = waiver(), y_range = NULL, - y_n_breaks = 5, + y_n_breaks = 5L, y_breaks = NULL, width = waiver(), height = waiver(), @@ -241,14 +244,27 @@ during feature selection.} \item{ggtheme}{(\emph{optional}) \code{ggplot} theme to use for plotting.} -\item{discrete_palette}{(\emph{optional}) Palette to use for coloring bar plots, -in case a non-singular variable was provided to the \code{color_by} argument.} - -\item{gradient_palette}{(\emph{optional}) Palette to use for filling the bars in -case the \code{color_by} argument is not set. The bars are then coloured -according to the occurrence of features. By default, no gradient is used, -and the bars are not filled according to occurrence. Use \code{NULL} to fill the -bars using the default palette in \code{familiar}.} +\item{discrete_palette}{(\emph{optional}) Palette for colouring the plot elements +according to the groupings indicated by the \code{color_by} argument (if any). +\code{familiar} has a default palette. Other palettes are supported by +\code{paletteer}, \code{grDevices::palette.pals()} (requires R >= 4.0.0), +\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, +\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the +palettes of the same name in \code{grDevices}. You may also specify your own +palette by providing a vector of colour names listed by +\code{grDevices::colors()} or through hexadecimal RGB strings.} + +\item{gradient_palette}{(\emph{optional}) Palette for filling bars if the +\code{color_by} argument is not set. By default, bars are not coloured. If +\code{gradient_palette} is set, the palette will colour bars according to +feature importance. Use \code{NULL} to fill the bars using the \code{familiar} +default palette. Other palettes are supported by the \code{paletteer} package, +\code{grDevices::palette.pals()} (requires R >= 4.0.0), \code{grDevices::hcl.pals()} +(requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, \code{terrain.colors}, +\code{topo.colors} and \code{cm.colors}, which correspond to the palettes of the same +name in \code{grDevices}. You may also specify your own palette by providing a +vector of colour names listed by \code{grDevices::colors()} or through +hexadecimal RGB strings.} \item{x_label}{(\emph{optional}) Label to provide to the x-axis. If NULL, no label is shown.} @@ -273,6 +289,10 @@ NULL, no subtitle is shown.} \item{caption}{(\emph{optional}) Label to provide as figure caption. If NULL, no caption is shown.} +\item{limit_n_features}{(\emph{optional}) The number of features that should be +included in the plot. Only the most important features are shown. By +default, the number of features is not limited.} + \item{y_range}{(\emph{optional}) Value range for the y-axis.} \item{y_n_breaks}{(\emph{optional}) Number of breaks to show on the y-axis of the @@ -305,7 +325,8 @@ parameter is one or more \code{familiarData} objects.} \code{NULL} (default), the device is guessed based on the \code{filename} extension.} \item{\code{scale}}{Multiplicative scaling factor.} \item{\code{dpi}}{Plot resolution. Also accepts a string input: "retina" (320), -"print" (300), or "screen" (72). Applies only to raster output types.} +"print" (300), or "screen" (72). Only applies when converting pixel units, +as is typical for raster output types.} \item{\code{limitsize}}{When \code{TRUE} (the default), \code{ggsave()} will not save images larger than 50x50 inches, to prevent the common error of specifying dimensions in pixels.} @@ -334,19 +355,10 @@ This function generates a barplot based on variable importance of features. The only allowed values for \code{split_by}, \code{color_by} or \code{facet_by} are -\code{fs_method} and \code{learner}, but note that \code{learner} has no effect when +\code{vimp_method} and \code{learner}, but note that \code{learner} has no effect when plotting variable importance of features acquired during feature selection. -Available palettes for \code{discrete_palette} and \code{gradient_palette} are those -listed by \code{grDevices::palette.pals()} (requires R >= 4.0.0), -\code{grDevices::hcl.pals()} (requires R >= 3.6.0) and \code{rainbow}, \code{heat.colors}, -\code{terrain.colors}, \code{topo.colors} and \code{cm.colors}, which correspond to the -palettes of the same name in \code{grDevices}. If not specified, a default -palette based on palettes in Tableau are used. You may also specify your -own palette by using colour names listed by \code{grDevices::colors()} or -through hexadecimal RGB strings. - -Labeling methods such as \code{set_feature_names} or \code{set_fs_method_names} can +Labeling methods such as \code{set_feature_names} or \code{set_vimp_method_names} can be applied to the \code{familiarCollection} object to update labels, and order the output in the figure. } diff --git a/man/precompute_data_assignment.Rd b/man/precompute_data_assignment.Rd index e6bcf214..65862908 100644 --- a/man/precompute_data_assignment.Rd +++ b/man/precompute_data_assignment.Rd @@ -35,7 +35,9 @@ In case paths are provided, the data should be stored as \code{csv}, \code{rds} \code{RData} files. See documentation for the \code{data_files} argument for more information.} -\item{experiment_data}{Experimental data may provided in the form of} +\item{experiment_data}{Experimental data may provided in the form of the +output of \code{precompute_data_assignment}, \code{precompute_feature_info} or +\code{precompute_vimp}. This allows for warm-starting experiments.} \item{cl}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallelisation. When a cluster is not @@ -46,10 +48,12 @@ This parameter has no effect if the \code{parallel} argument is set to \code{FAL \item{experimental_design}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building. The basic workflow components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (optional) variable importance computation step. If not explicitly +declared, feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. \item \code{ev}: (optional) external validation. If validation batches or cohorts are present in the dataset (\code{data}), these should be indicated in the @@ -122,7 +126,7 @@ sample or subject identifiers. See \code{batch_id_column} above for more details. If unset, every row will be identified as a single sample.} - \item{\code{series_id_column}}{(\strong{optional}) Name of the column containing series + \item{\code{series_id_column}}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -142,8 +146,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{\code{outcome_column}}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is provided as an argument. Otherwise an error is raised. Note that \code{survival} @@ -152,13 +156,12 @@ indicate the time-to-event or the time of last follow-up and the event status.} \item{\code{outcome_type}}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -168,7 +171,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{\code{class_levels}}{(\emph{optional}) Class levels for \code{binomial} or \code{multinomial} outcomes. This argument can be used to specify the ordering of levels for categorical outcomes. These class levels must exactly match the levels @@ -189,7 +193,7 @@ unset, all values other than those specified by the \code{event_indicator} and risks.} \item{\code{signature}}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{\code{novelty_features}}{(\emph{optional}) One or more names of feature columns that should be included for the purpose of novelty detection.} @@ -234,6 +238,10 @@ that defines the design.} \item{\code{imbalance_n_partitions}}{(\emph{optional}) Number of times random undersampling should be repeated. 10 undersampled subsets with balanced classes are formed by default.} + \item{\code{iteration_seed}}{(\emph{optional}) Integer seed used in sampling algorithms +specified by the \code{experimental_design} argument. This allows for creating +the same sample assignments across different experiments -- of course +provided that the same dataset is used. By default a random seed is used.} \item{\code{parallel}}{(\emph{optional}) Enable parallel processing. Defaults to \code{TRUE}. When set to \code{FALSE}, this disables all parallel processing, regardless of specific parameters such as \code{parallel_preprocessing}. However, when @@ -288,7 +296,7 @@ Several method are available: filter, for example, genes that are not differentially expressed. \item \code{univariate_test}: Features undergo a univariate regression using an outcome-appropriate regression model. The p-value of the model coefficient -is collected. Features with coefficient p or q-value above the +is collected. Features with coefficient p-value above the \code{univariate_test_threshold} are subsequently filtered. \item \code{robustness}: Features that are not sufficiently robust according to the intraclass correlation coefficient are filtered. Use of this method @@ -300,18 +308,15 @@ More than one method can be used simultaneously. Features with singular values are always filtered, as these do not contain information.} \item{\code{univariate_test_threshold}}{(\emph{optional}) Numeric value between \code{1.0} and \code{0.0} that determines which features are irrelevant and will be filtered by -the \code{univariate_test}. The p or q-values are compared to this threshold. +the \code{univariate_test}. p-values are compared to this threshold. All features with values above the threshold are filtered. The default value is \code{0.20}.} \item{\code{univariate_test_threshold_metric}}{(\emph{optional}) Metric used with the to -compare the \code{univariate_test_threshold} against. The following metrics can +compare the \code{univariate_test_threshold} against. The following metric can be chosen: \itemize{ \item \code{p_value} (default): The unadjusted p-value of each feature is used for to filter features. -\item \code{q_value}: The q-value (Story, 2002), is used to filter features. Some -data sets may have insufficient samples to compute the q-value. The -\code{qvalue} package must be installed from Bioconductor to use this method. }} \item{\code{univariate_test_max_feature_set_size}}{(\emph{optional}) Maximum size of the feature set after the univariate test. P or q values of features are @@ -362,7 +367,7 @@ methods are available: \item \code{none}: This disables transformation of features. \item \code{yeo_johnson}: Transformation using the location and scale invariant version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -Zwanenburg and Löck, 2023). +Zwanenburg and Löck, 2026). \item \code{yeo_johnson_robust} (default): A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{yeo_johnson_conventional}: As \code{yeo_johnson}, but without optimisation of @@ -370,7 +375,7 @@ location and scale parameters. This method is equivalent to the original transformation proposed by Yeo and Johnson (2001). \item \code{box_cox}: Transformation using the location and scale invariant version of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -2023). +2026). \item \code{box_cox_robust}: A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{box_cox_conventional}: As \code{box_cox}, but without optimisation of @@ -390,12 +395,12 @@ optimisation criteria, of which the following are available: \itemize{ \item \code{mle} (default): Optimisation using maximum likelihood estimation. \item \code{cramer_von_mises}: Optimisation using the Cramér-von Mises -criterion. Zwanenburg and Löck (2023) found that this criterion was +criterion. Zwanenburg and Löck (2026) found that this criterion was relatively robust against outliers. }} \item{\code{transformation_gof_test_p_value}}{(\emph{optional}) Not all transformations will lead to features that are roughly normally distributed. Zwanenburg and -Löck (2023) established a empirical goodness-of-fit test for central +Löck (2026) established a empirical goodness-of-fit test for central normality. This parameter sets the significance for rejecting the null-hypothesis that a feature distribution is centrally normal. When the null-hypothesis is rejected, no transformation is performed. The default diff --git a/man/precompute_feature_info.Rd b/man/precompute_feature_info.Rd index 98909b84..b45ac461 100644 --- a/man/precompute_feature_info.Rd +++ b/man/precompute_feature_info.Rd @@ -35,7 +35,9 @@ In case paths are provided, the data should be stored as \code{csv}, \code{rds} \code{RData} files. See documentation for the \code{data_files} argument for more information.} -\item{experiment_data}{Experimental data may provided in the form of} +\item{experiment_data}{Experimental data may provided in the form of the +output of \code{precompute_data_assignment}, \code{precompute_feature_info} or +\code{precompute_vimp}. This allows for warm-starting experiments.} \item{cl}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallelisation. When a cluster is not @@ -46,10 +48,12 @@ This parameter has no effect if the \code{parallel} argument is set to \code{FAL \item{experimental_design}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building. The basic workflow components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (optional) variable importance computation step. If not explicitly +declared, feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. \item \code{ev}: (optional) external validation. If validation batches or cohorts are present in the dataset (\code{data}), these should be indicated in the @@ -124,7 +128,7 @@ sample or subject identifiers. See \code{batch_id_column} above for more details. If unset, every row will be identified as a single sample.} - \item{\code{series_id_column}}{(\strong{optional}) Name of the column containing series + \item{\code{series_id_column}}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -144,8 +148,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{\code{outcome_column}}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is provided as an argument. Otherwise an error is raised. Note that \code{survival} @@ -154,13 +158,12 @@ indicate the time-to-event or the time of last follow-up and the event status.} \item{\code{outcome_type}}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -170,7 +173,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{\code{class_levels}}{(\emph{optional}) Class levels for \code{binomial} or \code{multinomial} outcomes. This argument can be used to specify the ordering of levels for categorical outcomes. These class levels must exactly match the levels @@ -191,7 +195,7 @@ unset, all values other than those specified by the \code{event_indicator} and risks.} \item{\code{signature}}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{\code{novelty_features}}{(\emph{optional}) One or more names of feature columns that should be included for the purpose of novelty detection.} @@ -236,6 +240,10 @@ that defines the design.} \item{\code{imbalance_n_partitions}}{(\emph{optional}) Number of times random undersampling should be repeated. 10 undersampled subsets with balanced classes are formed by default.} + \item{\code{iteration_seed}}{(\emph{optional}) Integer seed used in sampling algorithms +specified by the \code{experimental_design} argument. This allows for creating +the same sample assignments across different experiments -- of course +provided that the same dataset is used. By default a random seed is used.} \item{\code{parallel}}{(\emph{optional}) Enable parallel processing. Defaults to \code{TRUE}. When set to \code{FALSE}, this disables all parallel processing, regardless of specific parameters such as \code{parallel_preprocessing}. However, when @@ -290,7 +298,7 @@ Several method are available: filter, for example, genes that are not differentially expressed. \item \code{univariate_test}: Features undergo a univariate regression using an outcome-appropriate regression model. The p-value of the model coefficient -is collected. Features with coefficient p or q-value above the +is collected. Features with coefficient p-value above the \code{univariate_test_threshold} are subsequently filtered. \item \code{robustness}: Features that are not sufficiently robust according to the intraclass correlation coefficient are filtered. Use of this method @@ -302,18 +310,15 @@ More than one method can be used simultaneously. Features with singular values are always filtered, as these do not contain information.} \item{\code{univariate_test_threshold}}{(\emph{optional}) Numeric value between \code{1.0} and \code{0.0} that determines which features are irrelevant and will be filtered by -the \code{univariate_test}. The p or q-values are compared to this threshold. +the \code{univariate_test}. p-values are compared to this threshold. All features with values above the threshold are filtered. The default value is \code{0.20}.} \item{\code{univariate_test_threshold_metric}}{(\emph{optional}) Metric used with the to -compare the \code{univariate_test_threshold} against. The following metrics can +compare the \code{univariate_test_threshold} against. The following metric can be chosen: \itemize{ \item \code{p_value} (default): The unadjusted p-value of each feature is used for to filter features. -\item \code{q_value}: The q-value (Story, 2002), is used to filter features. Some -data sets may have insufficient samples to compute the q-value. The -\code{qvalue} package must be installed from Bioconductor to use this method. }} \item{\code{univariate_test_max_feature_set_size}}{(\emph{optional}) Maximum size of the feature set after the univariate test. P or q values of features are @@ -364,7 +369,7 @@ methods are available: \item \code{none}: This disables transformation of features. \item \code{yeo_johnson}: Transformation using the location and scale invariant version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -Zwanenburg and Löck, 2023). +Zwanenburg and Löck, 2026). \item \code{yeo_johnson_robust} (default): A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{yeo_johnson_conventional}: As \code{yeo_johnson}, but without optimisation of @@ -372,7 +377,7 @@ location and scale parameters. This method is equivalent to the original transformation proposed by Yeo and Johnson (2001). \item \code{box_cox}: Transformation using the location and scale invariant version of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -2023). +2026). \item \code{box_cox_robust}: A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{box_cox_conventional}: As \code{box_cox}, but without optimisation of @@ -392,12 +397,12 @@ optimisation criteria, of which the following are available: \itemize{ \item \code{mle} (default): Optimisation using maximum likelihood estimation. \item \code{cramer_von_mises}: Optimisation using the Cramér-von Mises -criterion. Zwanenburg and Löck (2023) found that this criterion was +criterion. Zwanenburg and Löck (2026) found that this criterion was relatively robust against outliers. }} \item{\code{transformation_gof_test_p_value}}{(\emph{optional}) Not all transformations will lead to features that are roughly normally distributed. Zwanenburg and -Löck (2023) established a empirical goodness-of-fit test for central +Löck (2026) established a empirical goodness-of-fit test for central normality. This parameter sets the significance for rejecting the null-hypothesis that a feature distribution is centrally normal. When the null-hypothesis is rejected, no transformation is performed. The default diff --git a/man/precompute_vimp.Rd b/man/precompute_vimp.Rd index 6e9891bf..c68af9bf 100644 --- a/man/precompute_vimp.Rd +++ b/man/precompute_vimp.Rd @@ -10,8 +10,8 @@ precompute_vimp( experiment_data = NULL, cl = NULL, experimental_design = "fs+mb", - fs_method = NULL, - fs_method_parameter = NULL, + vimp_method = NULL, + vimp_method_parameter = NULL, verbose = TRUE, ... ) @@ -37,7 +37,9 @@ In case paths are provided, the data should be stored as \code{csv}, \code{rds} \code{RData} files. See documentation for the \code{data_files} argument for more information.} -\item{experiment_data}{Experimental data may provided in the form of} +\item{experiment_data}{Experimental data may provided in the form of the +output of \code{precompute_data_assignment}, \code{precompute_feature_info} or +\code{precompute_vimp}. This allows for warm-starting experiments.} \item{cl}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallelisation. When a cluster is not @@ -48,10 +50,13 @@ This parameter has no effect if the \code{parallel} argument is set to \code{FAL \item{experimental_design}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building. The basic workflow components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (required) variable importance computation step. No variable +importances will be prepared if this step is not explicitly used, instead, +feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. Though models are not learned by \code{precompute_vimp}, this element is still required to prevent issues when using the resulting \code{experimentData} object to warm-start the experiments. @@ -90,19 +95,18 @@ dataset. This argument is ignored if the \code{experiment_data} argument is set.} -\item{fs_method}{(\strong{required}) Feature selection method to be used for -determining variable importance. \code{familiar} implements various feature -selection methods. Please refer to the vignette on feature selection -methods for more details. +\item{vimp_method}{(\strong{required}) Variable importance method. \code{familiar} +implements various variable importance methods. Please refer to the +vignette on variable importance methods for more details. -More than one feature selection method can be chosen. The experiment will +More than one variable importance method can be chosen. The experiment will then repeated for each feature selection method. -Feature selection methods determines the ranking of features. Actual +Variable importance methods determine the ranking of features. Actual selection of features is done by optimising the signature size model hyperparameter during the hyperparameter optimisation step.} -\item{fs_method_parameter}{(\emph{optional}) List of lists containing parameters +\item{vimp_method_parameter}{(\emph{optional}) List of lists containing parameters for feature selection methods. Each sublist should have the name of the feature selection method it corresponds to. @@ -116,7 +120,7 @@ assessing variable importance.} messages and warnings are returned.} \item{...}{ - Arguments passed on to \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}}, \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_feature_selection_settings]{.parse_feature_selection_settings}} + Arguments passed on to \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}}, \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_variable_importance_settings]{.parse_variable_importance_settings}} \describe{ \item{\code{batch_id_column}}{(\strong{recommended}) Name of the column containing batch or cohort identifiers. This parameter is required if more than one dataset @@ -145,7 +149,7 @@ sample or subject identifiers. See \code{batch_id_column} above for more details. If unset, every row will be identified as a single sample.} - \item{\code{series_id_column}}{(\strong{optional}) Name of the column containing series + \item{\code{series_id_column}}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -165,8 +169,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{\code{outcome_column}}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is provided as an argument. Otherwise an error is raised. Note that \code{survival} @@ -175,13 +179,12 @@ indicate the time-to-event or the time of last follow-up and the event status.} \item{\code{outcome_type}}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -191,7 +194,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{\code{class_levels}}{(\emph{optional}) Class levels for \code{binomial} or \code{multinomial} outcomes. This argument can be used to specify the ordering of levels for categorical outcomes. These class levels must exactly match the levels @@ -212,7 +216,7 @@ unset, all values other than those specified by the \code{event_indicator} and risks.} \item{\code{signature}}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{\code{novelty_features}}{(\emph{optional}) One or more names of feature columns that should be included for the purpose of novelty detection.} @@ -257,6 +261,10 @@ that defines the design.} \item{\code{imbalance_n_partitions}}{(\emph{optional}) Number of times random undersampling should be repeated. 10 undersampled subsets with balanced classes are formed by default.} + \item{\code{iteration_seed}}{(\emph{optional}) Integer seed used in sampling algorithms +specified by the \code{experimental_design} argument. This allows for creating +the same sample assignments across different experiments -- of course +provided that the same dataset is used. By default a random seed is used.} \item{\code{parallel}}{(\emph{optional}) Enable parallel processing. Defaults to \code{TRUE}. When set to \code{FALSE}, this disables all parallel processing, regardless of specific parameters such as \code{parallel_preprocessing}. However, when @@ -311,7 +319,7 @@ Several method are available: filter, for example, genes that are not differentially expressed. \item \code{univariate_test}: Features undergo a univariate regression using an outcome-appropriate regression model. The p-value of the model coefficient -is collected. Features with coefficient p or q-value above the +is collected. Features with coefficient p-value above the \code{univariate_test_threshold} are subsequently filtered. \item \code{robustness}: Features that are not sufficiently robust according to the intraclass correlation coefficient are filtered. Use of this method @@ -323,18 +331,15 @@ More than one method can be used simultaneously. Features with singular values are always filtered, as these do not contain information.} \item{\code{univariate_test_threshold}}{(\emph{optional}) Numeric value between \code{1.0} and \code{0.0} that determines which features are irrelevant and will be filtered by -the \code{univariate_test}. The p or q-values are compared to this threshold. +the \code{univariate_test}. p-values are compared to this threshold. All features with values above the threshold are filtered. The default value is \code{0.20}.} \item{\code{univariate_test_threshold_metric}}{(\emph{optional}) Metric used with the to -compare the \code{univariate_test_threshold} against. The following metrics can +compare the \code{univariate_test_threshold} against. The following metric can be chosen: \itemize{ \item \code{p_value} (default): The unadjusted p-value of each feature is used for to filter features. -\item \code{q_value}: The q-value (Story, 2002), is used to filter features. Some -data sets may have insufficient samples to compute the q-value. The -\code{qvalue} package must be installed from Bioconductor to use this method. }} \item{\code{univariate_test_max_feature_set_size}}{(\emph{optional}) Maximum size of the feature set after the univariate test. P or q values of features are @@ -385,7 +390,7 @@ methods are available: \item \code{none}: This disables transformation of features. \item \code{yeo_johnson}: Transformation using the location and scale invariant version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -Zwanenburg and Löck, 2023). +Zwanenburg and Löck, 2026). \item \code{yeo_johnson_robust} (default): A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{yeo_johnson_conventional}: As \code{yeo_johnson}, but without optimisation of @@ -393,7 +398,7 @@ location and scale parameters. This method is equivalent to the original transformation proposed by Yeo and Johnson (2001). \item \code{box_cox}: Transformation using the location and scale invariant version of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -2023). +2026). \item \code{box_cox_robust}: A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{box_cox_conventional}: As \code{box_cox}, but without optimisation of @@ -413,12 +418,12 @@ optimisation criteria, of which the following are available: \itemize{ \item \code{mle} (default): Optimisation using maximum likelihood estimation. \item \code{cramer_von_mises}: Optimisation using the Cramér-von Mises -criterion. Zwanenburg and Löck (2023) found that this criterion was +criterion. Zwanenburg and Löck (2026) found that this criterion was relatively robust against outliers. }} \item{\code{transformation_gof_test_p_value}}{(\emph{optional}) Not all transformations will lead to features that are roughly normally distributed. Zwanenburg and -Löck (2023) established a empirical goodness-of-fit test for central +Löck (2026) established a empirical goodness-of-fit test for central normality. This parameter sets the significance for rejecting the null-hypothesis that a feature distribution is centrally normal. When the null-hypothesis is rejected, no transformation is performed. The default @@ -666,11 +671,46 @@ preprocessing workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, this disable the use of parallel processing while preprocessing, regardless of the settings of the \code{parallel} parameter. \code{parallel_preprocessing} is ignored if \code{parallel=FALSE}.} - \item{\code{parallel_feature_selection}}{(\emph{optional}) Enable parallel processing for -the feature selection workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, -this will disable the use of parallel processing while performing feature -selection, regardless of the settings of the \code{parallel} parameter. -\code{parallel_feature_selection} is ignored if \code{parallel=FALSE}.} + \item{\code{config}}{A list of settings, e.g. from an xml file.} + \item{\code{vimp_aggregation_method}}{(\emph{optional}) The method used to aggregate +variable importances over different data subsets, e.g. bootstraps. The +following methods can be selected: +\itemize{ +\item \code{none}: Don't aggregate ranks, but rather aggregate the variable +importance scores themselves. +\item \code{mean}: Use the mean rank of a feature over the subsets to +determine the aggregated feature rank. +\item \code{median}: Use the median rank of a feature over the subsets to determine +the aggregated feature rank. +\item \code{best}: Use the best rank the feature obtained in any subset to determine +the aggregated feature rank. +\item \code{worst}: Use the worst rank the feature obtained in any subset to +determine the aggregated feature rank. +\item \code{stability}: Use the frequency of the feature being in the subset of +highly ranked features as measure for the aggregated feature rank +(Meinshausen and Buehlmann, 2010). +\item \code{exponential}: Use a rank-weighted frequence of occurrence in the subset +of highly ranked features as measure for the aggregated feature rank (Haury +et al., 2011). +\item \code{borda} (default): Use the borda count as measure for the aggregated +feature rank (Wald et al., 2012). +\item \code{enhanced_borda}: Use an occurrence frequency-weighted borda count as +measure for the aggregated feature rank (Wald et al., 2012). +\item \code{truncated_borda}: Use borda count computed only on features within the +subset of highly ranked features. +\item \code{enhanced_truncated_borda}: Apply both the enhanced borda method and the +truncated borda method and use the resulting borda count as the aggregated +feature rank. +} + +The \emph{feature selection methods} vignette provides additional information.} + \item{\code{vimp_aggregation_rank_threshold}}{(\emph{optional}) The threshold used to +define the subset of highly important features. If set to \code{NULL}, this +threshold is determined by maximising the variance in the occurrence value +over all features over the subset size. The default value is \code{5}. + +This parameter is only relevant for \code{stability}, \code{exponential}, +\code{enhanced_borda}, \code{truncated_borda} and \code{enhanced_truncated_borda} methods.} }} } \value{ diff --git a/man/predict-methods.Rd b/man/predict-methods.Rd index 09d1f622..5b873704 100644 --- a/man/predict-methods.Rd +++ b/man/predict-methods.Rd @@ -21,6 +21,7 @@ predict(object, ...) stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, + .as_prediction_table = FALSE, ... ) @@ -34,10 +35,18 @@ predict(object, ...) stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, + .as_prediction_table = FALSE, ... ) -\S4method{predict}{familiarNoveltyDetector}(object, newdata, type = "novelty", ...) +\S4method{predict}{familiarNoveltyDetector}( + object, + newdata, + type = "novelty", + ensemble_method = "median", + .as_prediction_table = FALSE, + ... +) \S4method{predict}{list}( object, @@ -49,6 +58,7 @@ predict(object, ...) stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, + .as_prediction_table = FALSE, ... ) @@ -62,6 +72,7 @@ predict(object, ...) stratification_threshold = NULL, stratification_method = NULL, percentiles = NULL, + .as_prediction_table = FALSE, ... ) } @@ -81,10 +92,9 @@ features. Unlike other \code{predict} methods, \code{newdata} cannot be missing \item{type}{Type of prediction made. The following values are directly supported: \itemize{ -\item \code{default}: Default prediction, i.e. value estimates for \code{count} and -\code{continuous} outcomes, predicted class probabilities and class for -\code{binomial} and \code{multinomial} and the model response for \code{survival} -outcomes. +\item \code{default}: Default prediction, i.e. value estimates for \code{continuous} +outcomes, predicted class probabilities and class for \code{binomial} and +\code{multinomial} and the model response for \code{survival} outcomes. \item \code{survival_probability}: Predicts survival probabilities at the time specified by \code{time}. Only applicable to \code{survival} outcomes. Some models may not allow for predicting survival probabilities based on their @@ -132,6 +142,9 @@ In addition this argument is ignored if a \code{stratification_threshold} is set.} \item{percentiles}{Currently unused.} + +\item{.as_prediction_table}{Selects whether a data.table or prediction table +object should be returned.} } \value{ A \code{data.table} with predicted values. diff --git a/man/set_object_name-familiarNoveltyDetector-method.Rd b/man/set_object_name-familiarNoveltyDetector-method.Rd new file mode 100644 index 00000000..50ecdc97 --- /dev/null +++ b/man/set_object_name-familiarNoveltyDetector-method.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/FamiliarNoveltyDetector.R +\name{set_object_name,familiarNoveltyDetector-method} +\alias{set_object_name,familiarNoveltyDetector-method} +\title{Set the name of a \code{familiarNoveltyDetector} object.} +\usage{ +\S4method{set_object_name}{familiarNoveltyDetector}(x, new = NULL) +} +\arguments{ +\item{x}{A \code{familiarNoveltyDetector} object.} +} +\value{ +A \code{familiarNoveltyDetector} object with a generated or a provided name. +} +\description{ +Set the \code{name} slot using the object name. +} +\keyword{internal} diff --git a/man/set_fs_method_names-familiarCollection-method.Rd b/man/set_vimp_method_names-familiarCollection-method.Rd similarity index 64% rename from man/set_fs_method_names-familiarCollection-method.Rd rename to man/set_vimp_method_names-familiarCollection-method.Rd index 49ede4d5..d6c6ac84 100644 --- a/man/set_fs_method_names-familiarCollection-method.Rd +++ b/man/set_vimp_method_names-familiarCollection-method.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/FamiliarCollection.R -\name{set_fs_method_names,familiarCollection-method} -\alias{set_fs_method_names,familiarCollection-method} -\alias{set_fs_method_names} -\title{Rename feature selection methods for plotting and export} +\name{set_vimp_method_names,familiarCollection-method} +\alias{set_vimp_method_names,familiarCollection-method} +\alias{set_vimp_method_names} +\title{Rename variable importance methods for plotting and export} \usage{ -\S4method{set_fs_method_names}{familiarCollection}(x, old = NULL, new = NULL, order = NULL) +\S4method{set_vimp_method_names}{familiarCollection}(x, old = NULL, new = NULL, order = NULL) } \arguments{ \item{x}{A familiarCollection object.} @@ -27,20 +27,20 @@ A familiarCollection object with updated labels. } \description{ Tabular exports and figures created from a familiarCollection -object can be customised by providing names for the feature selection +object can be customised by providing names for the variable importance methods. } \details{ -Labels convert the internal naming for feature selection methods to -the requested label at export or when plotting. This enables the use of +Labels convert the internal naming for variable importance methods +to the requested label at export or when plotting. This enables the use of more specific naming, e.g. changing \code{mim} to \code{Mutual Information Maximisation}. Currently assigned labels can be found using the -\code{get_fs_method_names} method. +\code{get_vimp_method_names} method. } \seealso{ \itemize{ \item \linkS4class{familiarCollection} for information concerning the -familiarCollection class. * \code{\link{get_fs_method_names}} for obtaining +familiarCollection class. * \code{\link{get_vimp_method_names}} for obtaining currently assigned labels. } } diff --git a/man/summon_familiar.Rd b/man/summon_familiar.Rd index e0d61404..04eb3261 100644 --- a/man/summon_familiar.Rd +++ b/man/summon_familiar.Rd @@ -12,7 +12,8 @@ summon_familiar( config = NULL, config_id = 1L, verbose = TRUE, - .stop_after = "evaluation", + .stop_after = "export", + .force_output = FALSE, ... ) } @@ -37,7 +38,9 @@ In case paths are provided, the data should be stored as \code{csv}, \code{rds} \code{RData} files. See documentation for the \code{data_files} argument for more information.} -\item{experiment_data}{Experimental data may provided in the form of} +\item{experiment_data}{Experimental data may provided in the form of the +output of \code{precompute_data_assignment}, \code{precompute_feature_info} or +\code{precompute_vimp}. This allows for warm-starting experiments.} \item{cl}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallelisation. When a cluster is not @@ -61,8 +64,11 @@ messages and warnings are returned.} \item{.stop_after}{Variable for internal use.} +\item{.force_output}{Generates output even if results have been written to +the file system.} + \item{...}{ - Arguments passed on to \code{\link[=.parse_file_paths]{.parse_file_paths}}, \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}}, \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_feature_selection_settings]{.parse_feature_selection_settings}}, \code{\link[=.parse_model_development_settings]{.parse_model_development_settings}}, \code{\link[=.parse_hyperparameter_optimisation_settings]{.parse_hyperparameter_optimisation_settings}}, \code{\link[=.parse_evaluation_settings]{.parse_evaluation_settings}} + Arguments passed on to \code{\link[=.parse_file_paths]{.parse_file_paths}}, \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}}, \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_variable_importance_settings]{.parse_variable_importance_settings}}, \code{\link[=.parse_model_development_settings]{.parse_model_development_settings}}, \code{\link[=.parse_hyperparameter_optimisation_settings]{.parse_hyperparameter_optimisation_settings}}, \code{\link[=.parse_evaluation_settings]{.parse_evaluation_settings}} \describe{ \item{\code{project_dir}}{(\emph{optional}) Path to the project directory. \code{familiar} checks if the directory indicated by \code{experiment_dir} and data files in @@ -131,7 +137,7 @@ sample or subject identifiers. See \code{batch_id_column} above for more details. If unset, every row will be identified as a single sample.} - \item{\code{series_id_column}}{(\strong{optional}) Name of the column containing series + \item{\code{series_id_column}}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -151,8 +157,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{\code{outcome_column}}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is provided as an argument. Otherwise an error is raised. Note that \code{survival} @@ -161,13 +167,12 @@ indicate the time-to-event or the time of last follow-up and the event status.} \item{\code{outcome_type}}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -177,7 +182,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{\code{class_levels}}{(\emph{optional}) Class levels for \code{binomial} or \code{multinomial} outcomes. This argument can be used to specify the ordering of levels for categorical outcomes. These class levels must exactly match the levels @@ -198,7 +204,7 @@ unset, all values other than those specified by the \code{event_indicator} and risks.} \item{\code{signature}}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{\code{novelty_features}}{(\emph{optional}) One or more names of feature columns that should be included for the purpose of novelty detection.} @@ -228,10 +234,13 @@ prior to familiar version 1.3.0. }} \item{\code{experimental_design}}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)+ev} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building, and external validation. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building, and external validation. The basic workflow +components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (optional) variable importance computation step. If not explicitly +declared, feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. \item \code{ev}: (optional) external validation. Note that internal validation due to subsampling will always be conducted if the subsampling methods create @@ -294,6 +303,10 @@ that defines the design.} \item{\code{imbalance_n_partitions}}{(\emph{optional}) Number of times random undersampling should be repeated. 10 undersampled subsets with balanced classes are formed by default.} + \item{\code{iteration_seed}}{(\emph{optional}) Integer seed used in sampling algorithms +specified by the \code{experimental_design} argument. This allows for creating +the same sample assignments across different experiments -- of course +provided that the same dataset is used. By default a random seed is used.} \item{\code{parallel}}{(\emph{optional}) Enable parallel processing. Defaults to \code{TRUE}. When set to \code{FALSE}, this disables all parallel processing, regardless of specific parameters such as \code{parallel_preprocessing}. However, when @@ -348,7 +361,7 @@ Several method are available: filter, for example, genes that are not differentially expressed. \item \code{univariate_test}: Features undergo a univariate regression using an outcome-appropriate regression model. The p-value of the model coefficient -is collected. Features with coefficient p or q-value above the +is collected. Features with coefficient p-value above the \code{univariate_test_threshold} are subsequently filtered. \item \code{robustness}: Features that are not sufficiently robust according to the intraclass correlation coefficient are filtered. Use of this method @@ -360,18 +373,15 @@ More than one method can be used simultaneously. Features with singular values are always filtered, as these do not contain information.} \item{\code{univariate_test_threshold}}{(\emph{optional}) Numeric value between \code{1.0} and \code{0.0} that determines which features are irrelevant and will be filtered by -the \code{univariate_test}. The p or q-values are compared to this threshold. +the \code{univariate_test}. p-values are compared to this threshold. All features with values above the threshold are filtered. The default value is \code{0.20}.} \item{\code{univariate_test_threshold_metric}}{(\emph{optional}) Metric used with the to -compare the \code{univariate_test_threshold} against. The following metrics can +compare the \code{univariate_test_threshold} against. The following metric can be chosen: \itemize{ \item \code{p_value} (default): The unadjusted p-value of each feature is used for to filter features. -\item \code{q_value}: The q-value (Story, 2002), is used to filter features. Some -data sets may have insufficient samples to compute the q-value. The -\code{qvalue} package must be installed from Bioconductor to use this method. }} \item{\code{univariate_test_max_feature_set_size}}{(\emph{optional}) Maximum size of the feature set after the univariate test. P or q values of features are @@ -422,7 +432,7 @@ methods are available: \item \code{none}: This disables transformation of features. \item \code{yeo_johnson}: Transformation using the location and scale invariant version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -Zwanenburg and Löck, 2023). +Zwanenburg and Löck, 2026). \item \code{yeo_johnson_robust} (default): A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{yeo_johnson_conventional}: As \code{yeo_johnson}, but without optimisation of @@ -430,7 +440,7 @@ location and scale parameters. This method is equivalent to the original transformation proposed by Yeo and Johnson (2001). \item \code{box_cox}: Transformation using the location and scale invariant version of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -2023). +2026). \item \code{box_cox_robust}: A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{box_cox_conventional}: As \code{box_cox}, but without optimisation of @@ -450,12 +460,12 @@ optimisation criteria, of which the following are available: \itemize{ \item \code{mle} (default): Optimisation using maximum likelihood estimation. \item \code{cramer_von_mises}: Optimisation using the Cramér-von Mises -criterion. Zwanenburg and Löck (2023) found that this criterion was +criterion. Zwanenburg and Löck (2026) found that this criterion was relatively robust against outliers. }} \item{\code{transformation_gof_test_p_value}}{(\emph{optional}) Not all transformations will lead to features that are roughly normally distributed. Zwanenburg and -Löck (2023) established a empirical goodness-of-fit test for central +Löck (2026) established a empirical goodness-of-fit test for central normality. This parameter sets the significance for rejecting the null-hypothesis that a feature distribution is centrally normal. When the null-hypothesis is rejected, no transformation is performed. The default @@ -703,18 +713,17 @@ preprocessing workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, this disable the use of parallel processing while preprocessing, regardless of the settings of the \code{parallel} parameter. \code{parallel_preprocessing} is ignored if \code{parallel=FALSE}.} - \item{\code{fs_method}}{(\strong{required}) Feature selection method to be used for -determining variable importance. \code{familiar} implements various feature -selection methods. Please refer to the vignette on feature selection -methods for more details. + \item{\code{vimp_method}}{(\strong{required}) Variable importance method. \code{familiar} +implements various variable importance methods. Please refer to the +vignette on variable importance methods for more details. -More than one feature selection method can be chosen. The experiment will +More than one variable importance method can be chosen. The experiment will then repeated for each feature selection method. -Feature selection methods determines the ranking of features. Actual +Variable importance methods determine the ranking of features. Actual selection of features is done by optimising the signature size model hyperparameter during the hyperparameter optimisation step.} - \item{\code{fs_method_parameter}}{(\emph{optional}) List of lists containing parameters + \item{\code{vimp_method_parameter}}{(\emph{optional}) List of lists containing parameters for feature selection methods. Each sublist should have the name of the feature selection method it corresponds to. @@ -756,17 +765,17 @@ feature rank. The \emph{feature selection methods} vignette provides additional information.} \item{\code{vimp_aggregation_rank_threshold}}{(\emph{optional}) The threshold used to -define the subset of highly important features. If not set, this threshold -is determined by maximising the variance in the occurrence value over all -features over the subset size. +define the subset of highly important features. If set to \code{NULL}, this +threshold is determined by maximising the variance in the occurrence value +over all features over the subset size. The default value is \code{5}. This parameter is only relevant for \code{stability}, \code{exponential}, \code{enhanced_borda}, \code{truncated_borda} and \code{enhanced_truncated_borda} methods.} - \item{\code{parallel_feature_selection}}{(\emph{optional}) Enable parallel processing for -the feature selection workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, + \item{\code{parallel_vimp}}{(\emph{optional}) Enable parallel processing for +variable importance tasks. Defaults to \code{TRUE}. When set to \code{FALSE}, this will disable the use of parallel processing while performing feature selection, regardless of the settings of the \code{parallel} parameter. -\code{parallel_feature_selection} is ignored if \code{parallel=FALSE}.} +\code{parallel_vimp} is ignored if \code{parallel = FALSE}.} \item{\code{learner}}{(\strong{required}) One or more algorithms used for model development. A sizeable number learners is supported in \code{familiar}. Please see the vignette on learners for more information concerning the available @@ -805,16 +814,17 @@ finish before exhausting the set of bootstraps.} \item{\code{optimisation_determine_vimp}}{(\emph{optional}) Logical value that indicates whether variable importance is determined separately for each of the bootstraps created during the optimisation process (\code{TRUE}) or the -applicable results from the feature selection step are used (\code{FALSE}). +applicable results from the variable importance computation step are used +(\code{FALSE}). Determining variable importance increases the initial computational overhead. However, it prevents positive biases for the out-of-bag data due to overlap of these data with the development data set used for the feature selection step. In this case, any hyperparameters of the variable importance method are not determined separately for each bootstrap, but -those obtained during the feature selection step are used instead. In case -multiple of such hyperparameter sets could be applicable, the set that will -be used is randomly selected for each bootstrap. +those obtained during the variable importance computation step are used +instead. In case multiple of such hyperparameter sets could be applicable, +the set that will be used is randomly selected for each bootstrap. This parameter only affects hyperparameter optimisation of learners. The default is \code{TRUE}.} @@ -898,7 +908,6 @@ If unset, the following metrics are used by default: \itemize{ \item \code{auc_roc}: For \code{binomial} and \code{multinomial} models. \item \code{mse}: Mean squared error for \code{continuous} models. -\item \code{msle}: Mean squared logarithmic error for \code{count} models. \item \code{concordance_index}: For \code{survival} models. } @@ -1042,48 +1051,63 @@ are not computed and shown. When the flag is \code{false}, results are computed from both the global layer and the next lower level. Setting the flag to \code{true} saves computation time.} - \item{\code{skip_evaluation_elements}}{(\emph{optional}) Specifies which evaluation steps, -if any, should be skipped as part of the evaluation process. Defaults to -\code{none}, which means that all relevant evaluation steps are performed. It can -have one or more of the following values: + \item{\code{evaluation_elements}}{(\emph{optional}) Specifies which evaluation steps +should be performed during the evaluation process. Defaults to \code{all}, +indicating that all evaluation steps should be performed. It can have one or +more of the following values: \itemize{ -\item \code{none}, \code{false}: no steps are skipped. -\item \code{all}, \code{true}: all steps are skipped. +\item \code{all}, \code{true}: all evaluation steps are performed. +\item \code{none}, \code{false}: no evaluation is performed. \item \code{auc_data}: data for assessing and plotting the area under the receiver -operating characteristic curve are not computed. +operating characteristic curve are computed. \item \code{calibration_data}: data for assessing and plotting model calibration are -not computed. +computed. \item \code{calibration_info}: data required to assess calibration, such as baseline -survival curves, are not collected. These data will still be present in the +survival curves, are collected. These data will still be present in the models. \item \code{confusion_matrix}: data for assessing and plotting a confusion matrix are -not collected. +collected. \item \code{decision_curve_analyis}: data for performing a decision curve analysis -are not computed. +are computed. \item \code{feature_expressions}: data for assessing and plotting sample clustering -are not computed. -\item \code{feature_similarity}: data for assessing and plotting feature clusters are +are computed. +\item \code{feature_similarity}: data for assessing and plotting feature clusters not computed. \item \code{fs_vimp}: data for assessing and plotting feature selection-based -variable importance are not collected. -\item \code{hyperparameters}: data for assessing model hyperparameters are not +variable importance are collected. +\item \code{hyperparameters}: data for assessing model hyperparameters are collected. These data will still be present in the models. \item \code{ice_data}: data for individual conditional expectation and partial -dependence plots are not created. +dependence plots are created. \item \code{model_performance}: data for assessing and visualising model performance -are not created. +are created. \item \code{model_vimp}: data for assessing and plotting model-based variable -importance are not collected. +importance are collected. \item \code{permutation_vimp}: data for assessing and plotting model-agnostic -permutation variable importance are not computed. -\item \code{prediction_data}: predictions for each sample are not made and exported. +permutation variable importance are computed. +\item \code{prediction_data}: predictions for each sample are made and exported. \item \code{risk_stratification_data}: data for assessing and plotting Kaplan-Meier -survival curves are not collected. +survival curves are collected. \item \code{risk_stratification_info}: data for assessing stratification into risk -groups are not computed. +groups are computed. +\item \code{sample_similarity}: data for assessing sample similarity are computed. +\item \code{shap}: data for assessing marginal contributions of feature values in +a SHAP analysis. \item \code{univariate_analysis}: data for assessing and plotting univariate feature -importance are not computed. -}} +importance are computed. +} + +The logical intersect of the evaluation elements specified by +\code{evaluation_elements} and \code{skip_evaluation_elements} is used to define which +evaluation steps are performed.} + \item{\code{skip_evaluation_elements}}{(\emph{optional}) Specifies which evaluation steps, +if any, should be skipped as part of the evaluation process. Defaults to +\code{none}, which means that all relevant evaluation steps are performed. It can +have one or more of the same values as \code{evaluation_elements}. + +The logical intersect of the evaluation elements specified by +\code{evaluation_elements} and \code{skip_evaluation_elements} is used to define which +evaluation steps are performed.} \item{\code{ensemble_method}}{(\emph{optional}) Method for ensembling predictions from models for the same sample. Available methods are: \itemize{ @@ -1104,14 +1128,23 @@ depends on the value of \code{confidence_level} (Davison and Hinkley, 1997). If unset, the metric in the \code{optimisation_metric} variable is used.} \item{\code{sample_limit}}{(\emph{optional}) Set the upper limit of the number of samples -that are used during evaluation steps. Cannot be less than 20. +that are used during evaluation steps. Cannot be fewer than 20. This setting can be specified per data element by providing a parameter value in a named list with data elements, e.g. \code{list("sample_similarity"=100, "permutation_vimp"=1000)}. This parameter can be set for the following data elements: -\code{sample_similarity} and \code{ice_data}.} +\code{sample_similarity}, \code{shap}, \code{permutation_vimp}, and \code{ice_data}.} + \item{\code{n_important_features}}{(\emph{optional}) Set the number of features that are +evaluated in evaluation steps. Cannot be 0 or fewer. + +This setting can be specified per data element by providing a parameter +value in a named list with data elements, e.g. +\code{list("ice_data"=10, "permutation_vimp"=5)}. + +This parameter can be set for the following data elements: +\code{ice_data}, \code{permutation_vimp}, and \code{shap}.} \item{\code{detail_level}}{(\emph{optional}) Sets the level at which results are computed and aggregated. \itemize{ @@ -1155,7 +1188,11 @@ evaluation steps by providing a parameter value in a named list with data elements, e.g. \code{list("auc_data"="ensemble", "model_performance"="hybrid")}. This parameter can be set for the following data elements: \code{auc_data}, \code{decision_curve_analyis}, \code{model_performance}, \code{permutation_vimp}, -\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}.} +\code{ice_data}, \code{prediction_data} and \code{confusion_matrix}. + +If results are computed from 10 samples or fewer, \code{ensemble} is +automatically used. This prevents issues where evaluation steps do not have +a required minimum number of samples for \code{hybrid} or \code{model}.} \item{\code{estimation_type}}{(\emph{optional}) Sets the type of estimation that should be possible. This has the following options: \itemize{ @@ -1209,6 +1246,19 @@ method. Note that the standard method is not implemented because this method is often not suitable due to non-normal distributions. The bias-corrected and accelerated (BCa) method is not implemented yet.} + \item{\code{shap_tolerance}}{(\emph{optional}) Relative tolerance for convergence of SHAP +values. The tolerance is scaled with the range in SHAP values. + +The default value is \code{0.05}.} + \item{\code{shap_max_iterations}}{(\emph{optional}) Maximum iterations for convergence of +SHAP values. + +The default value is \code{1000} iterations.} + \item{\code{shap_phi_0}}{(\emph{optional}) Value(s) to use for computing marginal +contributions. By default, the average predicted value in the population is +used. For \code{multinomial} and \code{survival} outcomes, this parameter requires a +value for each class and evaluation time (\code{evaluation_times}), +respectively.} \item{\code{feature_cluster_method}}{(\emph{optional}) Method used to perform clustering of features. The same methods as for the \code{cluster_method} configuration parameter are available: \code{none}, \code{hclust}, \code{agnes}, \code{diana} and \code{pam}. @@ -1294,9 +1344,9 @@ Gower's distance: distance is 0 if the values in a pair of samples match, and 1 if they do not.} \item{\code{eval_aggregation_method}}{(\emph{optional}) Method for aggregating variable importances for the purpose of evaluation. Variable importances are -determined during feature selection steps and after training the model. Both -types are evaluated, but feature selection variable importance is only -evaluated at run-time. +determined both during initial variable importance computation steps and +after training the model. Both types are evaluated after training the +model, but only the initial variable importances are evaluated at run-time. See the documentation for the \code{vimp_aggregation_method} argument for information concerning the different methods available.} @@ -1395,8 +1445,6 @@ Perform end-to-end machine learning and data analysis } \references{ \enumerate{ -\item Storey, J. D. A direct approach to false discovery rates. J. -R. Stat. Soc. Series B Stat. Methodol. 64, 479–498 (2002). \item Shrout, P. E. & Fleiss, J. L. Intraclass correlations: uses in assessing rater reliability. Psychol. Bull. 86, 420–428 (1979). \item Koo, T. K. & Li, M. Y. A guideline of selecting and reporting intraclass @@ -1408,6 +1456,9 @@ improve normality or symmetry. Biometrika 87, 954–959 (2000). Soc. Series B Stat. Methodol. 26, 211–252 (1964). \item Raymaekers, J., Rousseeuw, P. J. Transforming variables to central normality. Mach Learn. (2021). +\item Zwanenburg, A., & Löck, S. (2026). Location and scale-invariant power +transformations for transforming data to normality. Machine Learning, +115(3), 34. \item Park, M. Y., Hastie, T. & Tibshirani, R. Averaged gene expressions for regression. Biostatistics 8, 212–227 (2007). \item Tolosi, L. & Lengauer, T. Classification with correlated features: diff --git a/man/train_familiar.Rd b/man/train_familiar.Rd index 07486ffa..14961b58 100644 --- a/man/train_familiar.Rd +++ b/man/train_familiar.Rd @@ -37,7 +37,9 @@ In case paths are provided, the data should be stored as \code{csv}, \code{rds} \code{RData} files. See documentation for the \code{data_files} argument for more information.} -\item{experiment_data}{Experimental data may provided in the form of} +\item{experiment_data}{Experimental data may provided in the form of the +output of \code{precompute_data_assignment}, \code{precompute_feature_info} or +\code{precompute_vimp}. This allows for warm-starting experiments.} \item{cl}{Cluster created using the \code{parallel} package. This cluster is then used to speed up computation through parallelisation. When a cluster is not @@ -48,10 +50,12 @@ This parameter has no effect if the \code{parallel} argument is set to \code{FAL \item{experimental_design}{(\strong{required}) Defines what the experiment looks like, e.g. \code{cv(bt(fs,20)+mb,3,2)} for 2 times repeated 3-fold -cross-validation with nested feature selection on 20 bootstraps and -model-building. The basic workflow components are: +cross-validation with nested variable importance computation on 20 +bootstraps and model-building. The basic workflow components are: \itemize{ -\item \code{fs}: (required) feature selection step. +\item \code{fs}: (optional) variable importance computation step. If not explicitly +declared, feature selection will be done just in time for hyperparameter +optimisation. \item \code{mb}: (required) model building step. \item \code{ev}: (optional) external validation. Setting this is not required for \code{train_familiar}, but if validation batches or cohorts are present in the @@ -84,8 +88,8 @@ number of partitions generated depends on the imbalance correction method As shown in the example above, sampling algorithms can be nested. The simplest valid experimental design is \code{fs+mb}. This is the default in -\code{train_familiar}, and will create one model for each feature selection -method in \code{fs_method}. To create more models, a subsampling method should +\code{train_familiar}, and will create one model for each variable importance +method in \code{vimp_method}. To create more models, a subsampling method should be introduced, e.g. \code{bs(fs+mb,20)} to create 20 models based on bootstraps of the data. @@ -115,7 +119,7 @@ be conducted using these values.} messages and warnings are returned.} \item{...}{ - Arguments passed on to \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}}, \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_feature_selection_settings]{.parse_feature_selection_settings}}, \code{\link[=.parse_model_development_settings]{.parse_model_development_settings}}, \code{\link[=.parse_hyperparameter_optimisation_settings]{.parse_hyperparameter_optimisation_settings}} + Arguments passed on to \code{\link[=.parse_experiment_settings]{.parse_experiment_settings}}, \code{\link[=.parse_setup_settings]{.parse_setup_settings}}, \code{\link[=.parse_preprocessing_settings]{.parse_preprocessing_settings}}, \code{\link[=.parse_variable_importance_settings]{.parse_variable_importance_settings}}, \code{\link[=.parse_model_development_settings]{.parse_model_development_settings}}, \code{\link[=.parse_hyperparameter_optimisation_settings]{.parse_hyperparameter_optimisation_settings}} \describe{ \item{\code{batch_id_column}}{(\strong{recommended}) Name of the column containing batch or cohort identifiers. This parameter is required if more than one dataset @@ -144,7 +148,7 @@ sample or subject identifiers. See \code{batch_id_column} above for more details. If unset, every row will be identified as a single sample.} - \item{\code{series_id_column}}{(\strong{optional}) Name of the column containing series + \item{\code{series_id_column}}{(\emph{optional}) Name of the column containing series identifiers, which distinguish between measurements that are part of a series for a single sample. See \code{batch_id_column} above for more details. @@ -164,8 +168,8 @@ provided.} be used in figures created by \code{familiar}. If not set, the column name in \code{outcome_column} will be used for -\code{binomial}, \code{multinomial}, \code{count} and \code{continuous} outcomes. For other -outcomes (\code{survival} and \code{competing_risk}) no default is used.} +\code{binomial}, \code{multinomial}, and \code{continuous} outcomes. For other outcomes +(\code{survival} and \code{competing_risk}) no default is used.} \item{\code{outcome_column}}{(\strong{recommended}) Name of the column containing the outcome of interest. May be identified from a formula, if a formula is provided as an argument. Otherwise an error is raised. Note that \code{survival} @@ -174,13 +178,12 @@ indicate the time-to-event or the time of last follow-up and the event status.} \item{\code{outcome_type}}{(\strong{recommended}) Type of outcome found in the outcome column. The outcome type determines many aspects of the overall process, -e.g. the available feature selection methods and learners, but also the +e.g. the available variable importance methods and learners, but also the type of assessments that can be conducted to evaluate the resulting models. Implemented outcome types are: \itemize{ \item \code{binomial}: categorical outcome with 2 levels. \item \code{multinomial}: categorical outcome with 2 or more levels. -\item \code{count}: Poisson-distributed numeric outcomes. \item \code{continuous}: general continuous numeric outcomes. \item \code{survival}: survival outcome for time-to-event data. } @@ -190,7 +193,8 @@ contents of the outcome column. This may lead to unexpected results, and we therefore advise to provide this information manually. Note that \code{competing_risk} survival analysis are not fully supported, and -is currently not a valid choice for \code{outcome_type}.} +is currently not a valid choice for \code{outcome_type}. The \code{count} outcome +type was deprecated in version 2.0.0, and superseded by \code{continuous}.} \item{\code{class_levels}}{(\emph{optional}) Class levels for \code{binomial} or \code{multinomial} outcomes. This argument can be used to specify the ordering of levels for categorical outcomes. These class levels must exactly match the levels @@ -211,7 +215,7 @@ unset, all values other than those specified by the \code{event_indicator} and risks.} \item{\code{signature}}{(\emph{optional}) One or more names of feature columns that are considered part of a specific signature. Features specified here will -always be used for modelling. Ranking from feature selection has no effect +always be used for modelling. Ranking of variable importances has no effect for these features.} \item{\code{novelty_features}}{(\emph{optional}) One or more names of feature columns that should be included for the purpose of novelty detection.} @@ -256,6 +260,10 @@ that defines the design.} \item{\code{imbalance_n_partitions}}{(\emph{optional}) Number of times random undersampling should be repeated. 10 undersampled subsets with balanced classes are formed by default.} + \item{\code{iteration_seed}}{(\emph{optional}) Integer seed used in sampling algorithms +specified by the \code{experimental_design} argument. This allows for creating +the same sample assignments across different experiments -- of course +provided that the same dataset is used. By default a random seed is used.} \item{\code{parallel}}{(\emph{optional}) Enable parallel processing. Defaults to \code{TRUE}. When set to \code{FALSE}, this disables all parallel processing, regardless of specific parameters such as \code{parallel_preprocessing}. However, when @@ -310,7 +318,7 @@ Several method are available: filter, for example, genes that are not differentially expressed. \item \code{univariate_test}: Features undergo a univariate regression using an outcome-appropriate regression model. The p-value of the model coefficient -is collected. Features with coefficient p or q-value above the +is collected. Features with coefficient p-value above the \code{univariate_test_threshold} are subsequently filtered. \item \code{robustness}: Features that are not sufficiently robust according to the intraclass correlation coefficient are filtered. Use of this method @@ -322,18 +330,15 @@ More than one method can be used simultaneously. Features with singular values are always filtered, as these do not contain information.} \item{\code{univariate_test_threshold}}{(\emph{optional}) Numeric value between \code{1.0} and \code{0.0} that determines which features are irrelevant and will be filtered by -the \code{univariate_test}. The p or q-values are compared to this threshold. +the \code{univariate_test}. p-values are compared to this threshold. All features with values above the threshold are filtered. The default value is \code{0.20}.} \item{\code{univariate_test_threshold_metric}}{(\emph{optional}) Metric used with the to -compare the \code{univariate_test_threshold} against. The following metrics can +compare the \code{univariate_test_threshold} against. The following metric can be chosen: \itemize{ \item \code{p_value} (default): The unadjusted p-value of each feature is used for to filter features. -\item \code{q_value}: The q-value (Story, 2002), is used to filter features. Some -data sets may have insufficient samples to compute the q-value. The -\code{qvalue} package must be installed from Bioconductor to use this method. }} \item{\code{univariate_test_max_feature_set_size}}{(\emph{optional}) Maximum size of the feature set after the univariate test. P or q values of features are @@ -384,7 +389,7 @@ methods are available: \item \code{none}: This disables transformation of features. \item \code{yeo_johnson}: Transformation using the location and scale invariant version of the Yeo-Johnson transformation (Yeo and Johnson, 2000; -Zwanenburg and Löck, 2023). +Zwanenburg and Löck, 2026). \item \code{yeo_johnson_robust} (default): A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{yeo_johnson_conventional}: As \code{yeo_johnson}, but without optimisation of @@ -392,7 +397,7 @@ location and scale parameters. This method is equivalent to the original transformation proposed by Yeo and Johnson (2001). \item \code{box_cox}: Transformation using the location and scale invariant version of the Box-Cox transformation (Box and Cox, 1964; Zwanenburg and Löck, -2023). +2026). \item \code{box_cox_robust}: A robust version of \code{yeo_johnson}. This method is less sensitive to outliers. \item \code{box_cox_conventional}: As \code{box_cox}, but without optimisation of @@ -412,12 +417,12 @@ optimisation criteria, of which the following are available: \itemize{ \item \code{mle} (default): Optimisation using maximum likelihood estimation. \item \code{cramer_von_mises}: Optimisation using the Cramér-von Mises -criterion. Zwanenburg and Löck (2023) found that this criterion was +criterion. Zwanenburg and Löck (2026) found that this criterion was relatively robust against outliers. }} \item{\code{transformation_gof_test_p_value}}{(\emph{optional}) Not all transformations will lead to features that are roughly normally distributed. Zwanenburg and -Löck (2023) established a empirical goodness-of-fit test for central +Löck (2026) established a empirical goodness-of-fit test for central normality. This parameter sets the significance for rejecting the null-hypothesis that a feature distribution is centrally normal. When the null-hypothesis is rejected, no transformation is performed. The default @@ -665,18 +670,17 @@ preprocessing workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, this disable the use of parallel processing while preprocessing, regardless of the settings of the \code{parallel} parameter. \code{parallel_preprocessing} is ignored if \code{parallel=FALSE}.} - \item{\code{fs_method}}{(\strong{required}) Feature selection method to be used for -determining variable importance. \code{familiar} implements various feature -selection methods. Please refer to the vignette on feature selection -methods for more details. + \item{\code{vimp_method}}{(\strong{required}) Variable importance method. \code{familiar} +implements various variable importance methods. Please refer to the +vignette on variable importance methods for more details. -More than one feature selection method can be chosen. The experiment will +More than one variable importance method can be chosen. The experiment will then repeated for each feature selection method. -Feature selection methods determines the ranking of features. Actual +Variable importance methods determine the ranking of features. Actual selection of features is done by optimising the signature size model hyperparameter during the hyperparameter optimisation step.} - \item{\code{fs_method_parameter}}{(\emph{optional}) List of lists containing parameters + \item{\code{vimp_method_parameter}}{(\emph{optional}) List of lists containing parameters for feature selection methods. Each sublist should have the name of the feature selection method it corresponds to. @@ -718,17 +722,17 @@ feature rank. The \emph{feature selection methods} vignette provides additional information.} \item{\code{vimp_aggregation_rank_threshold}}{(\emph{optional}) The threshold used to -define the subset of highly important features. If not set, this threshold -is determined by maximising the variance in the occurrence value over all -features over the subset size. +define the subset of highly important features. If set to \code{NULL}, this +threshold is determined by maximising the variance in the occurrence value +over all features over the subset size. The default value is \code{5}. This parameter is only relevant for \code{stability}, \code{exponential}, \code{enhanced_borda}, \code{truncated_borda} and \code{enhanced_truncated_borda} methods.} - \item{\code{parallel_feature_selection}}{(\emph{optional}) Enable parallel processing for -the feature selection workflow. Defaults to \code{TRUE}. When set to \code{FALSE}, + \item{\code{parallel_vimp}}{(\emph{optional}) Enable parallel processing for +variable importance tasks. Defaults to \code{TRUE}. When set to \code{FALSE}, this will disable the use of parallel processing while performing feature selection, regardless of the settings of the \code{parallel} parameter. -\code{parallel_feature_selection} is ignored if \code{parallel=FALSE}.} +\code{parallel_vimp} is ignored if \code{parallel = FALSE}.} \item{\code{novelty_detector}}{(\emph{optional}) Specify the algorithm used for training a novelty detector. This detector can be used to identify out-of-distribution data prospectively.} @@ -751,16 +755,17 @@ finish before exhausting the set of bootstraps.} \item{\code{optimisation_determine_vimp}}{(\emph{optional}) Logical value that indicates whether variable importance is determined separately for each of the bootstraps created during the optimisation process (\code{TRUE}) or the -applicable results from the feature selection step are used (\code{FALSE}). +applicable results from the variable importance computation step are used +(\code{FALSE}). Determining variable importance increases the initial computational overhead. However, it prevents positive biases for the out-of-bag data due to overlap of these data with the development data set used for the feature selection step. In this case, any hyperparameters of the variable importance method are not determined separately for each bootstrap, but -those obtained during the feature selection step are used instead. In case -multiple of such hyperparameter sets could be applicable, the set that will -be used is randomly selected for each bootstrap. +those obtained during the variable importance computation step are used +instead. In case multiple of such hyperparameter sets could be applicable, +the set that will be used is randomly selected for each bootstrap. This parameter only affects hyperparameter optimisation of learners. The default is \code{TRUE}.} @@ -844,7 +849,6 @@ If unset, the following metrics are used by default: \itemize{ \item \code{auc_roc}: For \code{binomial} and \code{multinomial} models. \item \code{mse}: Mean squared error for \code{continuous} models. -\item \code{msle}: Mean squared logarithmic error for \code{count} models. \item \code{concordance_index}: For \code{survival} models. } diff --git a/man/update_object-methods.Rd b/man/update_object-methods.Rd index 13138cce..8c92e9fa 100644 --- a/man/update_object-methods.Rd +++ b/man/update_object-methods.Rd @@ -53,4 +53,7 @@ Provides backward compatibility for familiar objects exported to a file. This mitigates compatibility issues when working with files that become outdated as new versions of familiar are released, e.g. because slots have been removed. + +Major version releases (e.g., versions 1.0.0, 2.0.0) introduce breaking +changes which can result in objects that cannot be updated. } diff --git a/man/vimpTable-class.Rd b/man/vimpTable-class.Rd index 44abbbaa..8170e719 100644 --- a/man/vimpTable-class.Rd +++ b/man/vimpTable-class.Rd @@ -6,7 +6,8 @@ \title{Variable importance table} \description{ A vimpTable object contains information concerning variable importance of one -or more features. These objects are created during feature selection. +or more features. These objects are created during variable importance +computation.. } \details{ vimpTable objects exists in various states. These states are @@ -25,6 +26,12 @@ versions prior to familiar 1.2.0. \item{\code{vimp_method}}{Method used to compute variable importance scores for each feature.} +\item{\code{data_id}}{Internal identifier for the dataset used to derive the variable +importance table.} + +\item{\code{run_id}}{Internal identifier for the specific subset of the dataset used +to derive the variable importance table.} + \item{\code{run_table}}{Run table for the data used to compute variable importances from. Used internally.} diff --git a/tests/old_experiments/1_1_4_binomial.zip b/tests/old_experiments/1_1_4_binomial.zip deleted file mode 100644 index 6a04bf0f..00000000 Binary files a/tests/old_experiments/1_1_4_binomial.zip and /dev/null differ diff --git a/tests/old_experiments/1_1_4_continuous.zip b/tests/old_experiments/1_1_4_continuous.zip deleted file mode 100644 index deebd39d..00000000 Binary files a/tests/old_experiments/1_1_4_continuous.zip and /dev/null differ diff --git a/tests/old_experiments/1_1_4_count.zip b/tests/old_experiments/1_1_4_count.zip deleted file mode 100644 index 0c81381f..00000000 Binary files a/tests/old_experiments/1_1_4_count.zip and /dev/null differ diff --git a/tests/old_experiments/1_1_4_multinomial.zip b/tests/old_experiments/1_1_4_multinomial.zip deleted file mode 100644 index 3dcf330d..00000000 Binary files a/tests/old_experiments/1_1_4_multinomial.zip and /dev/null differ diff --git a/tests/old_experiments/1_1_4_survival.zip b/tests/old_experiments/1_1_4_survival.zip deleted file mode 100644 index 43bc878a..00000000 Binary files a/tests/old_experiments/1_1_4_survival.zip and /dev/null differ diff --git a/tests/old_experiments/1_4_1_binomial.zip b/tests/old_experiments/1_4_1_binomial.zip deleted file mode 100644 index 77d19d0e..00000000 Binary files a/tests/old_experiments/1_4_1_binomial.zip and /dev/null differ diff --git a/tests/old_experiments/1_4_1_continuous.zip b/tests/old_experiments/1_4_1_continuous.zip deleted file mode 100644 index 5227fb5b..00000000 Binary files a/tests/old_experiments/1_4_1_continuous.zip and /dev/null differ diff --git a/tests/old_experiments/1_4_1_count.zip b/tests/old_experiments/1_4_1_count.zip deleted file mode 100644 index 55230721..00000000 Binary files a/tests/old_experiments/1_4_1_count.zip and /dev/null differ diff --git a/tests/old_experiments/1_4_1_multinomial.zip b/tests/old_experiments/1_4_1_multinomial.zip deleted file mode 100644 index 11525e1c..00000000 Binary files a/tests/old_experiments/1_4_1_multinomial.zip and /dev/null differ diff --git a/tests/old_experiments/1_4_1_survival.zip b/tests/old_experiments/1_4_1_survival.zip deleted file mode 100644 index af77d3d7..00000000 Binary files a/tests/old_experiments/1_4_1_survival.zip and /dev/null differ diff --git a/tests/old_experiments/2_0_0_binomial.rds b/tests/old_experiments/2_0_0_binomial.rds new file mode 100644 index 00000000..9b17959b Binary files /dev/null and b/tests/old_experiments/2_0_0_binomial.rds differ diff --git a/tests/old_experiments/2_0_0_continuous.rds b/tests/old_experiments/2_0_0_continuous.rds new file mode 100644 index 00000000..f39d0f17 Binary files /dev/null and b/tests/old_experiments/2_0_0_continuous.rds differ diff --git a/tests/old_experiments/2_0_0_multinomial.rds b/tests/old_experiments/2_0_0_multinomial.rds new file mode 100644 index 00000000..b3d4a170 Binary files /dev/null and b/tests/old_experiments/2_0_0_multinomial.rds differ diff --git a/tests/old_experiments/2_0_0_survival.rds b/tests/old_experiments/2_0_0_survival.rds new file mode 100644 index 00000000..39c5e9d7 Binary files /dev/null and b/tests/old_experiments/2_0_0_survival.rds differ diff --git a/tests/old_experiments/archiveExperiment.R b/tests/old_experiments/archiveExperiment.R index ef107b20..7f380d79 100644 --- a/tests/old_experiments/archiveExperiment.R +++ b/tests/old_experiments/archiveExperiment.R @@ -5,56 +5,54 @@ test_run_archive_experiment <- function(parameters) { # Create data. data <- familiar:::test_create_good_data_random_missing( - outcome_type = parameters$outcome_type) + outcome_type = parameters$outcome_type + ) - # Generate the experiment directory. - experiment_dir <- file.path(tempdir(), familiar:::rstring(8L)) - - # Run the experiment to - do.call( + # Run the experiment and return the relevant familiar objects. + familiar_objects <- do.call( familiar::summon_familiar, args = c( list( "data" = data, - "experiment_dir" = experiment_dir, - "parallel" = FALSE), - parameters)) - - # Set the file name of the zip container. - zip_file_name <- paste0( + "parallel" = FALSE, + ".force_output" = TRUE + ), + parameters + ) + ) + + # Set the file name of the container. + rds_file_name <- paste0( gsub( pattern = ".", replacement = "_", x = as.character(utils::packageVersion("familiar")), - fixed = TRUE), + fixed = TRUE + ), "_", parameters$outcome_type, - ".zip") + ".rds" + ) - # Get the old working directory to restore it later. + # Get the current working directory. current_wd <- getwd() - - # Update the working directory so that we can properly zip using short - # relative paths. - setwd(experiment_dir) - - # Create zip file of the experimental directory. - utils::zip( - zipfile = file.path( + + saveRDS( + familiar_objects, + file = file.path( current_wd, "tests", "old_experiments", - zip_file_name), - files = "./") + rds_file_name + ) + ) +} - # Restore working directory. - setwd(current_wd) - # Clean up experiment directory. - unlink(experiment_dir, recursive = TRUE) -} test_create_experiment_archive <- function( - outcome_type = c("binomial", "multinomial", "count", "continuous", "survival")) { + outcome_type = c("binomial", "multinomial", "continuous", "survival"), + parallel = TRUE +) { # Creates zip files for testing update_object methods. test_generate_experiment_parameters <- coro::generator(function(outcome_type) { @@ -64,14 +62,13 @@ test_create_experiment_archive <- function( current_outcome_type, "binomial" = c("glm_logistic", "lasso"), "multinomial" = c("glm", "lasso"), - "count" = c("glm", "lasso"), "continuous" = c("glm_gaussian", "lasso"), "survival" = c("cox", "survival_regr_weibull")) coro::yield(list( "experimental_design" = "bs(fs+mb,3)", "outcome_type" = current_outcome_type, - "fs_method" = c("mim", "concordance"), + "vimp_method" = c("mim", "concordance"), "learner" = learner)) } }) @@ -80,13 +77,22 @@ test_create_experiment_archive <- function( config_parameters <- coro::collect( test_generate_experiment_parameters(outcome_type = outcome_type)) - cl <- parallel::makeCluster(type = "PSOCK", length(config_parameters)) - - # Iterate over parameter sets. - parallel::parLapply( - cl = cl, - X = config_parameters, - test_run_archive_experiment) - - parallel::stopCluster(cl) + if (parallel == TRUE) { + cl <- parallel::makeCluster(type = "PSOCK", length(config_parameters)) + + # Iterate over parameter sets. + parallel::parLapply( + cl = cl, + X = config_parameters, + test_run_archive_experiment + ) + + parallel::stopCluster(cl) + + } else { + lapply( + config_parameters, + test_run_archive_experiment + ) + } } diff --git a/tests/testthat/test-parallel_backend.R b/tests/testthat/test-0_parallel_backend.R similarity index 89% rename from tests/testthat/test-parallel_backend.R rename to tests/testthat/test-0_parallel_backend.R index 10b2c8b1..c2ccbb3b 100644 --- a/tests/testthat/test-parallel_backend.R +++ b/tests/testthat/test-0_parallel_backend.R @@ -6,7 +6,7 @@ familiar:::integrated_test( backend_type = "none", experimental_design = "bt(fs+mb,20)", parallel_nr_cores = 2, - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = TRUE, @@ -18,7 +18,7 @@ familiar:::integrated_test( backend_type = "socket_server", experimental_design = "bt(fs+mb,20)", parallel_nr_cores = 2, - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = TRUE, @@ -34,12 +34,11 @@ familiar:::integrated_test( backend_type = "none", cl = cl, experimental_design = "bt(fs+mb,20)", - fs_method = "mrmr", + vimp_method = "mrmr", cluster_method = "none", imputation_method = "simple", parallel = TRUE, - skip_evaluation_elements = "all", - debug = TRUE + skip_evaluation_elements = "all" ) cl <- familiar:::.terminate_cluster(cl = cl) diff --git a/tests/testthat/test-0_plot_calibration.R b/tests/testthat/test-0_plot_calibration.R index 15162a04..91031865 100644 --- a/tests/testthat/test-0_plot_calibration.R +++ b/tests/testthat/test-0_plot_calibration.R @@ -9,7 +9,7 @@ familiar:::test_plots( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, debug = debug_flag ) @@ -20,7 +20,7 @@ familiar:::test_plots( detail_level = "ensemble", data_element = "calibration_data", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, debug = debug_flag ) @@ -31,7 +31,7 @@ familiar:::test_plots( estimation_type = "bias_correction", data_element = "calibration_data", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, debug = debug_flag ) @@ -42,7 +42,7 @@ familiar:::test_plots( estimation_type = "point", data_element = "calibration_data", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, debug = debug_flag ) @@ -51,7 +51,7 @@ familiar:::test_plots( familiar:::test_plots( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", - test_specific_config = TRUE, + test_config = "normal", plot_args = list("show_density" = FALSE), debug = debug_flag ) @@ -60,7 +60,7 @@ familiar:::test_plots( familiar:::test_plots( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", - test_specific_config = TRUE, + test_config = "normal", plot_args = list("show_goodness_of_fit" = FALSE), debug = debug_flag ) @@ -69,7 +69,7 @@ familiar:::test_plots( familiar:::test_plots( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", - test_specific_config = TRUE, + test_config = "normal", plot_args = list("show_calibration_fit" = FALSE), debug = debug_flag ) @@ -78,7 +78,7 @@ familiar:::test_plots( familiar:::test_plots( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", - test_specific_config = TRUE, + test_config = "normal", plot_args = list( "show_calibration_fit" = FALSE, "show_goodness_of_fit" = FALSE), @@ -89,27 +89,27 @@ familiar:::test_plots( familiar:::test_plot_ordering( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), debug = debug_flag ) -# Test alignment of different plots, with missing data. +# Test alignment of different plots from prediction tables. familiar:::test_plot_ordering( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", - outcome_type_available = c("count"), - plot_args = list( - "facet_by" = c("fs_method", "learner"), - "color_by" = c("data_set")), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + prediction_type = list("survival" = "survival_probability"), + use_prediction_table = TRUE, debug = debug_flag ) +# Test alignment of different plots, with missing data. familiar:::test_plot_ordering( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", outcome_type_available = c("continuous"), plot_args = list( - "facet_by" = c("fs_method", "learner"), + "facet_by" = c("vimp_method", "learner"), "color_by" = c("data_set")), debug = debug_flag ) @@ -119,7 +119,7 @@ familiar:::test_plot_ordering( data_element = "calibration_data", outcome_type_available = c("binomial"), plot_args = list( - "facet_by" = c("fs_method", "learner"), + "facet_by" = c("vimp_method", "learner"), "color_by" = c("data_set")), debug = debug_flag ) @@ -129,7 +129,7 @@ familiar:::test_plot_ordering( data_element = "calibration_data", outcome_type_available = c("multinomial"), plot_args = list( - "facet_by" = c("fs_method", "learner"), + "facet_by" = c("vimp_method", "learner"), "color_by" = c("data_set", "positive_class")), debug = debug_flag ) @@ -139,7 +139,7 @@ familiar:::test_plot_ordering( data_element = "calibration_data", outcome_type_available = c("survival"), plot_args = list( - "facet_by" = c("fs_method", "learner"), + "facet_by" = c("vimp_method", "learner"), "color_by" = c("data_set")), debug = debug_flag ) @@ -147,8 +147,8 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_calibration_data, data_element = "calibration_data", - outcome_type_available = c("count", "continuous", "binomial", "survival"), - plot_args = list("facet_by" = c("learner", "fs_method", "data_set")), + outcome_type_available = c("continuous", "binomial", "survival"), + plot_args = list("facet_by" = c("learner", "vimp_method", "data_set")), debug = debug_flag ) @@ -157,7 +157,7 @@ familiar:::test_plot_ordering( data_element = "calibration_data", outcome_type_available = c("multinomial"), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), + "facet_by" = c("learner", "vimp_method", "data_set"), "color_by" = "positive_class"), debug = debug_flag ) diff --git a/tests/testthat/test-0_plot_ice_a.R b/tests/testthat/test-0_plot_ice_a.R deleted file mode 100644 index 4afd7f42..00000000 --- a/tests/testthat/test-0_plot_ice_a.R +++ /dev/null @@ -1,13 +0,0 @@ -# Don't perform any further tests on CRAN due to time of running the complete -# test. -testthat::skip_on_cran() -testthat::skip_on_ci() - -debug_flag <- FALSE - -familiar:::test_plots( - plot_function = familiar:::plot_ice, - not_available_some_predictions_fail = FALSE, - data_element = "ice_data", - debug = debug_flag -) diff --git a/tests/testthat/test-0_plot_sample_clustering_b.R b/tests/testthat/test-0_plot_sample_clustering_b.R deleted file mode 100644 index a13d1fe7..00000000 --- a/tests/testthat/test-0_plot_sample_clustering_b.R +++ /dev/null @@ -1,84 +0,0 @@ -# Don't perform any further tests on CRAN due to time of running the complete -# test. -testthat::skip_on_cran() -testthat::skip_on_ci() - -debug_flag <- FALSE - -# Generic test -familiar:::test_plots( - plot_function = familiar:::plot_sample_clustering, - not_available_all_predictions_fail = FALSE, - not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - data_element = "feature_expressions", - plot_args = list( - "verbose" = FALSE, - "show_normalised_data" = "set_normalisation"), - debug = debug_flag -) - -# No extra elements -familiar:::test_plot_ordering( - plot_function = familiar:::plot_sample_clustering, - data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "x_axis_by" = "sample", - "y_axis_by" = "feature", - "show_outcome" = FALSE, - "show_feature_dendrogram" = FALSE, - "show_sample_dendrogram" = FALSE, - "verbose" = FALSE), - debug = debug_flag -) - -# No normalisation. -familiar:::test_plot_ordering( - plot_function = familiar:::plot_sample_clustering, - data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "show_normalised_data" = "none", - "verbose" = FALSE), - debug = debug_flag -) - -# Normalisation per dataset. -familiar:::test_plot_ordering( - plot_function = familiar:::plot_sample_clustering, - data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "show_normalised_data" = "set_normalisation", - "verbose" = FALSE), - debug = debug_flag -) - - -# With sample limit -familiar:::test_plot_ordering( - plot_function = familiar:::plot_sample_clustering, - data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "sample_limit" = 20L, - "verbose" = FALSE), - debug = debug_flag -) - - -# Test multiple evaluation times -familiar:::test_plot_ordering( - plot_function = familiar:::plot_sample_clustering, - data_element = "feature_expressions", - outcome_type_available = c("survival"), - plot_args = list( - "evaluation_times" = c(500, 1000, 1500, 2000), - "verbose" = FALSE), - debug = debug_flag -) diff --git a/tests/testthat/test-0_preprocessing_clustering.R b/tests/testthat/test-0_preprocessing_clustering.R index 72f6ff77..208c6207 100644 --- a/tests/testthat/test-0_preprocessing_clustering.R +++ b/tests/testthat/test-0_preprocessing_clustering.R @@ -60,7 +60,7 @@ generate_test_parameters <- coro::generator(function( # Set outcome type to avoid redundant tests where outcome type does # not matter. if (current_cluster_representation_method %in% c("best_predictor")) { - available_outcome_type <- c("survival", "binomial", "multinomial", "continuous", "count") + available_outcome_type <- c("survival", "binomial", "multinomial", "continuous") } else { available_outcome_type <- c("binomial") } @@ -117,12 +117,7 @@ while (TRUE) { cluster_size = cluster_size) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data) # Create cluster skeletons feature_info_list <- familiar:::create_cluster_parameter_skeleton( @@ -331,12 +326,7 @@ while (TRUE) { features = "feature_1") # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data) # Create cluster skeletons feature_info_list <- familiar:::create_cluster_parameter_skeleton( @@ -419,12 +409,7 @@ while (TRUE) { features = c("feature_1", "feature_2")) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data) # Create cluster skeletons feature_info_list <- familiar:::create_cluster_parameter_skeleton( @@ -515,13 +500,8 @@ while (TRUE) { features = c("feature_1_A", "feature_1_B")) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] - + feature_info_list <- test_create_generic_info(data = data) + # Create cluster skeletons feature_info_list <- familiar:::create_cluster_parameter_skeleton( feature_info_list, @@ -594,12 +574,7 @@ while (TRUE) { cluster_size = cluster_size) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data) # Set signature features feature_info_list <- familiar:::add_signature_info( @@ -710,12 +685,7 @@ while (TRUE) { cluster_size = cluster_size) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data) # Create cluster skeletons feature_info_list <- familiar:::create_cluster_parameter_skeleton( @@ -819,12 +789,7 @@ while (TRUE) { cluster_size = cluster_size) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data) # Create cluster skeletons feature_info_list <- familiar:::create_cluster_parameter_skeleton(feature_info_list, @@ -896,12 +861,7 @@ while (TRUE) { cluster_size = cluster_size) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data@data, - file_paths = NULL, - project_id = character(), - outcome_type = parameters$outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data) # Create cluster skeletons feature_info_list <- familiar:::create_cluster_parameter_skeleton( diff --git a/tests/testthat/test-0_vimp_rfsrc_S4.R b/tests/testthat/test-0_vimp_rfsrc_S4.R deleted file mode 100644 index 686aca2c..00000000 --- a/tests/testthat/test-0_vimp_rfsrc_S4.R +++ /dev/null @@ -1,703 +0,0 @@ -familiar:::test_all_vimp_methods_available( - familiar:::.get_available_rfsrc_vimp_methods(show_general = TRUE)) -familiar:::test_all_vimp_methods_available( - familiar:::.get_available_rfsrc_default_vimp_methods(show_general = TRUE)) - -# Don't perform any further tests on CRAN due to time of running the complete -# test. -testthat::skip_on_cran() -testthat::skip_on_ci() - -familiar:::test_all_vimp_methods( - familiar:::.get_available_rfsrc_vimp_methods(show_general = FALSE), - debug = FALSE, - hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "continuous" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "binomial" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "multinomial" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "survival" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ) - ) -) - -familiar:::test_all_vimp_methods( - familiar:::.get_available_rfsrc_default_vimp_methods()) - -familiar:::test_all_vimp_methods_parallel( - familiar:::.get_available_rfsrc_vimp_methods(show_general = FALSE), - hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "continuous" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "binomial" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "multinomial" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ), - "survival" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 2 - ) - ) -) - -# Count outcome ---------------------------------------------------------------- -data <- familiar:::test_create_good_data("count") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_minimum_depth", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest minimum depth method correctly ranks count data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", - "residence_before_1940_proportion", "avg_rooms")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_permutation", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest permutation method correctly ranks count data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", - "residence_before_1940_proportion", "avg_rooms", "industry")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_holdout", - vimp_method_parameter_list = list( - "n_tree" = 12, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest hold-out method correctly ranks count data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", - "residence_before_1940_proportion", "avg_rooms", "property_tax_rate")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_variable_hunting", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 3), - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest variable hunting method correctly ranks count data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% familiar:::get_feature_columns(data)), - TRUE) - } -) - -# Continuous outcome ----------------------------------------------------------- -data <- familiar:::test_create_good_data("continuous") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_minimum_depth", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "continuous", - cluster_method = "none", - imputation_method = "simple") - - -testthat::test_that( - paste0( - "The RFSRC random forest minimum depth method correctly ranks continuous data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_permutation", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "continuous", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest permutation method correctly ranks continuous data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_holdout", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "continuous", - cluster_method = "none", - imputation_method = "simple") - - -testthat::test_that( - paste0( - "The RFSRC random forest hold-out method correctly ranks continuous data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_variable_hunting", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 3), - outcome_type = "continuous", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest variable hunting method correctly ranks continuous data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% familiar:::get_feature_columns(data)), - TRUE) - } -) - - -# Binomial outcome ------------------------------------------------------------- -data <- familiar:::test_create_good_data("binomial") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_minimum_depth", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "binomial", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest minimum depth method correctly ranks binomial data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", "epithelial_cell_size", "bare_nuclei")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_permutation", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "binomial", - cluster_method = "none", - imputation_method = "simple" -) - -testthat::test_that( - paste0( - "The RFSRC random forest permutation method correctly ranks binomial data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", "epithelial_cell_size", "bare_nuclei")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_holdout", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "binomial", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest hold-out method correctly ranks binomial data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% familiar:::get_feature_columns(data)), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_variable_hunting", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 3), - outcome_type = "binomial", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest variable hunting method correctly ranks binomial data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% familiar:::get_feature_columns(data)), - TRUE) - } -) - - - -# Multinomial outcome ---------------------------------------------------------- -data <- familiar:::test_create_good_data("multinomial") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_minimum_depth", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "multinomial", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest minimum depth method correctly ranks multinomial outcome data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c("Petal_Length", "Petal_Width")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_permutation", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "multinomial", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest permutation method correctly ranks multinomial outcome data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c("Petal_Length", "Petal_Width")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_holdout", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "multinomial", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest hold-out method correctly ranks multinomial outcome data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% familiar:::get_feature_columns(data)), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_variable_hunting", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 3), - outcome_type = "multinomial", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest variable hunting method correctly ranks multinomial outcome data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% familiar:::get_feature_columns(data)), - TRUE) - } -) - - - -# Survival outcome ------------------------------------------------------------- -data <- familiar:::test_create_good_data("survival") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_minimum_depth", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "survival", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest minimum depth method correctly ranks survival outcome data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c("nodes", "rx", "adhere")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_permutation", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "survival", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest permutation method correctly ranks survival outcome data."), { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c("nodes", "rx")), - TRUE) - } -) - - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_holdout", - vimp_method_parameter_list = list( - "n_tree" = 8, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - outcome_type = "survival", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest hold-out method correctly ranks survival outcome data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% c("nodes", "rx")), - TRUE) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_rfsrc_variable_hunting", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "fs_vh_fold" = 3, - "fs_vh_n_rep" = 3), - outcome_type = "survival", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0( - "The RFSRC random forest variable hunting method correctly ranks survival outcome data."), - { - vimp_table <- suppressWarnings( - familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal( - all(vimp_table[rank <= 2]$name %in% familiar:::get_feature_columns(data)), - TRUE) - } -) - -testthat::skip("Skip hyperparameter optimisation, unless manual.") - -familiar:::test_hyperparameter_optimisation( - vimp_methods = familiar:::.get_available_rfsrc_vimp_methods(show_general = TRUE), - debug = FALSE, - parallel = FALSE) diff --git a/tests/testthat/test-as_data_object.R b/tests/testthat/test-as_data_object.R index 0f5634bf..55bd4a0a 100644 --- a/tests/testthat/test-as_data_object.R +++ b/tests/testthat/test-as_data_object.R @@ -11,26 +11,30 @@ fam_model <- familiar:::test_train( imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "cox", - create_novelty_detector = TRUE) + create_novelty_detector = TRUE +) # Feature levels are correctly ordered ----------------------------------------- data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Change order of features. -data$rx <- factor( - x = data$rx, - levels = c("Lev", "Lev+5FU", "Obs")) +data$feature_3a <- factor( + x = data$feature_3a, + levels = rev(levels(data$feature_3a)) +) testthat::test_that("Feature levels are correctly ordered", { for (strictness in c("strict", "external_warn", "external")) { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( - levels(parsed_data@data$rx), - c("Obs", "Lev", "Lev+5FU")) + levels(parsed_data@data$feature_3a), + c("round", "square") + ) } }) @@ -38,18 +42,20 @@ testthat::test_that("Feature levels are correctly ordered", { data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Keep features as characters, -data$rx <- as.character(data$rx) +data$feature_3a <- as.character(data$feature_3a) testthat::test_that("Feature levels are correctly set", { for (strictness in c("strict", "external_warn", "external")) { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( - levels(parsed_data@data$rx), - c("Obs", "Lev", "Lev+5FU")) + levels(parsed_data@data$feature_3a), + c("round", "square") + ) } }) @@ -59,31 +65,32 @@ testthat::test_that("Feature levels are correctly set", { data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Change order of features. -data$adhere <- factor( - x = data$adhere, - levels = c("TRUE", "FALSE"), - ordered = TRUE) +data$feature_4 <- factor( + x = data$feature_4, + levels = c("best", "better", "good"), + ordered = TRUE +) testthat::test_that("Feature levels are correctly ordered", { for (strictness in c("strict", "external_warn", "external")) { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( - levels(parsed_data@data$adhere), - c("FALSE", "TRUE")) - testthat::expect_equal( - is.ordered(parsed_data@data$adhere), - TRUE) + levels(parsed_data@data$feature_4), + c("good", "better", "best") + ) + testthat::expect_true(is.ordered(parsed_data@data$feature_4)) } }) data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Keep features as characters, -data$adhere <- as.character(data$adhere) +data$feature_4 <- as.character(data$feature_4) testthat::test_that("Feature levels are correctly set", { for (strictness in c("strict", "external_warn", "external")) { @@ -93,11 +100,10 @@ testthat::test_that("Feature levels are correctly set", { check_stringency = strictness) testthat::expect_equal( - levels(parsed_data@data$adhere), - c("FALSE", "TRUE")) - testthat::expect_equal( - is.ordered(parsed_data@data$adhere), - TRUE) + levels(parsed_data@data$feature_4), + c("good", "better", "best") + ) + testthat::expect_true(is.ordered(parsed_data@data$feature_4)) } }) @@ -108,18 +114,20 @@ testthat::test_that("Feature levels are correctly set", { data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Remove a feature level. -data[rx == "Lev+5FU", "rx" := "Lev"] +data[feature_4 == "better", "feature_4" := "best"] testthat::test_that("Feature levels are correctly ordered", { for (strictness in c("strict", "external_warn", "external")) { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( - levels(parsed_data@data$rx), - c("Obs", "Lev", "Lev+5FU")) + levels(parsed_data@data$feature_4), + c("good", "better", "best") + ) } }) @@ -128,119 +136,147 @@ testthat::test_that("Feature levels are correctly ordered", { data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Add new level to categorical features. -data[c(1, 2, 3), "rx" := "Cisplatin"] +data[c(1, 2, 3), "feature_3a" := "extra_square"] testthat::test_that("Extra levels are detected", { for (strictness in c("strict", "external_warn", "external")) { testthat::expect_error(familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness)) + check_stringency = strictness + )) } }) # Test methods to set reference levels ----------------------------------------- data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) -data$rx <- stats::relevel(data$rx, ref = "Lev") -original_true <- data$adhere == "TRUE" -data[adhere == "FALSE", "adhere" := "TRUE"] -data[original_true, "adhere" := "FALSE"] +data$feature_3a <- stats::relevel(data$feature_3a, ref = "square") testthat::test_that("Auto-method does not re-order existing levels.", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), - sample_id_column = "id", - outcome_column = c("time", "status"), + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), outcome_type = "survival", - include_features = c("nodes", "rx", "adhere"), - reference_method = "auto") + include_features = c("feature_3a", "feature_3b"), + reference_method = "auto" + ) testthat::expect_equal( - head(levels(parsed_data@data$rx), n = 1L), "Lev") + head(levels(parsed_data@data$feature_3a), n = 1L), "square" + ) testthat::expect_equal( - head(levels(parsed_data@data$adhere), n = 1L), "FALSE") + head(levels(parsed_data@data$feature_3b), n = 1L), "sphere" + ) }) testthat::test_that("Always-method re-orders existing levels.", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), - sample_id_column = "id", - outcome_column = c("time", "status"), + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), outcome_type = "survival", - include_features = c("nodes", "rx", "adhere"), - reference_method = "always") + include_features = c("feature_3a", "feature_3b"), + reference_method = "always" + ) testthat::expect_equal( - head(levels(parsed_data@data$rx), n = 1L), "Obs") + head(levels(parsed_data@data$feature_3a), n = 1L), "round" + ) testthat::expect_equal( - head(levels(parsed_data@data$adhere), n = 1L), "FALSE") + head(levels(parsed_data@data$feature_3b), n = 1L), "sphere" + ) }) testthat::test_that("Never-method does not re-order existing levels.", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), - sample_id_column = "id", - outcome_column = c("time", "status"), + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), outcome_type = "survival", - include_features = c("nodes", "rx", "adhere"), - reference_method = "never") + include_features = c("feature_3a", "feature_3b"), + reference_method = "never" + ) testthat::expect_equal( - head(levels(parsed_data@data$rx), n = 1L), "Lev") + head(levels(parsed_data@data$feature_3a), n = 1L), "square" + ) testthat::expect_equal( - head(levels(parsed_data@data$adhere), n = 1L), "FALSE") + head(levels(parsed_data@data$feature_3b), n = 1L), "sphere" + ) }) # Now for automatic conversion of categorical variables. data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) -data$rx <- as.character(data$rx) -data$adhere <- as.logical(data$adhere) +data$feature_3a <- as.character(data$feature_3a) +data[, "feature_3_extra" := feature_3a == "square"] testthat::test_that("Auto-method re-orders existing levels.", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), - sample_id_column = "id", - outcome_column = c("time", "status"), + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), outcome_type = "survival", - include_features = c("nodes", "rx", "adhere"), - reference_method = "auto") - + include_features = c("feature_3a", "feature_3_extra"), + reference_method = "auto" + ) + testthat::expect_equal( - head(levels(parsed_data@data$rx), n = 1L), "Obs") + head(levels(parsed_data@data$feature_3a), n = 1L), "round" + ) testthat::expect_equal( - head(levels(parsed_data@data$adhere), n = 1L), "FALSE") + head(levels(parsed_data@data$feature_3_extra), n = 1L), "FALSE" + ) }) testthat::test_that( "Always-method re-orders existing levels.", { - parsed_data <- familiar::as_data_object( - data = data.table::copy(data), - sample_id_column = "id", - outcome_column = c("time", "status"), - outcome_type = "survival", - include_features = c("nodes", "rx", "adhere"), - reference_method = "always") - - testthat::expect_equal( - head(levels(parsed_data@data$rx), n = 1L), "Obs") - testthat::expect_equal( - head(levels(parsed_data@data$adhere), n = 1L), "FALSE") + parsed_data <- familiar::as_data_object( + data = data.table::copy(data), + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), + outcome_type = "survival", + include_features = c("feature_3a", "feature_3_extra"), + reference_method = "always" + ) + + testthat::expect_equal( + head(levels(parsed_data@data$feature_3a), n = 1L), "round" + ) + testthat::expect_equal( + head(levels(parsed_data@data$feature_3_extra), n = 1L), "FALSE" + ) }) testthat::test_that("Never-method sorts existing levels.", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), - sample_id_column = "id", - outcome_column = c("time", "status"), + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), outcome_type = "survival", - include_features = c("nodes", "rx", "adhere"), - reference_method = "never") - + include_features = c("feature_3a", "feature_3_extra"), + reference_method = "never" + ) + testthat::expect_equal( - head(levels(parsed_data@data$rx), n = 1L), "Lev") + head(levels(parsed_data@data$feature_3a), n = 1L), "round" + ) testthat::expect_equal( - head(levels(parsed_data@data$adhere), n = 1L), "FALSE") + head(levels(parsed_data@data$feature_3_extra), n = 1L), "FALSE" + ) }) @@ -253,11 +289,10 @@ testthat::test_that("Censoring is correctly transferred", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) - testthat::expect_equal( - all(parsed_data@data$outcome_event %in% c(0, 1)), - TRUE) + testthat::expect_true(all(parsed_data@data$outcome_event %in% c(0, 1))) } }) @@ -268,9 +303,9 @@ data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) manual_data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Update status column to specific -manual_data$status <- as.character(data$status) -manual_data[status == "0", "status" := "alive"] -manual_data[status == "1", "status" := "dead"] +manual_data$outcome_event <- as.character(data$outcome_event) +manual_data[outcome_event == "0", "outcome_event" := "alive"] +manual_data[outcome_event == "1", "outcome_event" := "dead"] testthat::test_that("Censoring and event identifiers can be manually set", { for (strictness in c("strict", "external_warn", "external")) { @@ -280,17 +315,19 @@ testthat::test_that("Censoring and event identifiers can be manually set", { object = fam_model, event_indicator = "dead", censoring_indicator = "alive", - check_stringency = strictness) + check_stringency = strictness + ) # With original event identifiers. parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) - testthat::expect_equal( - all(manual_parsed_data@data$outcome_event == parsed_data@data$outcome_event), - TRUE) + testthat::expect_true( + all(manual_parsed_data@data$outcome_event == parsed_data@data$outcome_event) + ) } }) @@ -300,9 +337,9 @@ testthat::test_that("Censoring and event identifiers can be manually set", { data <- familiar:::test_create_good_data("survival", to_data_object = FALSE) # Update status column to specific -data$status <- as.character(data$status) -data[status == "0", "status" := "alive"] -data[status == "1", "status" := "dead"] +data$outcome_event <- as.character(data$outcome_event) +data[outcome_event == "0", "outcome_event" := "alive"] +data[outcome_event == "1", "outcome_event" := "dead"] testthat::test_that("Censoring and event identifiers are not known", { for (strictness in c("strict", "external_warn", "external")) { @@ -313,23 +350,26 @@ testthat::test_that("Censoring and event identifiers are not known", { testthat::expect_error(familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness)) + check_stringency = strictness + )) } else if (strictness == "external_warn") { warns <- testthat::capture_warnings(familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness)) + check_stringency = strictness + )) - testthat::expect_equal(any(grepl("event indicator", warns)), TRUE) - testthat::expect_equal(any(grepl("censoring indicator", warns)), TRUE) + testthat::expect_true(any(grepl("event indicator", warns))) + testthat::expect_true(any(grepl("censoring indicator", warns))) } else if (strictness == "external") { # With original event identifiers. parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) } } }) @@ -349,17 +389,18 @@ fam_model <- familiar:::test_train( learner = "cox", event_indicator = "dead", censoring_indicator = "alive", - create_novelty_detector = TRUE) + create_novelty_detector = TRUE +) testthat::test_that("Non-standard censoring and event identifiers are automatically transferred", { for (strictness in c("strict", "external_warn", "external")) { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) - testthat::expect_equal( - all(parsed_data@data$outcome_event %in% c(0, 1)), TRUE) + testthat::expect_true(all(parsed_data@data$outcome_event %in% c(0, 1))) } }) @@ -375,7 +416,8 @@ fam_model <- familiar:::test_train( imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "glm_logistic", - create_novelty_detector = TRUE) + create_novelty_detector = TRUE +) # Create test dataset. data <- familiar:::test_create_good_data("binomial", to_data_object = FALSE) @@ -385,11 +427,13 @@ testthat::test_that("Class levels are correctly ordered", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( levels(parsed_data@data$outcome), - c("benign", "malignant")) + c("red", "green") + ) } }) @@ -399,27 +443,30 @@ testthat::test_that("Class levels are correctly ordered", { data <- familiar:::test_create_good_data("binomial", to_data_object = FALSE) # Reorder class levels -data$cell_malignancy <- factor( - x = data$cell_malignancy, - levels = c("malignant", "benign")) +data$outcome <- factor( + x = data$outcome, + levels = c("green", "red") +) testthat::test_that("Class levels are ordered according to expectations", { for (strictness in c("strict", "external_warn", "external")) { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( levels(parsed_data@data$outcome), - c("benign", "malignant")) + c("red", "green") + ) } }) # Missing class levels --------------------------------------------------------- data <- familiar:::test_create_good_data("binomial", to_data_object = FALSE) -data[cell_malignancy == "benign", cell_malignancy := "malignant"] +data[outcome == "red", outcome := "green"] testthat::test_that("Class levels are ordered according to expectations", { for (strictness in c("strict", "external_warn", "external")) { @@ -427,7 +474,8 @@ testthat::test_that("Class levels are ordered according to expectations", { testthat::expect_error(familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness)) + check_stringency = strictness + )) } else { # Class levels may be missing for external_warn and external strictness @@ -435,11 +483,12 @@ testthat::test_that("Class levels are ordered according to expectations", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( levels(parsed_data@data$outcome), - c("benign", "malignant")) + c("red", "green")) } } }) @@ -450,7 +499,7 @@ testthat::test_that("Class levels are ordered according to expectations", { data <- familiar:::test_create_good_data("binomial", to_data_object = FALSE) # Add new level -data[c(1, 2, 3), "cell_malignancy" := "unknown"] +data[c(1, 2, 3), "outcome" := "blue"] testthat::test_that("Additional class levels are detected", { for (strictness in c("strict", "external_warn", "external")) { @@ -458,13 +507,15 @@ testthat::test_that("Additional class levels are detected", { testthat::expect_error(familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness)) + check_stringency = strictness + )) } else { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) } } }) @@ -483,7 +534,8 @@ fam_naive_model <- familiar:::test_train( hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "glm_logistic", create_novelty_detector = TRUE, - create_naive = TRUE) + create_naive = TRUE +) data <- familiar:::test_create_good_data("binomial", to_data_object = FALSE) @@ -492,10 +544,12 @@ testthat::test_that("Naive models can be used to convert data objects.", { parsed_data <- familiar::as_data_object( data = data.table::copy(data), object = fam_model, - check_stringency = strictness) + check_stringency = strictness + ) testthat::expect_equal( levels(parsed_data@data$outcome), - c("benign", "malignant")) + c("red", "green") + ) } }) diff --git a/tests/testthat/test-batch_normalisation.R b/tests/testthat/test-batch_normalisation.R index 0461f3a3..45a7a18a 100644 --- a/tests/testthat/test-batch_normalisation.R +++ b/tests/testthat/test-batch_normalisation.R @@ -5,10 +5,11 @@ testthat::skip_on_ci() outcome_type <- "survival" # Generic test ----------------------------------------------------------------- -for (n_numeric_features in c(4, 3, 2, 1, 0)) { +for (n_numeric_features in c(4L, 3L, 2L, 1L, 0L)) { data <- familiar:::test_create_synthetic_series_data( outcome_type = outcome_type, - n_numeric = n_numeric_features) + n_numeric = n_numeric_features + ) for (batch_normalisation_method in familiar:::.get_available_batch_normalisation_methods()) { testthat::test_that(paste0( @@ -23,24 +24,21 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { batch_ids <- unique(data_copy@data[[familiar:::get_id_columns("batch")]]) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- familiar:::test_create_generic_info(data = data_copy) # Combat requires global standardisation if (batch_normalisation_method %in% familiar:::.get_available_batch_normalisation_methods("combat")) { # Create normalisation skeletons. feature_info_list <- familiar:::create_normalisation_parameter_skeleton( feature_info_list = feature_info_list, - normalisation_method = "standardisation") + normalisation_method = "standardisation" + ) # Update the feature info list with global standardisation parameters. feature_info_list <- familiar:::add_normalisation_parameters( feature_info_list = feature_info_list, - data = data_copy) + data = data_copy + ) # Act as if the data has been transformed. data_copy@preprocessing_level <- "transformation" @@ -48,18 +46,21 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { # Perform a global normalisation. data_copy <- familiar:::normalise_features( data = data_copy, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) } # Create batch normalisation container skeleton. feature_info_list <- familiar:::create_batch_normalisation_parameter_skeleton( feature_info_list = feature_info_list, - normalisation_method = batch_normalisation_method) + normalisation_method = batch_normalisation_method + ) # Add batch normalisation parameters. feature_info_list <- familiar:::add_batch_normalisation_parameters( feature_info_list = feature_info_list, - data = data_copy) + data = data_copy + ) # Assume that the data is pre-processed. data_copy@preprocessing_level <- "normalisation" @@ -67,12 +68,13 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { # Attempt to batch normalise the data. data_copy <- familiar:::batch_normalise_features( data = data_copy, - feature_info_list = feature_info_list) + feature_info_list = feature_info_list + ) # Test whether the features are normalised (unless none). if (batch_normalisation_method == "none") { # Check that the data is not altered. - testthat::expect_equal(data.table::fsetequal(data_copy@data, data@data), TRUE) + testthat::expect_true(data.table::fsetequal(data_copy@data, data@data)) # Iterate over features. for (feature in familiar:::get_feature_columns(data_copy)) { @@ -80,29 +82,34 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { # method. testthat::expect_equal( feature_info_list[[feature]]@batch_normalisation_parameters@method, - batch_normalisation_method) + batch_normalisation_method + ) # Expect that all batches are named. testthat::expect_setequal( names(feature_info_list[[feature]]@batch_normalisation_parameters@batch_parameters), - batch_ids) + batch_ids + ) # Expect that all batches parameter objects have the none class. for (batch_parameter_object in - feature_info_list[[feature]]@batch_normalisation_parameters@batch_parameters) { + feature_info_list[[feature]]@batch_normalisation_parameters@batch_parameters + ) { testthat::expect_s4_class( batch_parameter_object, - "featureInfoParametersNormalisationNone") + "featureInfoParametersNormalisationNone" + ) testthat::expect_equal(batch_parameter_object@name, feature) - testthat::expect_equal(batch_parameter_object@batch %in% batch_ids, TRUE) + testthat::expect_true(batch_parameter_object@batch %in% batch_ids) } } + } else { # Iterate over the different batches to determine if batch corrections # were performed correctly. for (x in split(data_copy@data, by = "batch_id")) { # Find the current batch identifier. - current_batch_id <- x[["batch_id"]][1] + current_batch_id <- x[["batch_id"]][1L] # Iterate over features. for (feature in familiar:::get_feature_columns(data_copy)) { @@ -115,7 +122,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { familiar:::.get_available_batch_normalisation_methods("normalisation")) { # Check that the feature is correctly centred around 0.5. - testthat::expect_equal(mu < 0.7 & mu > 0.3, TRUE) + testthat::expect_true(mu < 0.7 & mu > 0.3) } else if (batch_normalisation_method %in% familiar:::.get_available_batch_normalisation_methods("combat")) { @@ -123,50 +130,55 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { # wider margins for the non-parametric method Check also that # the overall mean is around 0. if (batch_normalisation_method %in% c("combat", "combat_np", "combat_non_parametric")) { - testthat::expect_equal(mu < 0.5 & mu > -0.5, TRUE) + testthat::expect_true(mu < 0.5 & mu > -0.5) } else { - testthat::expect_equal(mu < 0.2 & mu > -0.2, TRUE) + testthat::expect_true(mu < 0.2 & mu > -0.2) } # Check overall mean. mu_t <- mean(data_copy@data[[feature]], na.rm = TRUE) - testthat::expect_equal(mu_t < 0.2 & mu_t > -0.2, TRUE) + testthat::expect_true(mu_t < 0.2 & mu_t > -0.2) } else { # Check that the feature is correctly centred around 0. - testthat::expect_equal(mu < 0.2 & mu > -0.2, TRUE) + testthat::expect_true(mu < 0.2 & mu > -0.2) } # Test that the container method matches the batch normalisation # method. testthat::expect_equal( feature_info_list[[feature]]@batch_normalisation_parameters@method, - batch_normalisation_method) + batch_normalisation_method + ) # Expect that all batches are named. testthat::expect_setequal( names(feature_info_list[[feature]]@batch_normalisation_parameters@batch_parameters), - batch_ids) + batch_ids + ) } else { # For categorical features test that the none batch normalisation # method is present. testthat::expect_equal( feature_info_list[[feature]]@batch_normalisation_parameters@method, - "none") + "none" + ) # Expect that all batches are named. testthat::expect_setequal( names(feature_info_list[[feature]]@batch_normalisation_parameters@batch_parameters), - batch_ids) + batch_ids + ) # Expect that all batches parameter objects have # the none class. for (batch_parameter_object in - feature_info_list[[feature]]@batch_normalisation_parameters@batch_parameters) { + feature_info_list[[feature]]@batch_normalisation_parameters@batch_parameters + ) { testthat::expect_s4_class(batch_parameter_object, "featureInfoParametersNormalisationNone") testthat::expect_equal(batch_parameter_object@name, feature) - testthat::expect_equal(batch_parameter_object@batch %in% batch_ids, TRUE) + testthat::expect_true(batch_parameter_object@batch %in% batch_ids) } } } @@ -177,7 +189,8 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_restored <- familiar:::batch_normalise_features( data = data_copy, feature_info_list = feature_info_list, - invert = TRUE) + invert = TRUE + ) # Inverse the global normalisation. if (batch_normalisation_method %in% @@ -186,7 +199,8 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_restored <- familiar:::normalise_features( data = data_restored, feature_info_list = feature_info_list, - invert = TRUE) + invert = TRUE + ) } # Iterate over features and compare. They should be equal. @@ -203,10 +217,10 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { )$parameters for (batch_norm_parameters in aggr_batch_normalisation_parameters@batch_parameters) { - if (n_numeric_features > 0 && batch_normalisation_method != "none") { + if (n_numeric_features > 0L && batch_normalisation_method != "none") { # Expect that the selected transformation method matches the selected # method, except for combat methods. - if (n_numeric_features <= 2 && + if (n_numeric_features <= 2L && batch_normalisation_method %in% familiar:::.get_available_batch_normalisation_methods("combat")) { testthat::expect_s4_class( batch_norm_parameters, @@ -219,16 +233,17 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { } # Expect that the shift and scale parameters are not NA. - testthat::expect_equal(is.finite(batch_norm_parameters@shift), TRUE) + testthat::expect_true(is.finite(batch_norm_parameters@shift)) if (is(batch_norm_parameters, "featureInfoParametersNormalisationShiftScale")) { - testthat::expect_equal(is.finite(batch_norm_parameters@scale), TRUE) + testthat::expect_true(is.finite(batch_norm_parameters@scale)) } } else { # Assert that for the categorical features, the none method is used. testthat::expect_s4_class( batch_norm_parameters, - "featureInfoParametersNormalisationNone") + "featureInfoParametersNormalisationNone" + ) } } }) @@ -256,12 +271,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { batch_ids <- unique(data_copy@data[[familiar:::get_id_columns("batch")]]) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Combat requires global standardisation if (batch_normalisation_method %in% @@ -432,12 +442,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { batch_ids <- unique(data_copy@data[[familiar:::get_id_columns("batch")]]) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Combat requires global standardisation if (batch_normalisation_method %in% familiar:::.get_available_batch_normalisation_methods("combat")) { @@ -626,12 +631,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { batch_ids <- unique(data_copy@data[[familiar:::get_id_columns("batch")]]) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Combat requires global standardisation if (batch_normalisation_method %in% familiar:::.get_available_batch_normalisation_methods("combat")) { @@ -777,12 +777,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { batch_ids <- unique(data_copy@data[[familiar:::get_id_columns("batch")]]) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Combat requires global standardisation if (batch_normalisation_method %in% @@ -970,13 +965,8 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { batch_ids <- unique(data_copy@data[[familiar:::get_id_columns("batch")]]) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] - + feature_info_list <- test_create_generic_info(data = data_copy) + # Combat requires global standardisation if (batch_normalisation_method %in% familiar:::.get_available_batch_normalisation_methods("combat")) { # Create normalisation skeletons. @@ -1122,12 +1112,7 @@ for (batch_normalisation_method in familiar:::.get_available_batch_normalisation batch_ids <- unique(data_copy@data[[familiar:::get_id_columns("batch")]]) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Combat requires global standardisation if (batch_normalisation_method %in% diff --git a/tests/testthat/test-batch_normalisation_checks.R b/tests/testthat/test-batch_normalisation_checks.R new file mode 100644 index 00000000..f16b91dd --- /dev/null +++ b/tests/testthat/test-batch_normalisation_checks.R @@ -0,0 +1,42 @@ +# Avoid warnings due to non-standard evaluation in data.table. +outcome <- outcome_time <- NULL + +for (outcome_type in c("continuous", "binomial", "multinomial", "survival")) { + # Generate data. + data <- familiar:::test_create_good_data(outcome_type = outcome_type) + data@data[, "batch_id" := "A"] + data_b <- familiar:::test_create_good_data(outcome_type = outcome_type) + data_b@data[, "batch_id" := "B"] + data_c <- familiar:::test_create_good_data(outcome_type = outcome_type) + data_c@data[, "batch_id" := "C"] + data@data <- rbind(data@data, data_b@data, data_c@data) + + # Introduce data with offset. + data_offset <- data + data_offset@data <- data.table::copy(data_offset@data) + if (outcome_type == "continuous") { + data_offset@data[batch_id == "A", "outcome" := outcome + 50.0] + + } else if (outcome_type %in% c("binomial", "multinomial")) { + data_offset@data[batch_id == "A", "outcome" := "red"] + + } else if (outcome_type == "survival") { + data_offset@data[batch_id == "A", "outcome_time" := outcome_time + 1000.0] + } + + # Test results + testthat::expect_no_condition( + familiar:::.check_batch_normalisation_assumptions( + data = data, + normalisation_method = "combat" + ) + ) + + testthat::expect_warning( + familiar:::.check_batch_normalisation_assumptions( + data = data_offset, + normalisation_method = "combat" + ), + class = "familiar_batch_outcome_difference" + ) +} diff --git a/tests/testthat/test-check_data_plausibility.R b/tests/testthat/test-check_data_plausibility.R new file mode 100644 index 00000000..143a0791 --- /dev/null +++ b/tests/testthat/test-check_data_plausibility.R @@ -0,0 +1,78 @@ +# Don't perform any further tests on CRAN due to running time. +testthat::skip_on_cran() + +# power.transform and other packages are required. +if (!rlang::is_installed("power.transform")) testthat::skip() + +# Create data.table. +data <- familiar:::test_create_good_data( + outcome_type = "binomial", + to_data_object = FALSE +) + +# Test that the duplicated data check ------------------------------------------ + +# Duplicate the first row. +duplicated_data <- data.table::copy(data) +duplicated_data[2L, ] <- duplicated_data[1L, ] + +# Create data assignment object. +testthat::expect_warning( + experiment_data_assignment <- familiar::precompute_data_assignment( + data = duplicated_data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE + ), + class = "familiar_data_check" +) + + +# Test the invariant feature check --------------------------------------------- + +# Add invariant feature +invariant_data <- data.table::copy(data) +invariant_data[, "feature_5" := 3.0] + +testthat::expect_warning( + experiment_data_assignment <- familiar::precompute_data_assignment( + data = invariant_data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE + ), + class = "familiar_data_check" +) + + +# Test the one-to-one predictor check ------------------------------------------ + +# Add one-to-one predictor +one_to_one_data <- data.table::copy(data) +one_to_one_data[, "feature_5" := 0.0] +one_to_one_data[outcome == "red", "feature_5" := 1.0] + +testthat::expect_warning( + experiment_data_assignment <- familiar::precompute_data_assignment( + data = one_to_one_data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE + ), + class = "familiar_data_check" +) diff --git a/tests/testthat/test-collection_labels.R b/tests/testthat/test-collection_labels.R index 9b79032e..add534ce 100644 --- a/tests/testthat/test-collection_labels.R +++ b/tests/testthat/test-collection_labels.R @@ -2,10 +2,9 @@ testthat::skip_on_cran() testthat::skip_on_ci() +debug_flag <- FALSE + for (outcome_type in c("continuous", "multinomial", "survival")) { - - if (!familiar:::test_data_package_installed(outcome_type)) next - # Get data. data <- familiar:::test_create_good_data(outcome_type = outcome_type) @@ -14,21 +13,24 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { outcome_type, "continuous" = "glm_gaussian", "multinomial" = "glm_multinomial", - "survival" = "cox") + "survival" = "cox" + ) # Data elements to skip. - skip_data_elements <- c("ice_data", "permutation_vimp") + skip_data_elements <- c("ice_data", "permutation_vimp", "shap") # Create experiment data. experiment_data <- familiar::summon_familiar( data = data, experimental_design = "fs+mb", - fs_method = "mim", + vimp_method = "mim", imputation_method = "simple", learner = learner, estimation_type = "point", skip_evaluation_elements = skip_data_elements, - parallel = FALSE) + parallel = FALSE, + verbose = debug_flag + ) # Test both familiarCollection and familiarModel objects. familiar_collection_list <- list( @@ -38,7 +40,9 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { data = data, familiar_data_names = "development", estimation_type = "point", - data_element = setdiff(familiar:::.get_available_data_elements(), skip_data_elements))) + data_element = setdiff(familiar:::.get_available_data_elements(), skip_data_elements) + ) + ) # class names ---------------------------------------------------------------- for (collection in familiar_collection_list) { @@ -56,23 +60,27 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { collection <- familiar::set_class_names( collection, old = rev(class_names), - new = rev(new_class_names)) + new = rev(new_class_names) + ) # Expect that the labels are the same and have the same order as the # original labels. testthat::expect_equal( familiar::get_class_names(collection), - new_class_names) + new_class_names + ) # Reorder levels. collection <- familiar::set_class_names( collection, - order = rev(new_class_names)) + order = rev(new_class_names) + ) # Expect that the labels are now re-ordered. testthat::expect_equal( familiar::get_class_names(collection), - rev(new_class_names)) + rev(new_class_names) + ) } else { testthat::expect_equal(class_names, character(0L)) @@ -95,13 +103,15 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { collection <- familiar::set_data_set_names( collection, old = "development", - new = new_data_set_names) + new = new_data_set_names + ) # Expect that the labels are the same and have the same order as the # original labels. testthat::expect_equal( familiar::get_data_set_names(collection), - new_data_set_names) + new_data_set_names + ) } ) } @@ -113,39 +123,41 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { testthat::test_that( "Feature names are correct", { - testthat::expect_equal( - all(feature_names %in% familiar:::get_feature_columns(data)), - TRUE) + testthat::expect_true(all(feature_names %in% familiar:::get_feature_columns(data))) # Replace feature names. new_feature_names <- paste0("feature_", seq_along(feature_names)) collection <- familiar::set_feature_names( collection, old = rev(feature_names), - new = rev(new_feature_names)) + new = rev(new_feature_names) + ) # Expect that the labels are the same and have the same order as the # original labels. testthat::expect_equal( familiar::get_feature_names(collection), - new_feature_names) + new_feature_names + ) # Reorder levels. collection <- familiar::set_feature_names( collection, - order = rev(new_feature_names)) + order = rev(new_feature_names) + ) # Expect that the labels are now re-ordered. testthat::expect_equal( familiar::get_feature_names(collection), - rev(new_feature_names)) + rev(new_feature_names) + ) } ) } # vimp names ----------------------------------------------------------------- for (collection in familiar_collection_list) { - vimp_names <- familiar::get_fs_method_names(collection) + vimp_names <- familiar::get_vimp_method_names(collection) testthat::test_that( "VIMP names are correct", @@ -154,16 +166,18 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { # Replace vimp-method names. new_vimp_names <- paste0("vimp_method_", seq_along(vimp_names)) - collection <- familiar::set_fs_method_names( + collection <- familiar::set_vimp_method_names( collection, old = vimp_names, - new = new_vimp_names) + new = new_vimp_names + ) # Expect that the labels are the same and have the same order as the # original labels. testthat::expect_equal( - familiar::get_fs_method_names(collection), - new_vimp_names) + familiar::get_vimp_method_names(collection), + new_vimp_names + ) } ) } @@ -182,13 +196,15 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { collection <- familiar::set_learner_names( collection, old = learner_names, - new = new_learner_names) + new = new_learner_names + ) # Expect that the labels are the same and have the same order as the # original labels. testthat::expect_equal( familiar::get_learner_names(collection), - new_learner_names) + new_learner_names + ) } ) } @@ -203,35 +219,41 @@ for (outcome_type in c("continuous", "multinomial", "survival")) { if (outcome_type %in% c("survival")) { testthat::expect_setequal( risk_group_names, - c("low", "moderate", "high")) + c("low", "moderate", "high") + ) # Replace risk-group names. new_risk_group_names <- paste0("risk_group", seq_along(risk_group_names)) collection <- familiar::set_risk_group_names( collection, old = rev(risk_group_names), - new = rev(new_risk_group_names)) + new = rev(new_risk_group_names) + ) # Expect that the labels are the same and have the same order as the # original labels. testthat::expect_equal( familiar::get_risk_group_names(collection), - new_risk_group_names) + new_risk_group_names + ) # Reorder levels. collection <- familiar::set_risk_group_names( collection, - order = rev(new_risk_group_names)) + order = rev(new_risk_group_names) + ) # Expect that the labels are now re-ordered. testthat::expect_equal( familiar::get_risk_group_names(collection), - rev(new_risk_group_names)) + rev(new_risk_group_names) + ) } else { testthat::expect_equal( risk_group_names, - c("low", "moderate", "high")) + c("low", "moderate", "high") + ) } } ) diff --git a/tests/testthat/test-configuration_file.R b/tests/testthat/test-configuration_file.R index a10a7b7a..7191c855 100644 --- a/tests/testthat/test-configuration_file.R +++ b/tests/testthat/test-configuration_file.R @@ -1,4 +1,5 @@ -testthat::skip_if_not_installed("xml2") +# xml2 is required to . +if (!rlang::is_installed("xml2")) testthat::skip() # Find path to configuration file in package. config <- system.file("config.xml", package = "familiar") @@ -11,29 +12,20 @@ config <- familiar:::.load_configuration_file(config) config_node_names <- names(config) expected_node_names <- familiar:::.get_all_configuration_parent_node_names() -testthat::test_that("1. All parent nodes are present in the configuration file.", { - testthat::expect_equal(all(config_node_names %in% expected_node_names), TRUE) - testthat::expect_equal(all(expected_node_names %in% config_node_names), TRUE) -}) - -testthat::test_that("2. All parameters are specified.", { - config_args <- unique(unlist(sapply(config, names))) - - testthat::expect_equal(all(config_args %in% familiar:::.get_all_parameter_names()), TRUE) - testthat::expect_equal(all(familiar:::.get_all_parameter_names() %in% config_args), TRUE) - - if (!all(familiar:::.get_all_parameter_names() %in% config_args)) { - warning(paste0( - "The following parameters are not specified in the configuration file: ", - paste0(setdiff(familiar:::.get_all_parameter_names(), config_args), collapse = ", "))) +testthat::test_that( + "1. All parent nodes are present in the configuration file.", + { + testthat::expect_setequal(config_node_names, expected_node_names) } +) - if (!all(config_args %in% familiar:::.get_all_parameter_names())) { - warning(paste0( - "The following parameters are specified in the configuration file, but not familiar: ", - paste0(setdiff(config_args, familiar:::.get_all_parameter_names()), collapse = ", "))) +testthat::test_that( + "2. All parameters are specified.", + { + config_args <- unique(unlist(sapply(config, names))) + testthat::expect_setequal(config_args, familiar:::.get_all_parameter_names()) } -}) +) for (parent_node in expected_node_names) { # Identify the parsing function for the node. @@ -42,7 +34,7 @@ for (parent_node in expected_node_names) { data = familiar:::.parse_experiment_settings, run = familiar:::.parse_setup_settings, preprocessing = familiar:::.parse_preprocessing_settings, - feature_selection = familiar:::.parse_feature_selection_settings, + variable_importance = familiar:::.parse_variable_importance_settings, model_development = familiar:::.parse_model_development_settings, hyperparameter_optimisation = familiar:::.parse_hyperparameter_optimisation_settings, evaluation = familiar:::.parse_evaluation_settings @@ -68,7 +60,7 @@ for (parent_node in expected_node_names) { ) } - if (parent_node != "feature_selection") { + if (parent_node != "variable_importance") { expected_config_args <- setdiff( expected_config_args, c("vimp_aggregation_rank_threshold", "vimp_aggregation_method") @@ -78,22 +70,10 @@ for (parent_node in expected_node_names) { # Find the argument names. config_args <- names(config[[parent_node]]) - testthat::test_that(paste0("3. All parameters are specified for the \"", parent_node, "\" node."), { - testthat::expect_equal(all(config_args %in% expected_config_args), TRUE) - testthat::expect_equal(all(expected_config_args %in% config_args), TRUE) - - if (!all(expected_config_args %in% config_args)) { - warning(paste0( - "The following parameters are not specified in the configuration file under node \"", - parent_node, "\": ", - paste0(setdiff(expected_config_args, config_args), collapse = ", "))) + testthat::test_that( + paste0("3. All parameters are specified for the \"", parent_node, "\" node."), + { + testthat::expect_setequal(config_args, expected_config_args) } - - if (!all(config_args %in% expected_config_args)) { - warning(paste0( - "The following parameters are specified in the configuration file under node \"", - parent_node, "\" but not familiar: ", - paste0(setdiff(config_args, expected_config_args), collapse = ", "))) - } - }) + ) } diff --git a/tests/testthat/test-dynamic_model_loading.R b/tests/testthat/test-dynamic_model_loading.R index 934f508f..49809bee 100644 --- a/tests/testthat/test-dynamic_model_loading.R +++ b/tests/testthat/test-dynamic_model_loading.R @@ -5,8 +5,9 @@ testthat::skip_on_ci() familiar:::integrated_test( dynamic_model_loading = TRUE, experimental_design = "fs+mb", - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, - estimation_type = "point") + estimation_type = "point" +) diff --git a/tests/testthat/test-experiment_data.R b/tests/testthat/test-experiment_data.R index 07b2447c..c9adfbf2 100644 --- a/tests/testthat/test-experiment_data.R +++ b/tests/testthat/test-experiment_data.R @@ -5,21 +5,27 @@ testthat::skip_on_ci() # Create data.table. data <- familiar:::test_create_good_data( outcome_type = "binomial", - to_data_object = FALSE) + to_data_object = FALSE +) # Create data assignment object. experiment_data_assignment <- familiar::precompute_data_assignment( data = data, experimental_design = "bs(fs+mb,3)", outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Assert that data assignment performs correctly", { - testthat::expect_equal(is.null(experiment_data_assignment@feature_info), TRUE) - testthat::expect_equal(is.null(experiment_data_assignment@vimp_table_list), TRUE) + testthat::expect_false(is.null(experiment_data_assignment@experiment_setup)) + testthat::expect_false(is.null(experiment_data_assignment@iteration_list)) + testthat::expect_true(is.null(experiment_data_assignment@feature_info)) + testthat::expect_true(is.null(experiment_data_assignment@vimp_table_list)) }) # Create feature info object. @@ -27,14 +33,20 @@ experiment_feature_info <- familiar::precompute_feature_info( data = data, experiment_data = experiment_data_assignment, outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Assert that feature info computation performs correctly", { - # Check that 6 subsets are present, namely generic + complete + # Check that 4 subsets are present, namely generic + complete testthat::expect_equal(length(experiment_feature_info@feature_info), 4L) + + # Check that there are 6 features. + testthat::expect_equal(length(experiment_feature_info@feature_info$generic), 6L) for (feature_info_set in names(experiment_feature_info@feature_info)) { for (feature_info in experiment_feature_info@feature_info[[feature_info_set]]) { @@ -44,42 +56,47 @@ testthat::test_that("Assert that feature info computation performs correctly", { # Assert that the feature information is complete. testthat::expect_equal( familiar:::feature_info_complete(feature_info), - feature_info_set != "generic") + feature_info_set != "generic" + ) } } # Test contents. - testthat::expect_equal(is.null(experiment_feature_info@vimp_table_list), TRUE) + testthat::expect_true(is.null(experiment_feature_info@vimp_table_list)) testthat::expect_equal( experiment_data_assignment@experiment_setup, experiment_feature_info@experiment_setup, - ignore_attr = TRUE) + ignore_attr = TRUE + ) testthat::expect_equal( experiment_data_assignment@iteration_list, experiment_feature_info@iteration_list, - ignore_attr = TRUE) + ignore_attr = TRUE + ) testthat::expect_equal( experiment_data_assignment@project_id, - experiment_feature_info@project_id) + experiment_feature_info@project_id + ) }) # Create variable importance experiment_vimp <- familiar::precompute_vimp( data = data, experiment_data = experiment_feature_info, - fs_method = "univariate_regression", + vimp_method = "univariate_regression", outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Assert that variable importance computation performs correctly", { # Assert that variable importance data are correct. - testthat::expect_equal( - length(experiment_vimp@vimp_table_list$univariate_regression), - 3L) - for (vimp_table in experiment_vimp@vimp_table_list$univariate_regression) { + testthat::expect_length(experiment_vimp@vimp_table_list, 3L) + for (vimp_table in experiment_vimp@vimp_table_list) { testthat::expect_s4_class(vimp_table, "vimpTable") } @@ -87,66 +104,75 @@ testthat::test_that("Assert that variable importance computation performs correc testthat::expect_equal( experiment_data_assignment@experiment_setup, experiment_vimp@experiment_setup, - ignore_attr = TRUE) + ignore_attr = TRUE + ) testthat::expect_equal( experiment_data_assignment@iteration_list, experiment_vimp@iteration_list, - ignore_attr = TRUE) + ignore_attr = TRUE + ) testthat::expect_equal( experiment_feature_info@feature_info, experiment_vimp@feature_info, - ignore_attr = TRUE) + ignore_attr = TRUE + ) testthat::expect_equal( experiment_data_assignment@project_id, - experiment_vimp@project_id) + experiment_vimp@project_id + ) # Test that get_vimp_table produces three tables. - vimp_table <- familiar::get_vimp_table(experiment_vimp) - testthat::expect_equal(length(vimp_table$univariate_regression), 3L) + vimp_table <- familiar::get_vimp_table(experiment_vimp@vimp_table_list) + testthat::expect_length(vimp_table, 3L) # Test that aggregate_vimp_table produces one table. vimp_table <- familiar::aggregate_vimp_table( - experiment_vimp, - aggregation_method = "borda") - testthat::expect_s4_class( - vimp_table$univariate_regression, "vimpTable") + experiment_vimp@vimp_table_list, + aggregation_method = "borda" + ) + testthat::expect_s4_class(vimp_table, "vimpTable") + vimp_table <- familiar::get_vimp_table(vimp_table) - testthat::expect_s3_class( - vimp_table$univariate_regression, "data.table") + testthat::expect_s3_class(vimp_table, "data.table") }) # Add additional variable importance methods. experiment_vimp_3 <- familiar::precompute_vimp( data = data, experiment_data = experiment_vimp, - fs_method = c("univariate_regression", "mim", "mrmr"), + vimp_method = c("univariate_regression", "mim", "mrmr"), outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) - + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Addition variable importance computation performs correctly", { # Assert that the vimp tables for the univariate_regression method are not # altered. - for (ii in seq_along(experiment_vimp_3@vimp_table_list$univariate_regression)) { + for (ii in 1L:3L) { testthat::expect_equal( - experiment_vimp_3@vimp_table_list$univariate_regression[[ii]], - experiment_vimp@vimp_table_list$univariate_regression[[ii]], - ignore_attr = TRUE) + experiment_vimp_3@vimp_table_list[[ii]], + experiment_vimp@vimp_table_list[[ii]], + ignore_attr = TRUE + ) } # Test that 9 variable importance tables were created. - testthat::expect_equal( - length(unlist(familiar::get_vimp_table(experiment_vimp_3), recursive = FALSE)), - 9L) + testthat::expect_length( + familiar::get_vimp_table(experiment_vimp_3@vimp_table_list), 9L + ) # Test that 3 aggregated variable importance tables are created. - testthat::expect_equal( - length(familiar::get_vimp_table( - familiar::aggregate_vimp_table(experiment_vimp_3, "borda"))), - 3L) + testthat::expect_length( + familiar::get_vimp_table( + familiar::aggregate_vimp_table(experiment_vimp_3@vimp_table_list, "borda") + ), + 3L + ) testthat::expect_equal( experiment_vimp@project_id, diff --git a/tests/testthat/test-experimental_design.R b/tests/testthat/test-experimental_design.R index 28f7b86a..86380ba4 100644 --- a/tests/testthat/test-experimental_design.R +++ b/tests/testthat/test-experimental_design.R @@ -6,7 +6,7 @@ debug_flag <- FALSE # Simple test familiar:::integrated_test( experimental_design = "fs+mb", - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, @@ -18,7 +18,7 @@ familiar:::integrated_test( # Bootstrap (without optimisation within bootstraps) familiar:::integrated_test( experimental_design = "bt(fs+mb, 5)", - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, @@ -30,7 +30,7 @@ familiar:::integrated_test( # Bootstrap (with pre-processing and optimisation within bootstraps) familiar:::integrated_test( experimental_design = "bs(fs+mb, 5)", - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, @@ -42,7 +42,7 @@ familiar:::integrated_test( # Cross-validation familiar:::integrated_test( experimental_design = "cv(fs+mb, 3)", - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, @@ -54,7 +54,7 @@ familiar:::integrated_test( # Leave-one-out cross-validation familiar:::integrated_test( experimental_design = "lv(fs+mb)", - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, @@ -67,14 +67,12 @@ familiar:::integrated_test( familiar:::integrated_test( experimental_design = "ip(fs+mb)", imbalance_correction_method = "full_undersampling", - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, skip_evaluation_elements = "all", outcome_type_available = "binomial", - warning_good = "Imbalance partitions are not required as data are not severely imbalanced.", - warning_bad = "Imbalance partitions are not required as data are not severely imbalanced.", debug = debug_flag ) @@ -83,13 +81,11 @@ familiar:::integrated_test( experimental_design = "ip(fs+mb)", imbalance_correction_method = "random_undersampling", imbalance_n_partitions = 3, - fs_method = "none", + vimp_method = "none", cluster_method = "none", imputation_method = "simple", parallel = FALSE, skip_evaluation_elements = "all", outcome_type_available = "binomial", - warning_good = "Imbalance partitions are not required as data are not severely imbalanced.", - warning_bad = "Imbalance partitions are not required as data are not severely imbalanced.", debug = debug_flag ) diff --git a/tests/testthat/test-experimental_design_external_validation.R b/tests/testthat/test-experimental_design_external_validation.R new file mode 100644 index 00000000..83b0ffa0 --- /dev/null +++ b/tests/testthat/test-experimental_design_external_validation.R @@ -0,0 +1,313 @@ +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + + +# With external validation ----------------------------------------------------- + +data <- familiar:::test_create_good_data(outcome_type = "binomial", to_data_object = FALSE) +data[101L:150L, "batch_id" := "test"] + +# Training + external validation +results <- familiar::summon_familiar( + data = data, + experimental_design = "mb+ev", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = FALSE +) + +testthat::test_that("development + evaluation experiment is correctly created", { + testthat::expect_length(results$familiarModel, 1L) + testthat::expect_length(results$familiarData, 2L) + testthat::expect_equal(results$familiarData[[1L]]@name, "development") + testthat::expect_equal(results$familiarData[[2L]]@name, "external_validation") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 1L) + testthat::expect_length(int_values, 0L) + testthat::expect_length(ext_values, 1L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) +}) + + +# Internal bootstraps (incomplete) + external validation +results <- familiar::summon_familiar( + data = data, + experimental_design = "bt(mb, 3)+ev", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("incomplete bootstrap-only + evaluation experiment is correctly created", { + testthat::expect_length(results$familiarModel, 3L) + testthat::expect_length(results$familiarData, 2L) + testthat::expect_equal(results$familiarData[[1L]]@name, "development") + testthat::expect_equal(results$familiarData[[2L]]@name, "external_validation") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 3L) + testthat::expect_length(int_values, 0L) + testthat::expect_length(ext_values, 3L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) +}) + + +# Internal cross-validation +results <- familiar::summon_familiar( + data = data, + experimental_design = "cv(mb, 3)+ev", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("cv + evaluation experiment is correctly created", { + testthat::expect_length(results$familiarModel, 3L) + testthat::expect_length(results$familiarData, 3L) + testthat::expect_setequal( + sapply(results$familiarData, function(x) (x@name)), + c("development", "internal_validation", "external_validation") + ) + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 3L) + testthat::expect_length(int_values, 3L) + testthat::expect_length(ext_values, 3L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) +}) + + +# Internal bootstraps (full) +results <- familiar::summon_familiar( + data = data, + experimental_design = "bs(mb, 3)+ev", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("bootstrap + evaluation experiment is correctly created", { + testthat::expect_length(results$familiarModel, 3L) + testthat::expect_length(results$familiarData, 3L) + testthat::expect_setequal( + sapply(results$familiarData, function(x) (x@name)), + c("development", "internal_validation", "external_validation") + ) + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 3L) + testthat::expect_length(int_values, 3L) + testthat::expect_length(ext_values, 3L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) +}) + + + +results <- familiar::summon_familiar( + data = data[c(1L:30L, 101L:150L),], + experimental_design = "lv(mb) + ev", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("loocv-only experiment is correctly created", { + testthat::expect_length(results$familiarModel, 30L) + testthat::expect_length(results$familiarData, 3L) + testthat::expect_setequal( + sapply(results$familiarData, function(x) (x@name)), + c("development", "internal_validation", "external_validation") + ) + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. Note that the detail-level is + # automatically changed to ensemble because of the limited number of values + # in the internal validation set (1 per fold.) + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 1L) + testthat::expect_length(int_values, 1L) + testthat::expect_length(ext_values, 1L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) +}) + + + +# Internal cross-validation with nested (full) bootstraps +results <- familiar::summon_familiar( + data = data, + experimental_design = "cv(bs(mb, 2), 3) + ev", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + iteration_seed = 9L, + parallel = FALSE, + verbose = debug_flag +) + +# Get predicted probabilities for red. The bootstraps might not visit all +# training data. More over the probabilities should generally be different +# because different models are used to predict each sample. +prediction_data <- merge( + x = results$familiarData[[1L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + y = results$familiarData[[3L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + by = "sample_id", + suffixes = c("_dev", "_int"), + all = FALSE +) + +testthat::test_that("cv-only with nested bootstraps experiment is correctly created", { + testthat::expect_length(results$familiarModel, 6L) + testthat::expect_length(results$familiarData, 3L) + testthat::expect_setequal( + sapply(results$familiarData, function(x) (x@name)), + c("development", "internal_validation", "external_validation") + ) + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 6L) + testthat::expect_length(int_values, 6L) + testthat::expect_length(ext_values, 6L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) + + # Expect that fewer than 150 samples appear in the training dataset. If this + # fails, check that the iteration seed correctly generates the same sample + # set consistently. + testthat::expect_lt( + nrow(results$familiarData[[1L]]@prediction_data[[1L]]@data), + nrow(data[batch_id == "basic"]) + ) + + # Expect that predicted probabilities are not all the same. + testthat::expect_false(all(prediction_data$red_dev == prediction_data$red_int)) + + # Expect that there is no overlap between development and external validation. + testthat::expect_equal( + nrow(merge( + x = results$familiarData[[1L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + y = results$familiarData[[2L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + by = "sample_id", + suffixes = c("_dev", "_ext"), + all = FALSE + )), + 0L + ) + + # Expect that there is no overlap between internal and external development. + testthat::expect_equal( + nrow(merge( + x = results$familiarData[[3L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + y = results$familiarData[[2L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + by = "sample_id", + suffixes = c("_int", "_ext"), + all = FALSE + )), + 0L + ) +}) diff --git a/tests/testthat/test-experimental_design_no_external_validation.R b/tests/testthat/test-experimental_design_no_external_validation.R new file mode 100644 index 00000000..77d5a2ce --- /dev/null +++ b/tests/testthat/test-experimental_design_no_external_validation.R @@ -0,0 +1,276 @@ +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +# Without external validation -------------------------------------------------- + +data <- familiar:::test_create_good_data(outcome_type = "binomial", to_data_object = FALSE) + +# Only training +results <- familiar::summon_familiar( + data = data, + experimental_design = "mb", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("development-only experiment is correctly created", { + testthat::expect_length(results$familiarModel, 1L) + testthat::expect_length(results$familiarData, 1L) + testthat::expect_equal(results$familiarData@name, "development") +}) + + +# Internal bootstraps (incomplete) +results <- familiar::summon_familiar( + data = data, + experimental_design = "bt(mb, 3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("incomplete bootstrap-only experiment is correctly created", { + testthat::expect_length(results$familiarModel, 3L) + testthat::expect_length(results$familiarData, 1L) + testthat::expect_equal(results$familiarData@name, "development") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + testthat::expect_length(performance_data$value, 3L) +}) + + +# Internal cross-validation +results <- familiar::summon_familiar( + data = data, + experimental_design = "cv(mb, 3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("cv-only experiment is correctly created", { + testthat::expect_length(results$familiarModel, 3L) + testthat::expect_length(results$familiarData, 2L) + testthat::expect_equal(results$familiarData[[1L]]@name, "development") + testthat::expect_equal(results$familiarData[[2L]]@name, "internal_validation") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + testthat::expect_length(dev_values, 3L) + testthat::expect_length(int_values, 3L) + testthat::expect_false(setequal(dev_values, int_values)) +}) + +# Internal bootstraps (full) +results <- familiar::summon_familiar( + data = data, + experimental_design = "bs(mb, 3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("bootstrap-only experiment is correctly created", { + testthat::expect_length(results$familiarModel, 3L) + testthat::expect_length(results$familiarData, 2L) + testthat::expect_equal(results$familiarData[[1L]]@name, "development") + testthat::expect_equal(results$familiarData[[2L]]@name, "internal_validation") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + testthat::expect_length(dev_values, 3L) + testthat::expect_length(int_values, 3L) + testthat::expect_false(setequal(dev_values, int_values)) +}) + + +# Leave-one-out cross-validation +results <- familiar::summon_familiar( + data = data[1:30L,], + experimental_design = "lv(mb)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("loocv-only experiment is correctly created", { + testthat::expect_length(results$familiarModel, 30L) + testthat::expect_length(results$familiarData, 2L) + testthat::expect_equal(results$familiarData[[1L]]@name, "development") + testthat::expect_equal(results$familiarData[[2L]]@name, "internal_validation") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. Note that the detail-level is + # automatically changed to ensemble because of the limited number of values + # in the cross-validation. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + testthat::expect_length(dev_values, 1L) + testthat::expect_length(int_values, 1L) + testthat::expect_false(setequal(dev_values, int_values)) +}) + + + +# Internal cross-validation with nested (incomplete) bootstraps +results <- familiar::summon_familiar( + data = data, + experimental_design = "cv(bt(mb, 2), 3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + iteration_seed = 9L, + parallel = FALSE, + verbose = debug_flag +) + +testthat::test_that("nested cv-only experiment is correctly created", { + testthat::expect_length(results$familiarModel, 6L) + testthat::expect_length(results$familiarData, 2L) + testthat::expect_equal(results$familiarData[[1L]]@name, "development") + testthat::expect_equal(results$familiarData[[2L]]@name, "internal_validation") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + testthat::expect_length(dev_values, 6L) + testthat::expect_length(int_values, 6L) + testthat::expect_false(setequal(dev_values, int_values)) +}) + + +# Internal cross-validation with nested (full) bootstraps +results <- familiar::summon_familiar( + data = data, + experimental_design = "cv(bs(mb, 2), 3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + iteration_seed = 9L, + parallel = FALSE, + verbose = debug_flag +) + + + +# Get predicted probabilities for red. The bootstraps might not visit all +# training data. More over the probabilities should generally be different +# because different models are used to predict each sample. +prediction_data <- merge( + x = results$familiarData[[1L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + y = results$familiarData[[2L]]@prediction_data[[1L]]@data[, mget(c("sample_id", "red"))], + by = "sample_id", + suffixes = c("_dev", "_int"), + all = FALSE +) + +testthat::test_that("cv-only with nested bootstraps experiment is correctly created", { + testthat::expect_length(results$familiarModel, 6L) + testthat::expect_length(results$familiarData, 2L) + testthat::expect_equal(results$familiarData[[1L]]@name, "development") + testthat::expect_equal(results$familiarData[[2L]]@name, "internal_validation") + + performance_data <- familiar::export_model_performance( + results$familiarCollection, + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + testthat::expect_length(dev_values, 6L) + testthat::expect_length(int_values, 6L) + testthat::expect_false(setequal(dev_values, int_values)) + + # Expect that fewer than 150 samples appear in the training dataset. If this + # fails, check that the iteration seed correctly generates the same sample + # set consistently. + testthat::expect_lt( + nrow(results$familiarData[[1L]]@prediction_data[[1L]]@data), + nrow(data) + ) + + # Expect that predicted probabilities are not all the same. + testthat::expect_false(all(prediction_data$red_dev == prediction_data$red_int)) +}) diff --git a/tests/testthat/test-experimental_design_unpooled_collection.R b/tests/testthat/test-experimental_design_unpooled_collection.R new file mode 100644 index 00000000..b293186b --- /dev/null +++ b/tests/testthat/test-experimental_design_unpooled_collection.R @@ -0,0 +1,218 @@ +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +data <- familiar:::test_create_good_data(outcome_type = "binomial", to_data_object = FALSE) +data[101L:150L, "batch_id" := "test"] + + +# With unpooled collections ---------------------------------------------------- + +# Set evaluate_top_level_only to FALSE evaluate underlying data divisions. +results <- familiar::summon_familiar( + data = data, + experimental_design = "cv(bs(mb, 2), 3) + ev", + evaluate_top_level_only = FALSE, + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + iteration_seed = 9L, + parallel = FALSE, + verbose = debug_flag +) + + +testthat::test_that("cv-only with nested bootstraps experiment is correctly created", { + testthat::expect_length(results$familiarModel, 6L) + testthat::expect_length(results$familiarData, 12L) + testthat::expect_length(results$familiarCollection, 4L) + testthat::expect_setequal( + sapply(results$familiarData, function(x) (x@name)), + c("development", "internal_validation", "external_validation") + ) + + pooled_collection <- results$familiarCollection[ + sapply(results$familiarCollection, function(x) (endsWith(x@name, "pooled_collection"))) + ][[1L]] + prediction_data <- familiar::export_prediction_data(pooled_collection) + prediction_data <- prediction_data$classification[[1L]]@data + ext_val_samples <- prediction_data[data_set == "ext. validation"]$sample_id + int_val_samples <- prediction_data[data_set == "int. validation"]$sample_id + dev_samples <- prediction_data[data_set == "development"]$sample_id + + testthat::expect_length(intersect(ext_val_samples, dev_samples), 0L) + testthat::expect_length(intersect(ext_val_samples, int_val_samples), 0L) + testthat::expect_length(ext_val_samples, nrow(data[batch_id == "test"])) + testthat::expect_length(int_val_samples, nrow(data[batch_id == "basic"])) + testthat::expect_lt(length(dev_samples), nrow(data[batch_id == "basic"])) + + cv_1_collection <- results$familiarCollection[ + sapply(results$familiarCollection, function(x) (endsWith(x@name, "2_1_collection"))) + ][[1L]] + prediction_data <- familiar::export_prediction_data(cv_1_collection) + prediction_data <- prediction_data$classification[[1L]]@data + ext_val_samples_1 <- prediction_data[data_set == "ext. validation"]$sample_id + int_val_samples_1 <- prediction_data[data_set == "int. validation"]$sample_id + dev_samples_1 <- prediction_data[data_set == "development"]$sample_id + + testthat::expect_length(intersect(ext_val_samples_1, dev_samples_1), 0L) + testthat::expect_length(intersect(ext_val_samples_1, int_val_samples_1), 0L) + testthat::expect_length(intersect(int_val_samples_1, dev_samples_1), 0L) + testthat::expect_length(ext_val_samples_1, nrow(data[batch_id == "test"])) + testthat::expect_lt(length(int_val_samples_1) + length(dev_samples_1), nrow(data[batch_id == "basic"])) + + cv_2_collection <- results$familiarCollection[ + sapply(results$familiarCollection, function(x) (endsWith(x@name, "2_2_collection"))) + ][[1L]] + prediction_data <- familiar::export_prediction_data(cv_2_collection) + prediction_data <- prediction_data$classification[[1L]]@data + ext_val_samples_2 <- prediction_data[data_set == "ext. validation"]$sample_id + int_val_samples_2 <- prediction_data[data_set == "int. validation"]$sample_id + dev_samples_2 <- prediction_data[data_set == "development"]$sample_id + + testthat::expect_length(intersect(ext_val_samples_2, dev_samples_2), 0L) + testthat::expect_length(intersect(ext_val_samples_2, int_val_samples_2), 0L) + testthat::expect_length(intersect(int_val_samples_2, dev_samples_2), 0L) + testthat::expect_length(ext_val_samples_2, nrow(data[batch_id == "test"])) + testthat::expect_lt(length(int_val_samples_2) + length(dev_samples_2), nrow(data[batch_id == "basic"])) + + cv_3_collection <- results$familiarCollection[ + sapply(results$familiarCollection, function(x) (endsWith(x@name, "2_3_collection"))) + ][[1L]] + prediction_data <- familiar::export_prediction_data(cv_3_collection) + prediction_data <- prediction_data$classification[[1L]]@data + ext_val_samples_3 <- prediction_data[data_set == "ext. validation"]$sample_id + int_val_samples_3 <- prediction_data[data_set == "int. validation"]$sample_id + dev_samples_3 <- prediction_data[data_set == "development"]$sample_id + + testthat::expect_length(intersect(ext_val_samples_3, dev_samples_3), 0L) + testthat::expect_length(intersect(ext_val_samples_3, int_val_samples_3), 0L) + testthat::expect_length(intersect(int_val_samples_3, dev_samples_3), 0L) + testthat::expect_length(ext_val_samples_3, nrow(data[batch_id == "test"])) + testthat::expect_lt(length(int_val_samples_3) + length(dev_samples_3), nrow(data[batch_id == "basic"])) + + # Internal validation folds between experiments do not overlap. + testthat::expect_length(intersect(int_val_samples_1, int_val_samples_2), 0L) + testthat::expect_length(intersect(int_val_samples_1, int_val_samples_3), 0L) + testthat::expect_length(intersect(int_val_samples_2, int_val_samples_3), 0L) + + # External validation folds between experiments are the same. + testthat::expect_setequal(ext_val_samples_1, ext_val_samples_2) + testthat::expect_setequal(ext_val_samples_1, ext_val_samples_3) + testthat::expect_setequal(ext_val_samples_2, ext_val_samples_3) + + # Pooled performance data. + performance_data <- familiar::export_model_performance( + results$familiarCollection[[4L]], + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 6L) + testthat::expect_length(int_values, 6L) + testthat::expect_length(ext_values, 6L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) + + for (ii in seq_len(3L)) { + # Get performance for individual folds. + performance_data <- familiar::export_model_performance( + results$familiarCollection[[ii]], + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. There are two models per fold. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 2L) + testthat::expect_length(int_values, 2L) + testthat::expect_length(ext_values, 2L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) + } +}) + + + +# Set evaluate_top_level_only to FALSE evaluate underlying data divisions. +results <- familiar::summon_familiar( + data = data[c(1L:30L, 101L:150L),], + experimental_design = "lv(mb) + ev", + evaluate_top_level_only = FALSE, + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + validation_batch_id = "test", + vimp_method = "mim", + learner = "glm_logistic", + estimation_type = "point", + shap_max_iterations = 10L, + iteration_seed = 9L, + parallel = FALSE, + verbose = FALSE +) + + +testthat::test_that("loocv with external validation experiment is correctly created", { + testthat::expect_length(results$familiarModel, 30L) + testthat::expect_length(results$familiarData, 93L) + testthat::expect_length(results$familiarCollection, 31L) + testthat::expect_setequal( + sapply(results$familiarData, function(x) (x@name)), + c("development", "internal_validation", "external_validation") + ) + + # This is the pooled data. + performance_data <- familiar::export_model_performance( + results$familiarCollection[[31L]], + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. Note that the detail-level is + # automatically changed to ensemble because of the limited number of values + # in the cross-validation. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 1L) + testthat::expect_length(int_values, 1L) + testthat::expect_length(dev_values, 1L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) + + # For individual folds of the leave-one-out cross-validation set. Note that + # performance data for internal validation data should be missing -- you + # cannot compute performance for internal validation (1 sample). + for (ii in seq_len(30L)) { + performance_data <- familiar::export_model_performance( + results$familiarCollection[[ii]], + aggregate_results = FALSE + )[[1L]]@data + + # Expect that the values are not the same. Note that the detail-level is + # automatically changed to ensemble because of the limited number of values + # in the cross-validation. + dev_values <- performance_data[data_set == "development"]$value + int_values <- performance_data[data_set == "int. validation"]$value + ext_values <- performance_data[data_set == "ext. validation"]$value + testthat::expect_length(dev_values, 1L) + testthat::expect_length(int_values, 0L) + testthat::expect_length(dev_values, 1L) + testthat::expect_false(setequal(dev_values, int_values)) + testthat::expect_false(setequal(dev_values, ext_values)) + } +}) diff --git a/tests/testthat/test-export_hyperparameters.R b/tests/testthat/test-export_hyperparameters.R index 71e32daa..999ab34d 100644 --- a/tests/testthat/test-export_hyperparameters.R +++ b/tests/testthat/test-export_hyperparameters.R @@ -11,7 +11,7 @@ familiar:::test_export( not_available_no_samples = FALSE, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), debug = debug_flag ) @@ -21,7 +21,7 @@ familiar:::test_export( not_available_no_samples = FALSE, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), export_args = list("aggregate_results" = FALSE), debug = debug_flag ) diff --git a/tests/testthat/test-export_ice.R b/tests/testthat/test-export_ice.R index 4433331c..03dafb7e 100644 --- a/tests/testthat/test-export_ice.R +++ b/tests/testthat/test-export_ice.R @@ -2,13 +2,15 @@ testthat::skip_on_cran() testthat::skip_on_ci() +debug_flag <- FALSE + # Default results <- familiar:::test_export_specific( export_function = familiar:::export_ice_data, data_element = "ice_data", sample_limit = 20L, create_novelty_detector = FALSE, - debug = TRUE + debug = debug_flag ) testthat::test_that("Sample limit is correctly propagated", { @@ -25,14 +27,14 @@ results <- familiar:::test_export_specific( export_function = familiar:::export_ice_data, outcome_type_available = "survival", data_element = "ice_data", - features = c("nodes"), + features = c("feature_1"), sample_limit = 20L, create_novelty_detector = FALSE, - debug = TRUE + debug = debug_flag ) testthat::test_that("A single feature can be specified.", { - testthat::expect_equal(results$survival[[1]]@identifiers$feature_x, "nodes") + testthat::expect_equal(results$survival[[1]]@identifiers$feature_x, "feature_1") testthat::expect_equal(length(results$survival), 1L) }) @@ -41,15 +43,15 @@ results <- familiar:::test_export_specific( export_function = familiar:::export_ice_data, outcome_type_available = "survival", data_element = "ice_data", - features = c("rx", "nodes"), + features = c("feature_4", "feature_1"), sample_limit = 20L, create_novelty_detector = FALSE, - debug = TRUE + debug = debug_flag ) testthat::test_that("Two features can be specified.", { - testthat::expect_equal(results$survival[[1]]@identifiers$feature_x, "rx") - testthat::expect_equal(results$survival[[1]]@identifiers$feature_y, "nodes") + testthat::expect_equal(results$survival[[1]]@identifiers$feature_x, "feature_4") + testthat::expect_equal(results$survival[[1]]@identifiers$feature_y, "feature_1") testthat::expect_equal(length(results$survival), 1L) }) @@ -59,20 +61,19 @@ results <- familiar:::test_export_specific( export_function = familiar:::export_ice_data, outcome_type_available = "survival", data_element = "ice_data", - features = c("rx", "nodes"), - feature_x_range = c("Obs", "Lev+5FU"), - feature_y_range = c(0, 10), + features = c("feature_4", "feature_1"), + feature_x_range = c("better", "best"), + feature_y_range = c(0.25, 0.75), n_sample_points = 5L, sample_limit = 20L, create_novelty_detector = FALSE, - debug = TRUE + debug = debug_flag ) testthat::test_that("Ranges and features can specified.", { - testthat::expect_setequal(unique(results$survival[[1]]@data$feature_x_value), c("Obs", "Lev+5FU")) - testthat::expect_equal(all(results$survival[[1]]@data$feature_y_value <= 10), TRUE) - testthat::expect_equal(all(results$survival[[1]]@data$feature_y_value >= 0), TRUE) - testthat::expect_equal(data.table::uniqueN(results$survival[[1]]@data$feature_y_value), 5L) + testthat::expect_setequal(unique(results$survival[[1]]@data$feature_x_value), c("better", "best")) + testthat::expect_true(all(results$survival[[1]]@data$feature_y_value <= 0.75)) + testthat::expect_true(all(results$survival[[1]]@data$feature_y_value >= 0.25)) }) # Test that test_export_specific works when specifying two features and their @@ -81,15 +82,35 @@ results <- familiar:::test_export_specific( export_function = familiar:::export_ice_data, outcome_type_available = "survival", data_element = "ice_data", - features = c("rx", "nodes"), - feature_x_range = c("Obs", "Lev+5FU"), - feature_y_range = c(0, 5, 10, 15), + features = c("feature_4", "feature_3a"), + feature_x_range = c("good", "better"), + feature_y_range = c("round", "square"), sample_limit = 20L, create_novelty_detector = FALSE, - debug = TRUE + debug = debug_flag ) testthat::test_that("Ranges and features can specified.", { - testthat::expect_setequal(unique(results$survival[[1]]@data$feature_x_value), c("Obs", "Lev+5FU")) - testthat::expect_setequal(unique(results$survival[[1]]@data$feature_y_value), c(0, 5, 10, 15)) + testthat::expect_setequal(unique(results$survival[[1]]@data$feature_x_value), c("good", "better")) + testthat::expect_setequal(unique(results$survival[[1]]@data$feature_y_value), c("round", "square")) +}) + + +# Test that test_export_specific works when specifying n_important_features. +results <- familiar:::test_export_specific( + export_function = familiar:::export_ice_data, + outcome_type_available = "continuous", + data_element = "ice_data", + n_important_features = 2L, + sample_limit = 20L, + create_novelty_detector = FALSE, + debug = debug_flag +) + +testthat::test_that("The number of important features can be set.", { + testthat::expect_length(results$continuous, 2L) + testthat::expect_setequal( + sapply(results$continuous, function(x) (x@identifiers$feature_x)), + c("feature_1", "feature_2b") + ) }) diff --git a/tests/testthat/test-export_model_performance.R b/tests/testthat/test-export_model_performance.R new file mode 100644 index 00000000..24af3d4a --- /dev/null +++ b/tests/testthat/test-export_model_performance.R @@ -0,0 +1,31 @@ +# Don't perform any further tests on CRAN due to running time. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +# Default +familiar:::test_export( + export_function = familiar:::export_model_performance, + data_element = "model_performance", + not_available_all_prospective = TRUE, + not_available_mostly_prospective = c("binomial", "multinomial", "survival"), + not_available_single_sample = c("binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + estimation_type = "point", + create_novelty_detector = FALSE, + use_prediction_table = TRUE, + debug = debug_flag +) + +results <- familiar:::test_export_specific( + export_function = familiar:::export_model_performance, + data_element = "model_performance", + not_available_all_prospective = TRUE, + not_available_mostly_prospective = c("binomial", "multinomial", "survival"), + not_available_single_sample = c("binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + create_novelty_detector = FALSE, + use_prediction_table = FALSE, + debug = debug_flag +) diff --git a/tests/testthat/test-export_permutation_vimp.R b/tests/testthat/test-export_permutation_vimp.R new file mode 100644 index 00000000..f68a62f5 --- /dev/null +++ b/tests/testthat/test-export_permutation_vimp.R @@ -0,0 +1,78 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +# Without setting the number of important features. +results <- familiar:::test_export_specific( + export_function = familiar:::export_permutation_vimp, + data_element = "permutation_vimp", + outcome_type_available = "continuous", + create_novelty_detector = FALSE, + debug = debug_flag +) + +testthat::test_that( + "all feature are assessed", + { + data <- results$continuous[[1L]]@data + features <- unique(data$feature) + testthat::expect_length(features, 6L) + } +) + + +# With setting the number of important features to 2. +results <- familiar:::test_export_specific( + export_function = familiar:::export_permutation_vimp, + data_element = "permutation_vimp", + outcome_type_available = "continuous", + n_important_features = 2L, + create_novelty_detector = FALSE, + debug = debug_flag +) + +testthat::test_that( + "the 2 most important features are assessed", + { + data <- results$continuous[[1L]]@data + features <- unique(data$feature) + testthat::expect_length(features, 2L) + testthat::expect_setequal(features, c("feature_1", "feature_2b")) + } +) + + +# With setting the number of important features to 2. +results <- familiar:::test_export_specific( + export_function = familiar:::export_permutation_vimp, + data_element = "permutation_vimp", + outcome_type_available = "continuous", + n_important_features = 2L, + n_models = 3L, + create_novelty_detector = FALSE, + debug = debug_flag +) + + +# With setting the number of important features to 1. +results <- familiar:::test_export_specific( + export_function = familiar:::export_permutation_vimp, + data_element = "permutation_vimp", + outcome_type_available = "continuous", + n_important_features = 1L, + create_novelty_detector = FALSE, + debug = debug_flag +) + +testthat::test_that( + "the most important feature is assessed", + { + data <- results$continuous[[1L]]@data + features <- unique(data$feature) + testthat::expect_length(features, 1L) + testthat::expect_setequal(features, "feature_1") + } +) diff --git a/tests/testthat/test-export_prediction_data.R b/tests/testthat/test-export_prediction_data.R index 3924248c..8ab2b6e2 100644 --- a/tests/testthat/test-export_prediction_data.R +++ b/tests/testthat/test-export_prediction_data.R @@ -9,7 +9,7 @@ familiar:::test_export( not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, data_element = "prediction_data", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), detail_level = "ensemble", create_novelty_detector = TRUE, debug = debug_flag @@ -20,14 +20,14 @@ familiar:::test_export( not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, data_element = "prediction_data", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), detail_level = "hybrid", estimation_type = "bci", confidence_level = 0.80, aggregate_results = TRUE, create_novelty_detector = TRUE, n_models = 100, - test_specific_config = TRUE, + test_config = "normal", debug = debug_flag ) @@ -36,13 +36,13 @@ familiar:::test_export( not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, data_element = "prediction_data", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), detail_level = "hybrid", estimation_type = "bias_correction", confidence_level = 0.80, aggregate_results = TRUE, create_novelty_detector = TRUE, n_models = 20, - test_specific_config = TRUE, + test_config = "normal", debug = debug_flag ) diff --git a/tests/testthat/test-export_shap.R b/tests/testthat/test-export_shap.R new file mode 100644 index 00000000..b9e0b736 --- /dev/null +++ b/tests/testthat/test-export_shap.R @@ -0,0 +1,28 @@ +# Don't perform any further tests on CRAN due to running time. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- TRUE + +results <- familiar:::test_export_specific( + export_function = familiar:::export_shap, + outcome_type_available = "multinomial", + data_element = "shap", + create_novelty_detector = FALSE, + debug = debug_flag, + export_args = list( + feature_x = "feature_1", + feature_y = "feature_2a" + ) +) + + + +# Default +results <- familiar:::test_export_specific( + export_function = familiar:::export_shap, + outcome_type_available = "multinomial", + data_element = "shap", + create_novelty_detector = FALSE, + debug = debug_flag +) diff --git a/tests/testthat/test-familiar_data_creation.R b/tests/testthat/test-familiar_data_creation.R index 4adeac1f..553805f6 100644 --- a/tests/testthat/test-familiar_data_creation.R +++ b/tests/testthat/test-familiar_data_creation.R @@ -3,9 +3,7 @@ testthat::skip_on_cran() testthat::skip_on_ci() familiar_data_creation_unit_test <- function(outcome_type) { - if (outcome_type == "count") { - learner <- "glm_poisson" - } else if (outcome_type == "continuous") { + if (outcome_type == "continuous") { learner <- "glm_gaussian" } else if (outcome_type == "binomial") { learner <- "glm_logistic" @@ -27,7 +25,7 @@ familiar_data_creation_unit_test <- function(outcome_type) { imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = learner, - time_max = 1832)) + time_max = 3.5)) testthat::test_that( paste0( @@ -108,7 +106,7 @@ familiar_data_creation_unit_test <- function(outcome_type) { imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = learner, - time_max = 1832)) + time_max = 3.5)) testthat::test_that( paste0( @@ -155,7 +153,7 @@ familiar_data_creation_unit_test <- function(outcome_type) { imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = learner, - time_max = 1832)) + time_max = 3.5)) testthat::test_that( paste0( @@ -209,7 +207,6 @@ familiar_data_creation_unit_test <- function(outcome_type) { ) } -familiar_data_creation_unit_test("count") familiar_data_creation_unit_test("continuous") familiar_data_creation_unit_test("binomial") familiar_data_creation_unit_test("multinomial") diff --git a/tests/testthat/test-general_normalisation.R b/tests/testthat/test-general_normalisation.R index 2e98b006..31e08391 100644 --- a/tests/testthat/test-general_normalisation.R +++ b/tests/testthat/test-general_normalisation.R @@ -289,12 +289,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_normalisation_parameter_skeleton( @@ -416,12 +411,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_normalisation_parameter_skeleton( @@ -490,12 +480,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_normalisation_parameter_skeleton( @@ -573,12 +558,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_normalisation_parameter_skeleton( @@ -629,12 +609,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_normalisation_parameter_skeleton( @@ -712,12 +687,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_normalisation_parameter_skeleton( diff --git a/tests/testthat/test-hyperparameter_optimisation.R b/tests/testthat/test-hyperparameter_optimisation.R index b9bf11ff..7bed5ad9 100644 --- a/tests/testthat/test-hyperparameter_optimisation.R +++ b/tests/testthat/test-hyperparameter_optimisation.R @@ -57,175 +57,187 @@ familiar:::test_hyperparameter_optimisation( debug = FALSE, parallel = FALSE) -# Create dataset. -data <- familiar:::test_create_good_data(outcome_type = "binomial") # Test that "none" feature selection keeps all features ------------------------ +..generate_hyperparameters <- function( + data, + learner, + vimp_method, + set_signature = FALSE, + cluster_method = "none", + cluster_similarity_metric = "mcfadden_r2", + cluster_similarity_threshold = 0.90, + use_vimp = "use_hpo_vimp", + ... +) { + # Reconstitute settings from the data. + settings <- familiar:::extract_settings_from_data(data = data) + + # Update some missing settings that can be fixed within this method. + settings$data$train_cohorts <- unique(data@data[[familiar:::get_id_columns(single_column = "batch")]]) + if (set_signature) { + settings$data$signature <- familiar:::get_feature_columns(data)[1L:2L] + } + + # Parse the remaining settings that are important. + settings <- do.call( + familiar:::.parse_general_settings, + args = c( + list( + "settings" = settings, + "data" = data@data, + "vimp_method" = vimp_method, + "learner" = learner, + "cluster_method" = cluster_method, + "cluster_similarity_metric" = cluster_similarity_metric, + "cluster_similarity_threshold" = cluster_similarity_threshold + ) + ) + ) + + # Create task. + task <- methods::new( + "familiarTaskLearnerHyperparameters", + vimp_method = vimp_method, + learner = learner, + use_vimp = use_vimp + ) + + # Optimise hyperparameters. + new_object <- familiar:::.perform_task( + object = task, + data = data, + settings = settings, + ... + ) + + return(new_object) +} + +# Create dataset. +data <- familiar:::test_create_good_data(outcome_type = "binomial") -# Create object. -object <- familiar:::.test_create_hyperparameter_object( +# Optimise hyperparameters. +new_object <- ..generate_hyperparameters( data = data, vimp_method = "none", learner = "elastic_net", - is_vimp = FALSE, - set_signature_feature = FALSE) - -# Hyperparameter optimisation. -new_object <- familiar:::optimise_hyperparameters( - object = object, - data = data, n_max_bootstraps = 25L, n_max_optimisation_steps = 3L, n_max_intensify_steps = 2L, n_random_sets = 20L, n_challengers = 10L, - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) testthat::test_that("Test that \"none\" feature selection keeps all features.", { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == familiar:::get_n_features(data)), - TRUE) + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size == familiar:::get_n_features(data))) }) # Test that "random" feature selection can select up to the maximum number of features ------ -object <- familiar:::.test_create_hyperparameter_object( + +# Optimise hyperparameters. +new_object <- ..generate_hyperparameters( data = data, vimp_method = "random", learner = "elastic_net", - is_vimp = FALSE, - set_signature_feature = FALSE) - -# Hyperparameter optimisation. -new_object <- familiar:::optimise_hyperparameters( - object = object, - data = data, n_max_bootstraps = 25L, n_max_optimisation_steps = 3L, n_max_intensify_steps = 2L, n_random_sets = 20L, n_challengers = 10L, - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) testthat::test_that("Test that \"random\" feature selection can select up to the maximum number of features.", { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size >= 1L & - new_object@hyperparameter_data$parameter_table$sign_size <= familiar:::get_n_features(data)), - TRUE) + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size >= 1L)) + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size <= familiar:::get_n_features(data))) }) + # Test that "signature_only" keeps only signature features --------------------- -object <- familiar:::.test_create_hyperparameter_object( + +# Optimise hyperparameters. +new_object <- ..generate_hyperparameters( data = data, vimp_method = "signature_only", learner = "elastic_net", - is_vimp = FALSE, - set_signature_feature = TRUE) - -# Hyperparameter optimisation. -new_object <- familiar:::optimise_hyperparameters( - object = object, - data = data, + set_signature = TRUE, n_max_bootstraps = 25L, n_max_optimisation_steps = 3L, n_max_intensify_steps = 2L, n_random_sets = 20L, n_challengers = 10L, - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) testthat::test_that("Test that \"signature_only\" feature selection keeps only signature features.", { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size == 2L), - TRUE) + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size == 2L)) }) + # Test that a range of signature sizes can be provided ------------------------- -object <- familiar:::.test_create_hyperparameter_object( + +# Optimise hyperparameters. +new_object <- ..generate_hyperparameters( data = data, vimp_method = "mim", learner = "elastic_net", - is_vimp = FALSE, - set_signature_feature = TRUE) - -# Hyperparameter optimisation. -new_object <- familiar:::optimise_hyperparameters( - object = object, - data = data, - user_list = list("sign_size" = c(2, 5)), + set_signature = FALSE, + hyperparameters = list("sign_size" = c(2, 5)), n_max_bootstraps = 25L, n_max_optimisation_steps = 3L, n_max_intensify_steps = 2L, n_random_sets = 20L, n_challengers = 10L, - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) -testthat::test_that("Test that \"signature_only\" feature selection keeps only signature features.", { - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size >= 2L & - new_object@hyperparameter_data$parameter_table$sign_size <= 5L), - TRUE) - testthat::expect_equal( - all(new_object@hyperparameter_data$parameter_table$sign_size %in% 2:5), - TRUE) - testthat::expect_equal( - length(setdiff(unique(new_object@hyperparameter_data$parameter_table$sign_size), c(2, 5))) >= 1, - TRUE) +testthat::test_that("Test that setting a range of signature sizes works correctly.", { + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size >= 2L)) + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size <= 5L)) + testthat::expect_true(all(unique(new_object@hyperparameter_data$parameter_table$sign_size) %in% 2L:5L)) }) + # Test that a range of signature sizes can be provided ------------------------- -object <- familiar:::.test_create_hyperparameter_object( + +# Optimise hyperparameters. +new_object <- ..generate_hyperparameters( data = data, vimp_method = "mim", learner = "elastic_net", - is_vimp = FALSE, - set_signature_feature = FALSE) - - -# Hyperparameter optimisation. -new_object <- familiar:::optimise_hyperparameters( - object = object, - data = data, - user_list = list("sign_size" = c(1, 4, 8)), + set_signature = FALSE, + hyperparameters = list("sign_size" = c(1, 4, 6)), n_max_bootstraps = 25L, n_max_optimisation_steps = 3L, n_max_intensify_steps = 2L, n_random_sets = 20L, n_challengers = 10L, - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) testthat::test_that("Test that \"signature_only\" feature selection keeps only signature features.", { testthat::expect_setequal( unique(new_object@hyperparameter_data$parameter_table$sign_size), - c(1, 4, 8)) + c(1, 4, 6) + ) }) # Test exploration methods ----------------------------------------------------- -# Create dataset. -data <- familiar:::test_create_good_data(outcome_type = "binomial") - -# Create object. -object <- familiar:::.test_create_hyperparameter_object( +# Optimise hyperparameters. +new_object <- ..generate_hyperparameters( data = data, vimp_method = "mim", learner = "elastic_net", - is_vimp = FALSE, - set_signature_feature = FALSE) - -# Hyperparameter optimisation without pruning. -new_object <- familiar:::optimise_hyperparameters( - object = object, - data = data, + set_signature = FALSE, n_max_bootstraps = 25L, n_max_optimisation_steps = 1L, n_max_intensify_steps = 4L, @@ -233,8 +245,8 @@ new_object <- familiar:::optimise_hyperparameters( n_random_sets = 16L, n_challengers = 10L, exploration_method = "none", - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) # Set expected range of rows. Upper and lower boundary are the same, as all runs # are executed simultaneously. @@ -249,12 +261,15 @@ testthat::test_that(paste0( ) + # Hyperparameter optimisation using successive_halving for pruning. Note that # n_max_intensify_steps is 5, but only 4 will be steps are possible. Just as a # test. -new_object <- familiar:::optimise_hyperparameters( - object = object, +new_object <- ..generate_hyperparameters( data = data, + vimp_method = "mim", + learner = "elastic_net", + set_signature = FALSE, n_max_bootstraps = 25L, n_max_optimisation_steps = 1L, n_max_intensify_steps = 5L, @@ -262,8 +277,8 @@ new_object <- familiar:::optimise_hyperparameters( n_random_sets = 16L, n_challengers = 10L, exploration_method = "successive_halving", - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) # Set expected range of rows. 10 initial challengers decrease to 5, 2 and 1 in # subsequent rounds. Upper and lower boundary are the same because here @@ -279,10 +294,14 @@ testthat::test_that(paste0( } ) + + # Hyperparameter optimisation using stochastic_reject for pruning. -new_object <- familiar:::optimise_hyperparameters( - object = object, +new_object <- ..generate_hyperparameters( data = data, + vimp_method = "mim", + learner = "elastic_net", + set_signature = FALSE, n_max_bootstraps = 25L, n_max_optimisation_steps = 1L, n_max_intensify_steps = 4L, @@ -291,8 +310,8 @@ new_object <- familiar:::optimise_hyperparameters( n_random_sets = 16L, n_challengers = 10L, exploration_method = "stochastic_reject", - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) # Set expected range of rows. The lowest boundary occurs when all challengers # are rejected after one round, and only one new run is sampled. The upper @@ -309,11 +328,15 @@ testthat::test_that(paste0( } ) + + # Single-shot hyperparameter optimisation. Note that n_intensify_step_bootstraps # and n_max_intensify_steps should be set to 1L internally. -new_object <- familiar:::optimise_hyperparameters( - object = object, +new_object <- ..generate_hyperparameters( data = data, + vimp_method = "mim", + learner = "elastic_net", + set_signature = FALSE, n_max_bootstraps = 25L, n_max_optimisation_steps = 1L, n_max_intensify_steps = 4L, @@ -321,8 +344,8 @@ new_object <- familiar:::optimise_hyperparameters( n_random_sets = 16L, n_challengers = 10L, exploration_method = "single_shot", - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) # Set expected range of rows. Upper and lower boundary are the same, as all runs # are executed simultaneously. @@ -337,24 +360,16 @@ testthat::test_that(paste0( ) -# Test time truncation --------------------------------------------------------- - -# Create dataset. -data <- familiar:::test_create_good_data(outcome_type = "binomial") -# Create object. -object <- familiar:::.test_create_hyperparameter_object( - data = data, - vimp_method = "mim", - learner = "elastic_net", - is_vimp = FALSE, - set_signature_feature = FALSE) +# Test time truncation --------------------------------------------------------- # Hyperparameter optimisation without pruning and marginal time limit. This # should just complete the initial step. -new_object <- familiar:::optimise_hyperparameters( - object = object, +new_object <- ..generate_hyperparameters( data = data, + vimp_method = "mim", + learner = "elastic_net", + set_signature = FALSE, time_limit = 0.000001, n_max_bootstraps = 25L, n_max_optimisation_steps = 1L, @@ -363,37 +378,33 @@ new_object <- familiar:::optimise_hyperparameters( n_random_sets = 16L, n_challengers = 10L, exploration_method = "none", - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) testthat::test_that("Time limits are respected and only the initial bootstraps are run.", { testthat::expect_gte(new_object@hyperparameter_data$time_taken, 0.000001) - testthat::expect_equal(all(new_object@hyperparameter_data$score_table$iteration_id == 0), TRUE) + testthat::expect_true(all(new_object@hyperparameter_data$score_table$iteration_id == 0)) }) # Test that clustered data are correctly handled ------------------------------- + # Create data, data <- familiar:::test_create_synthetic_correlated_data( outcome_type = "continuous", n_numeric = 4, - cluster_size = c(3, 3, 3, 3)) + cluster_size = c(3, 3, 3, 3) +) -# Create object. -object <- familiar:::.test_create_hyperparameter_object( +# Optimise hyperparameters. +new_object <- ..generate_hyperparameters( data = data, vimp_method = "mim", learner = "elastic_net", - is_vimp = FALSE, cluster_method = "hclust", cluster_similarity_metric = "mcfadden_r2", cluster_similarity_threshold = 0.90, - set_signature_feature = FALSE) - -new_object <- familiar:::optimise_hyperparameters( - object = object, - data = data, n_max_bootstraps = 25L, n_max_optimisation_steps = 1L, n_max_intensify_steps = 5L, @@ -401,14 +412,42 @@ new_object <- familiar:::optimise_hyperparameters( n_random_sets = 16L, n_challengers = 10L, exploration_method = "successive_halving", - is_vimp = FALSE, - verbose = verbose) + verbose = verbose +) testthat::test_that("One to four features are assessed for clustered features.", { - testthat::expect( - all(new_object@hyperparameter_data$parameter_table$sign_size >= 1 & - new_object@hyperparameter_data$parameter_table$sign_size <= 4), - TRUE) - testthat::expect(any(new_object@hyperparameter_data$parameter_table$sign_size == 1), TRUE) - testthat::expect(any(new_object@hyperparameter_data$parameter_table$sign_size == 4), TRUE) + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size >= 1)) + testthat::expect_true(all(new_object@hyperparameter_data$parameter_table$sign_size <= 4)) + testthat::expect_true(any(new_object@hyperparameter_data$parameter_table$sign_size == 1)) + testthat::expect_true(any(new_object@hyperparameter_data$parameter_table$sign_size == 4)) +}) + + +# Test that data with only one relevant feature are correctly handled ---------- + +# Create data. +data <- familiar:::test_create_single_relevant_feature_data(outcome_type = "continuous") + +new_object <- ..generate_hyperparameters( + data = data, + vimp_method = "familiarMultivariateInfoVimpTestSingle", + learner = "glm_gaussian", + use_vimp = "return_hpo_vimp", + verbose = verbose +) + +testthat::test_that("Variable importance information is returned.", { + testthat::expect_false(familiar:::is_empty(new_object@vimp_table)) +}) + +new_object <- ..generate_hyperparameters( + data = data, + vimp_method = "familiarMultivariateInfoVimpTestSingle", + learner = "glm_gaussian", + use_vimp = "use_hpo_vimp", + verbose = verbose +) + +testthat::test_that("Variable importance information is not returned.", { + testthat::expect_true(familiar:::is_empty(new_object@vimp_table)) }) diff --git a/tests/testthat/test-imputation.R b/tests/testthat/test-imputation.R index ed5b8e55..9c8cf459 100644 --- a/tests/testthat/test-imputation.R +++ b/tests/testthat/test-imputation.R @@ -24,12 +24,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -89,12 +84,7 @@ for (n_numeric_features in c(3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -154,12 +144,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -216,12 +201,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -277,12 +257,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -353,12 +328,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -414,12 +384,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -474,12 +439,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -539,12 +499,7 @@ for (n_numeric_features in c(1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list <- familiar:::create_imputation_parameter_skeleton( @@ -600,12 +555,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Create imputation skeleton. feature_info_list_1 <- familiar:::create_imputation_parameter_skeleton( diff --git a/tests/testthat/test-iteration_seed.R b/tests/testthat/test-iteration_seed.R new file mode 100644 index 00000000..6c6c8580 --- /dev/null +++ b/tests/testthat/test-iteration_seed.R @@ -0,0 +1,87 @@ +# Don't perform any further tests on CRAN due to running time. +testthat::skip_on_cran() + +# power.transform and other packages are required. +if (!rlang::is_installed("power.transform")) testthat::skip() + +# Create data.table. +data <- familiar:::test_create_good_data( + outcome_type = "binomial", + to_data_object = FALSE +) + +# Check reproducibility of sample assignment ----------------------------------- + +# Create data assignment object without fixed seed. +experiment_data_assignment_random <- familiar::precompute_data_assignment( + data = data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) + +# Create data assignment object with fixed seed. +experiment_data_assignment_a <- familiar::precompute_data_assignment( + data = data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + iteration_seed = 19L, + verbose = FALSE +) + +# Create data assignment object with fixed seed. +experiment_data_assignment_b <- familiar::precompute_data_assignment( + data = data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + iteration_seed = 19L, + verbose = FALSE +) + +# Create data assignment object with fixed seed. +experiment_data_assignment_different <- familiar::precompute_data_assignment( + data = data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + iteration_seed = 20L, + verbose = FALSE +) + +# Test that the same fixed seed leads to the same sample assignment. +testthat::expect_equal( + experiment_data_assignment_a@iteration_list, + experiment_data_assignment_b@iteration_list, + ignore_attr = TRUE +) + +# Test that the random seed leads to a different sample assignment. +testthat::expect_false(identical( + experiment_data_assignment_random@iteration_list, + experiment_data_assignment_a@iteration_list +)) + +# Test that a different fixed seed leads to a different sample assignment. +testthat::expect_false(identical( + experiment_data_assignment_different@iteration_list, + experiment_data_assignment_a@iteration_list +)) diff --git a/tests/testthat/test-learner_cox_s4.R b/tests/testthat/test-learner_cox_s4.R index de81261d..a0356d1e 100644 --- a/tests/testthat/test-learner_cox_s4.R +++ b/tests/testthat/test-learner_cox_s4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_cox_learners(show_general = TRUE)) + learners = familiar:::.get_available_cox_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the test. testthat::skip_on_cran() @@ -8,14 +9,15 @@ testthat::skip_on_ci() # Generic test familiar:::test_all_learners_train_predict_vimp( - learners = familiar:::.get_available_cox_learners(show_general = TRUE)) + learners = familiar:::.get_available_cox_learners(show_general = TRUE) +) familiar:::test_all_learners_parallel_train_predict_vimp( - learners = familiar:::.get_available_cox_learners(show_general = TRUE)) + learners = familiar:::.get_available_cox_learners(show_general = TRUE) +) # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -23,32 +25,15 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "cox") - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "cox")) + learner = "cox" +) testthat::test_that("Cox model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) - # Test the prediction type - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "hazard_ratio") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") - - # Checkt that no deprecation warnings are given. + # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) # Test that no errors appear. @@ -59,53 +44,26 @@ testthat::test_that("Cox model trained correctly", { testthat::test_that("Cox model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 3) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_equal( - all(familiar:::get_feature_columns(good_data) %in% vimp_table$name), - TRUE) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "nodes") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "rx") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Cox model does not train for wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), FALSE) - - # No variable importance table. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), TRUE) - - # No valid predictions. - testthat::expect_equal( - familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type), - FALSE) - - # No valid survival probability predictions. - testthat::expect_equal( - familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type), - FALSE) - - # Test that specific warnings and errors appear. - testthat::expect_equal(length(wide_model@messages$warning), 1L) - testthat::expect_equal( - grepl(x = wide_model@messages$warning, pattern = "did not converge", fixed = TRUE), - TRUE) - - testthat::expect_equal(length(wide_model@messages$error), 1L) - testthat::expect_equal( - grepl(x = wide_model@messages$error, pattern = "did not converge", fixed = TRUE), - TRUE) -}) +familiar:::test_hyperparameter_optimisation( + learners = "cox", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) testthat::skip("Skip hyperparameter optimisation, unless manual.") @@ -114,4 +72,5 @@ testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_cox_learners(show_general = TRUE), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) diff --git a/tests/testthat/test-learner_glm_S4.R b/tests/testthat/test-learner_glm_S4.R index fbf38754..f6f477a3 100644 --- a/tests/testthat/test-learner_glm_S4.R +++ b/tests/testthat/test-learner_glm_S4.R @@ -1,96 +1,26 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_glm_learners(show_general = TRUE)) + learners = familiar:::.get_available_glm_learners(show_general = TRUE) +) -# Don't perform any further tests on CRAN due to time of running the complete test. +# Don't perform any further tests on CRAN due to time of running the complete +# test. testthat::skip_on_cran() testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( - learners = familiar:::.get_available_glm_learners(show_general = FALSE)) + learners = familiar:::.get_available_glm_learners(show_general = FALSE) +) familiar:::test_all_learners_parallel_train_predict_vimp( - learners = familiar:::.get_available_glm_learners(show_general = FALSE)) - -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "glm_poisson") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "glm_poisson") - -testthat::test_that("Generalised linear model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Generalised linear model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 13) - - # Expect that the names are the same as that of the features. - testthat::expect_equal( - all(familiar:::get_feature_columns(good_data) %in% vimp_table$name), - TRUE) - - testthat::expect_true( - all(vimp_table[rank <= 2, ]$name %in% c("avg_rooms", "lower_status_percentage", "industry"))) -}) - - -testthat::test_that("Generalised linear model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - suppressWarnings(testthat::expect_equal( - familiar:::is_empty(familiar:::get_vimp_table(wide_model)), FALSE)) - - # Valid predictions. - suppressWarnings(testthat::expect_equal( - familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type), - TRUE)) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) + learners = familiar:::.get_available_glm_learners(show_general = FALSE) +) # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -98,19 +28,12 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "glm_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "glm_gaussian") + learner = "glm_gaussian" +) testthat::test_that("Generalised linear model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -124,36 +47,16 @@ testthat::test_that("Generalised linear model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 10) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) # Expect that the names are the same as that of the features. testthat::expect_true( - all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) - # Expect that calwpct has rank 1 and elpct has rank 2. - testthat::expect_true(all(vimp_table[rank <= 2, ]$name %in% c("calwpct", "avginc", "elpct"))) -}) - - -testthat::test_that("Generalised linear model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - suppressWarnings(testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model)))) - - # Valid predictions. - suppressWarnings(testthat::expect_true( - familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type))) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) @@ -161,7 +64,6 @@ testthat::test_that("Generalised linear model can train on wide data", { # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -169,19 +71,12 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "glm_logistic") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "glm_logistic") + learner = "glm_logistic" +) testthat::test_that("Generalised linear model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -194,47 +89,24 @@ testthat::test_that("Generalised linear model trained correctly", { testthat::test_that("Generalised linear model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 8) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. testthat::expect_true( - all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that bare_nuclei has rank 1 and clump_thickness has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "bare_nuclei") - testthat::expect_equal(vimp_table[rank == 2, ]$name %in% c("clump_thickness", "cell_shape_uniformity"), TRUE) -}) - - -testthat::test_that("Generalised linear model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - suppressWarnings(testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model)))) - - # Valid predictions. - suppressWarnings(testthat::expect_true( - familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type))) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) - # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- suppressWarnings(familiar:::test_train( @@ -242,19 +114,12 @@ good_model <- suppressWarnings(familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "glm_multinomial")) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "glm_multinomial") + learner = "glm_multinomial" +)) testthat::test_that("Generalised linear model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning, "deprec") @@ -266,33 +131,17 @@ testthat::test_that("Generalised linear model trained correctly", { testthat::test_that("Generalised linear model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 4) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that Petal length has rank 1 and petal width has rank 2. - testthat::expect_true(all(vimp_table[rank <= 2, ]$name %in% c("Petal_Length", "Petal_Width"))) -}) - - -testthat::test_that("Generalised linear model can train on wide data", { - # Model can be trained -- even if the neural network does not converge - # completely, it still functions. - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is empty. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is among the most important. + testthat::expect_true("feature_1" %in% vimp_table[rank <= 2, ]$name) }) @@ -300,7 +149,6 @@ testthat::test_that("Generalised linear model can train on wide data", { # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -308,24 +156,13 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - time_max = 1832, - learner = "glm") - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - time_max = 1832, - learner = "glm")) + time_max = 3.5, + learner = "glm" +) testthat::test_that("Generalised linear model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that the model predicts hazard ratios. - testthat::expect_equal(familiar:::get_prediction_type(good_model), "hazard_ratio") + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -338,47 +175,26 @@ testthat::test_that("Generalised linear model trained correctly", { testthat::test_that("Generalised linear model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 3) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "nodes") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "rx") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Generalised linear model cannot train on wide data", { - # Model was not trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), FALSE) - - # Variable importance table is empty. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions are not possible. - testthat::expect_false(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Valid survival probability predictions can not be made. - testthat::expect_false(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - - # Test that specific warnings and errors appear. - testthat::expect_equal(length(wide_model@messages$warning), 1L) - testthat::expect_equal( - grepl(x = wide_model@messages$warning, pattern = "did not converge", fixed = TRUE), - TRUE) - - testthat::expect_equal(length(wide_model@messages$error), 1L) - testthat::expect_equal( - grepl(x = wide_model@messages$error, pattern = "did not converge", fixed = TRUE), - TRUE) -}) +familiar:::test_hyperparameter_optimisation( + learners = "glm", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) testthat::skip("Skip hyperparameter optimisation, unless manual.") @@ -387,4 +203,5 @@ testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_glm_learners(show_general = TRUE), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) diff --git a/tests/testthat/test-learner_glmnet_S4.R b/tests/testthat/test-learner_glmnet_S4.R index eb1791df..ad072e8b 100644 --- a/tests/testthat/test-learner_glmnet_S4.R +++ b/tests/testthat/test-learner_glmnet_S4.R @@ -1,111 +1,55 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_glmnet_ridge_learners(show_general = TRUE)) + learners = familiar:::.get_available_glmnet_ridge_learners(show_general = TRUE) +) familiar:::test_all_learners_available( - learners = familiar:::.get_available_glmnet_lasso_learners(show_general = TRUE)) + learners = familiar:::.get_available_glmnet_lasso_learners(show_general = TRUE) +) familiar:::test_all_learners_available( - learners = familiar:::.get_available_glmnet_elastic_net_learners(show_general = TRUE)) + learners = familiar:::.get_available_glmnet_elastic_net_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete test. testthat::skip_on_cran() testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( - learners = familiar:::.get_available_glmnet_ridge_learners(show_general = FALSE)) + learners = familiar:::.get_available_glmnet_ridge_learners(show_general = FALSE) +) familiar:::test_all_learners_train_predict_vimp( - learners = familiar:::.get_available_glmnet_lasso_learners(show_general = FALSE)) + learners = familiar:::.get_available_glmnet_lasso_learners(show_general = FALSE) +) familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_glmnet_elastic_net_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list("alpha" = 0.50), "continuous" = list("alpha" = 0.50), "binomial" = list("alpha" = 0.50), "multinomial" = list("alpha" = 0.50), - "survival" = list("alpha" = 0.50))) + "survival" = list("alpha" = 0.50) + ) +) familiar:::test_all_learners_parallel_train_predict_vimp( - learners = familiar:::.get_available_glmnet_ridge_learners(show_general = FALSE)) + learners = familiar:::.get_available_glmnet_ridge_learners(show_general = FALSE) +) familiar:::test_all_learners_parallel_train_predict_vimp( - learners = familiar:::.get_available_glmnet_lasso_learners(show_general = FALSE)) + learners = familiar:::.get_available_glmnet_lasso_learners(show_general = FALSE) +) familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_glmnet_elastic_net_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list("alpha" = 0.50), "continuous" = list("alpha" = 0.50), "binomial" = list("alpha" = 0.50), "multinomial" = list("alpha" = 0.50), - "survival" = list("alpha" = 0.50))) + "survival" = list("alpha" = 0.50) + ) +) -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "lasso") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "lasso") - -testthat::test_that("Regularised regression model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - -testthat::test_that("Regularised regression model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has entries up to the number of features. - testthat::expect_equal(nrow(vimp_table) <= familiar:::get_n_features(good_data), TRUE) - - # Expect that the names are the same as that of the features. - testthat::expect_equal(all(vimp_table$name %in% familiar:::get_feature_columns(good_data)), TRUE) - - # Expect specific features to be highly ranked. - testthat::expect_true( - any(vimp_table[rank <= 2]$name %in% c( - "avg_rooms", "per_capita_crime", "lower_status_percentage", "industry", "large_residence_proportion"))) -}) - -testthat::test_that("Regularised regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -113,19 +57,12 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "lasso_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "lasso_gaussian") + learner = "lasso_gaussian" +) testthat::test_that("Regularised regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -137,41 +74,24 @@ testthat::test_that("Regularised regression model trained correctly", { testthat::test_that("Regularised regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table) <= 10, TRUE) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that avginc has rank 1 and calwpct has rank 2. - testthat::expect_true(vimp_table[rank == 1, ]$name %in% c( - "avginc", "calwpct", "teachers", "enrltot")) - testthat::expect_true(vimp_table[rank == 2, ]$name %in% c( - "avginc", "calwpct", "teachers", "enrltot")) + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Regularised regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -179,19 +99,12 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "lasso_binomial") - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "lasso_binomial")) + learner = "lasso_binomial" +) testthat::test_that("Regularised regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -204,40 +117,24 @@ testthat::test_that("Regularised regression model trained correctly", { testthat::test_that("Regularised regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_lte(nrow(vimp_table), 8) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(any(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - testthat::expect_true(all(vimp_table[rank <= 2, ]$name %in% c("cell_shape_uniformity", "mitoses", "bare_nuclei"))) + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Regularised regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), FALSE) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -245,19 +142,12 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "lasso_multinomial") - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "lasso_multinomial")) + learner = "lasso_multinomial" +) testthat::test_that("Regularised regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -270,61 +160,24 @@ testthat::test_that("Regularised regression model trained correctly", { testthat::test_that("Regularised regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 4) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that Petal length has rank 1 and petal width has rank 2. - testthat::expect_true(all(vimp_table[rank <= 2, ]$name %in% c("Petal_Length", "Petal_Width"))) + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -# This model may occasionally be able to train. -testthat::test_that("Regularised regression model can not train on wide data", { - if (familiar:::model_is_trained(wide_model)) { - # Variable importance table is not empty. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Check that the expected error appears. - testthat::expect_equal(wide_model@messages$error, NULL) - - } else { - # Variable importance table is empty. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions cannot be made. - testthat::expect_false(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Check that the expected error appears. - testthat::expect_equal(length(wide_model@messages$error), 1L) - testthat::expect_true(grepl( - x = wide_model@messages$error, - pattern = "lognet: one multinomial or binomial class has 1 or 0 observations; not allowed", - fixed = TRUE)) - } -}) - # Survival tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -332,34 +185,16 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - time_max = 1832, - learner = "lasso_cox") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - time_max = 1832, - learner = "lasso_cox") + time_max = 3.5, + learner = "lasso_cox" +) testthat::test_that("Regularised regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Calibration info is present - testthat::expect_equal(familiar:::has_calibration_info(good_model), TRUE) - - # Test that the model predicts hazard ratios. - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "hazard_ratio") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") + testthat::expect_true(familiar:::has_calibration_info(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -372,38 +207,40 @@ testthat::test_that("Regularised regression model trained correctly", { testthat::test_that("Regularised regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 2) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(any(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that rx has rank 1 and nodes has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "rx") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "nodes") + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Regularised regression model can train on wide data", { - # Model was trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - # Valid predictions are present. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) +familiar:::test_hyperparameter_optimisation( + learners = "ridge", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Valid survival probability predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "lasso", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) +familiar:::test_hyperparameter_optimisation( + learners = "elastic_net", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) testthat::skip("Skip hyperparameter optimisation, unless manual.") @@ -411,14 +248,17 @@ testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_glmnet_ridge_learners(show_general = TRUE), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_glmnet_lasso_learners(show_general = TRUE), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_glmnet_elastic_net_learners(show_general = TRUE), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) diff --git a/tests/testthat/test-learner_knn_S4.R b/tests/testthat/test-learner_knn_S4.R index b5dac7eb..7d253f43 100644 --- a/tests/testthat/test-learner_knn_S4.R +++ b/tests/testthat/test-learner_knn_S4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_knn_learners(show_general = TRUE)) + learners = familiar:::.get_available_knn_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete test. testthat::skip_on_cran() @@ -8,95 +9,34 @@ testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_knn_learners( - show_general = FALSE, show_default = TRUE), + show_general = FALSE, + show_default = TRUE + ), hyperparameter_list = list( - "count" = list("k" = 3), "continuous" = list("k" = 3), "binomial" = list("k" = 3), - "multinomial" = list("k" = 3)), - has_vimp = FALSE) + "multinomial" = list("k" = 3) + ), + has_vimp = FALSE +) familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_knn_learners( - show_general = FALSE, show_default = TRUE), + show_general = FALSE, + show_default = TRUE + ), hyperparameter_list = list( - "count" = list("k" = 3), "continuous" = list("k" = 3), "binomial" = list("k" = 3), - "multinomial" = list("k" = 3)), - has_vimp = FALSE) - -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "k" = 3), - learner = "k_nearest_neighbours_gower") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "k" = 3), - learner = "k_nearest_neighbours_gower") - -testthat::test_that("k-nearest neighbour model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("k-nearest neighbour model has no variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table is empty. - testthat::expect_equal(familiar:::is_empty(vimp_table), TRUE) -}) - - -testthat::test_that("k-nearest neighbour model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), TRUE) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) + "multinomial" = list("k" = 3) + ), + has_vimp = FALSE +) # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -105,22 +45,14 @@ good_model <- familiar:::test_train( imputation_method = "simple", hyperparameter_list = list( "sign_size" = familiar:::get_n_features(good_data), - "k" = 3), - learner = "k_nearest_neighbours_gower") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "k" = 3), - learner = "k_nearest_neighbours_gower") + "k" = 3 + ), + learner = "k_nearest_neighbours_gower" +) testthat::test_that("k-nearest neighbour model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -129,40 +61,19 @@ testthat::test_that("k-nearest neighbour model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("k-nearest neighbour model has no variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table is empty. - testthat::expect_equal(familiar:::is_empty(vimp_table), TRUE) + testthat::expect_true(familiar:::is_empty(vimp_table)) }) -testthat::test_that("k-nearest neighbour model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -171,23 +82,14 @@ good_model <- familiar:::test_train( imputation_method = "simple", hyperparameter_list = list( "sign_size" = familiar:::get_n_features(good_data), - "k" = 3), - learner = "k_nearest_neighbours_gower") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "k" = 3), - learner = "k_nearest_neighbours_gower") - + "k" = 3 + ), + learner = "k_nearest_neighbours_gower" +) testthat::test_that("k-nearest neighbour model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -196,40 +98,19 @@ testthat::test_that("k-nearest neighbour model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("k-nearest neighbour model does not have variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table has no rows. - testthat::expect_equal(familiar:::is_empty(vimp_table), TRUE) + testthat::expect_true(familiar:::is_empty(vimp_table)) }) -testthat::test_that("k-nearest neighbour model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- suppressWarnings(familiar:::test_train( @@ -238,22 +119,14 @@ good_model <- suppressWarnings(familiar:::test_train( imputation_method = "simple", hyperparameter_list = list( "sign_size" = familiar:::get_n_features(good_data), - "k" = 3), - learner = "k_nearest_neighbours_gower")) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "k" = 3), - learner = "k_nearest_neighbours_gower") + "k" = 3 + ), + learner = "k_nearest_neighbours_gower" +)) testthat::test_that("k-nearest neighbour model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -262,39 +135,30 @@ testthat::test_that("k-nearest neighbour model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("k-nearest neighbour model has no variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table is empty. - testthat::expect_equal(familiar:::is_empty(vimp_table), TRUE) + testthat::expect_true(familiar:::is_empty(vimp_table)) }) -testthat::test_that("k-nearest neighbour model can train on wide data", { - # Model cannot be trained. - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is empty. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions cannot be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) +familiar:::test_hyperparameter_optimisation( + learners = "knn", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_knn_learners( - show_general = TRUE, show_default = TRUE), + show_general = TRUE, + show_default = TRUE + ), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) diff --git a/tests/testthat/test-learner_mboost_lm_S4.R b/tests/testthat/test-learner_mboost_lm_S4.R deleted file mode 100644 index 3d16ff6f..00000000 --- a/tests/testthat/test-learner_mboost_lm_S4.R +++ /dev/null @@ -1,390 +0,0 @@ -# First test if all selectable learners are also available -familiar:::test_all_learners_available(learners = familiar:::.get_available_mboost_lm_learners(show_general = TRUE)) - -# Don't perform any further tests on CRAN due to time of running the complete test. -testthat::skip_on_cran() -testthat::skip_on_ci() - -familiar:::test_all_learners_train_predict_vimp( - learners = familiar:::.get_available_mboost_lm_learners(show_general = FALSE), - hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -5 - ), - "continuous" = list( - "n_boost" = 2, - "learning_rate" = -3 - ), - "binomial" = list( - "n_boost" = 2, - "learning_rate" = -3 - ), - "survival" = list( - "n_boost" = 2, - "learning_rate" = -3 - ) - ), - except_predict_survival = c( - "boosted_glm_loglog", - "boosted_glm_lognormal", - "boosted_glm_weibull" - ) -) - -familiar:::test_all_learners_parallel_train_predict_vimp( - learners = familiar:::.get_available_mboost_lm_learners(show_general = FALSE), - hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -5 - ), - "continuous" = list( - "n_boost" = 2, - "learning_rate" = -3 - ), - "binomial" = list( - "n_boost" = 2, - "learning_rate" = -3 - ), - "survival" = list( - "n_boost" = 2, - "learning_rate" = -3 - ) - ) -) - -##### Count outcome tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -5 - ), - learner = "boosted_glm_poisson" -) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -5 - ), - learner = "boosted_glm_poisson" -) - - -testthat::test_that("Gradient boosting regression model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting regression model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 13) - - # Expect that the names are the same as that of the features. - testthat::expect_equal(all(vimp_table$name %in% familiar:::get_feature_columns(good_data)), TRUE) - - # Expect that lower_status_percentage has rank 1 and avg_rooms has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "lower_status_percentage") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "avg_rooms") -}) - - -testthat::test_that("Gradient boosting regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), FALSE) - - # Valid predictions. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - -##### Continuous outcome tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1 - ), - learner = "boosted_glm_gaussian" -) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1 - ), - learner = "boosted_glm_gaussian" -) - - -testthat::test_that("Gradient boosting regression model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting regression model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 10) - - # Expect that the names are the same as that of the features. - testthat::expect_equal(all(vimp_table$name %in% familiar:::get_feature_columns(good_data)), TRUE) - - # Expect that avginc has rank 1 and calwpct has rank 2. - testthat::expect_true(all(vimp_table[rank <= 2, ]$name %in% c("avginc", "calwpct"))) -}) - - -testthat::test_that("Gradient boosting regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), FALSE) - - # Valid predictions. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - -##### Binomial tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1 - ), - learner = "boosted_glm_logistic" -) - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1 - ), - learner = "boosted_glm_logistic" -)) - -testthat::test_that("Gradient boosting regression model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting regression model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 8) - - # Expect that the names are the same as that of the features. - testthat::expect_equal(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name), TRUE) - - # Expect that cell_shape_uniformity has rank 1 and bare_nuclei has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "cell_shape_uniformity") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "bare_nuclei") -}) - - -testthat::test_that("Gradient boosting regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), FALSE) - - # Valid predictions. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - - -##### Survival tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1 - ), - time_max = 1832, - learner = "boosted_glm_cox" -) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1 - ), - time_max = 1832, - learner = "boosted_glm_cox" -) - - -testthat::test_that("Gradient boosting regression model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test the prediction type - testthat::expect_equal(familiar:::get_prediction_type(good_model), "hazard_ratio") - - # Test that the model predicts hazard ratios - testthat::expect_equal(familiar:::get_prediction_type(good_model, type = "survival_probability"), "survival_probability") - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting regression model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 3) - - # Expect that the names are the same as that of the features. - testthat::expect_equal(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name), TRUE) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "nodes") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "rx") -}) - - -testthat::test_that("Gradient boosting regression model can train and predict on wide data", { - # Model was trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), FALSE) - - # Valid predictions are present. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # Valid survival probability predictions can be made. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - -testthat::skip("Skip hyperparameter optimisation, unless manual.") - - -familiar:::test_hyperparameter_optimisation( - learners = familiar:::.get_available_mboost_lm_learners(show_general = TRUE), - debug = FALSE, - parallel = FALSE -) diff --git a/tests/testthat/test-learner_mboost_tree_S4.R b/tests/testthat/test-learner_mboost_tree_S4.R deleted file mode 100644 index 8e681166..00000000 --- a/tests/testthat/test-learner_mboost_tree_S4.R +++ /dev/null @@ -1,376 +0,0 @@ -# First test if all selectable learners are also available -familiar:::test_all_learners_available(learners = familiar:::.get_available_mboost_lm_learners(show_general = TRUE)) - -# Don't perform any further tests on CRAN due to time of running the complete test. -testthat::skip_on_cran() -testthat::skip_on_ci() - -familiar:::test_all_learners_train_predict_vimp( - learners = familiar:::.get_available_mboost_tree_learners(show_general = FALSE), - hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -5, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - "continuous" = list( - "n_boost" = 2, - "learning_rate" = -3, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - "binomial" = list( - "n_boost" = 2, - "learning_rate" = -3, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - "survival" = list( - "n_boost" = 2, - "learning_rate" = -3, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ) - ), - except_predict_survival = c( - "boosted_tree_loglog", - "boosted_tree_lognormal", - "boosted_tree_weibull" - ), - has_vimp = FALSE -) - -familiar:::test_all_learners_parallel_train_predict_vimp( - learners = familiar:::.get_available_mboost_tree_learners(show_general = FALSE), - hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -5, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - "continuous" = list( - "n_boost" = 2, - "learning_rate" = -3, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - "binomial" = list( - "n_boost" = 2, - "learning_rate" = -3, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - "survival" = list( - "n_boost" = 2, - "learning_rate" = -3, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ) - ), - has_vimp = FALSE -) - -##### Count outcome tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -5, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - learner = "boosted_tree_poisson" -) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -5, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - learner = "boosted_tree_poisson" -) - - -testthat::test_that("Gradient boosting tree model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), TRUE) - - # Valid predictions. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - -##### Continuous outcome tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - learner = "boosted_tree_gaussian" -) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - learner = "boosted_tree_gaussian" -) - - -testthat::test_that("Gradient boosting tree model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), TRUE) - - # Valid predictions. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - -##### Binomial tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - learner = "boosted_tree_logistic" -) - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - learner = "boosted_tree_logistic" -)) - -testthat::test_that("Gradient boosting tree model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), TRUE) - - # Valid predictions. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - - -##### Survival tests------------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - time_max = 1832, - learner = "boosted_tree_cox" -) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "tree_depth" = 3, - "min_child_weight" = 0.5, - "alpha" = 0.10 - ), - time_max = 1832, - learner = "boosted_tree_cox" -) - - -testthat::test_that("Gradient boosting tree model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test the prediction type - testthat::expect_equal(familiar:::get_prediction_type(good_model), "hazard_ratio") - - # Test that the model predicts hazard ratios - testthat::expect_equal(familiar:::get_prediction_type(good_model, type = "survival_probability"), "survival_probability") - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - - -testthat::test_that("Gradient boosting tree model can train and predict on wide data", { - # Model was trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_equal(familiar:::is_empty(familiar:::get_vimp_table(wide_model)), TRUE) - - # Valid predictions are present. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data), outcome_type = wide_data@outcome_type), TRUE) - - # Valid survival probability predictions can be made. - testthat::expect_equal(familiar:::any_predictions_valid(familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), outcome_type = wide_data@outcome_type), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - - -testthat::skip("Skip hyperparameter optimisation, unless manual.") - -familiar:::test_hyperparameter_optimisation( - learners = familiar:::.get_available_mboost_tree_learners(show_general = TRUE), - debug = FALSE, - parallel = FALSE -) diff --git a/tests/testthat/test-learner_naive_bayes_S4.R b/tests/testthat/test-learner_naive_bayes_S4.R index 5d00a2cf..2ea0110c 100644 --- a/tests/testthat/test-learner_naive_bayes_S4.R +++ b/tests/testthat/test-learner_naive_bayes_S4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_naive_bayes_learners(show_general = TRUE)) + learners = familiar:::.get_available_naive_bayes_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete test. testthat::skip_on_cran() @@ -10,21 +11,25 @@ familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_naive_bayes_learners(show_general = FALSE), hyperparameter_list = list( "binomial" = list("laplace" = 0.0), - "multinomial" = list("laplace" = 0.0)), - has_vimp = FALSE) + "multinomial" = list("laplace" = 0.0) + ), + has_vimp = FALSE +) familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_naive_bayes_learners(show_general = FALSE), hyperparameter_list = list( "binomial" = list("laplace" = 0.0), - "multinomial" = list("laplace" = 0.0)), - has_vimp = FALSE) + "multinomial" = list("laplace" = 0.0) + ), + has_vimp = FALSE +) + # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -33,22 +38,14 @@ good_model <- familiar:::test_train( imputation_method = "simple", hyperparameter_list = list( "sign_size" = familiar:::get_n_features(good_data), - "laplace" = 0.0), - learner = "naive_bayes") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "laplace" = 0.0), - learner = "naive_bayes") + "laplace" = 0.0 + ), + learner = "naive_bayes" +) testthat::test_that("Naive Bayes model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -62,33 +59,14 @@ testthat::test_that("Naive Bayes model has no variable importance", { vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table is empty. - testthat::expect_equal(familiar:::is_empty(vimp_table), TRUE) + testthat::expect_true(familiar:::is_empty(vimp_table)) }) -testthat::test_that("Naive Bayes model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- suppressWarnings(familiar:::test_train( @@ -97,22 +75,14 @@ good_model <- suppressWarnings(familiar:::test_train( imputation_method = "simple", hyperparameter_list = list( "sign_size" = familiar:::get_n_features(good_data), - "laplace" = 0.0), - learner = "naive_bayes")) - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "laplace" = 0.0), - learner = "naive_bayes") + "laplace" = 0.0 + ), + learner = "naive_bayes" +)) testthat::test_that("Naive Bayes model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -121,37 +91,27 @@ testthat::test_that("Naive Bayes model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("Naive Bayes model has no variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table is empty. - testthat::expect_equal(familiar:::is_empty(vimp_table), TRUE) + testthat::expect_true(familiar:::is_empty(vimp_table)) }) -testthat::test_that("Naive Bayes model can train on wide data", { - # Model cannot be trained. - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is empty. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - # Valid predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "naive_bayes", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_naive_bayes_learners(show_general = TRUE), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) diff --git a/tests/testthat/test-learner_ranger_s4.R b/tests/testthat/test-learner_ranger_s4.R index 6f7ef15f..1510f580 100644 --- a/tests/testthat/test-learner_ranger_s4.R +++ b/tests/testthat/test-learner_ranger_s4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_ranger_learners(show_general = TRUE)) + learners = familiar:::.get_available_ranger_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete # test. @@ -10,14 +11,6 @@ testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_ranger_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1 - ), "continuous" = list( "n_tree" = 4, "sample_size" = 1.00, @@ -56,14 +49,6 @@ familiar:::test_all_learners_train_predict_vimp( familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_ranger_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1 - ), "continuous" = list( "n_tree" = 4, "sample_size" = 1.00, @@ -100,92 +85,10 @@ familiar:::test_all_learners_parallel_train_predict_vimp( ) -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_tree" = 8, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 8, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") - -testthat::test_that("Ranger random forest model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - -testthat::test_that("Ranger random forest model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 13) - - # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect specific features to be highly ranked. - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "avg_rooms", "per_capita_crime", "lower_status_percentage", "industry"))) -}) - -testthat::test_that("Ranger random forest model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -199,27 +102,14 @@ good_model <- familiar:::test_train( "m_try" = 0.3, "node_size" = 5, "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 8, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") + "alpha" = 0.1 + ), + learner = "random_forest_ranger" +) testthat::test_that("Ranger random forest model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -231,41 +121,24 @@ testthat::test_that("Ranger random forest model trained correctly", { testthat::test_that("Ranger random forest model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 10) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that avginc has rank 1 and mealpct has rank 2. - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct"))) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Ranger random forest model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -279,27 +152,14 @@ good_model <- familiar:::test_train( "m_try" = 0.3, "node_size" = 5, "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 8, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") + "alpha" = 0.1 + ), + learner = "random_forest_ranger" +) testthat::test_that("Ranger random forest model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -308,47 +168,27 @@ testthat::test_that("Ranger random forest model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("Ranger random forest model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 8) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that cell_shape_uniformity has rank 1 and clump_thickness has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "cell_shape_uniformity") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "clump_thickness") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Ranger random forest model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -362,27 +202,14 @@ good_model <- familiar:::test_train( "m_try" = 0.3, "node_size" = 5, "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 8, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") + "alpha" = 0.1 + ), + learner = "random_forest_ranger" +) testthat::test_that("Ranger random forest model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -391,46 +218,27 @@ testthat::test_that("Ranger random forest model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("Ranger random forest model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 4) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that Petal length has rank 1 and petal width has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name %in% c("Petal_Length", "Petal_Width"), TRUE) - testthat::expect_equal(vimp_table[rank == 2, ]$name %in% c("Petal_Length", "Petal_Width"), TRUE) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Ranger random forest model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Survival tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -444,40 +252,17 @@ good_model <- familiar:::test_train( "m_try" = 0.3, "node_size" = 5, "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 8, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - learner = "random_forest_ranger") + "alpha" = 0.1 + ), + learner = "random_forest_ranger" +) testthat::test_that("Ranger random forest model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Calibration info is present - testthat::expect_equal(familiar:::has_calibration_info(good_model), TRUE) - - # Test that the model predicts cumulative hazard - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "cumulative_hazard") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") + testthat::expect_true(familiar:::has_calibration_info(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -489,44 +274,31 @@ testthat::test_that("Ranger random forest model trained correctly", { testthat::test_that("Ranger random forest model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has three rows. - testthat::expect_equal(nrow(vimp_table), 3) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("nodes", "rx"))) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Ranger random forest model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - # Variable importance table is present - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions are possible. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Valid survival probability predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "random_forest_ranger", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( learners = familiar:::.get_available_ranger_learners(show_general = TRUE), debug = FALSE, - parallel = FALSE) + parallel = FALSE +) diff --git a/tests/testthat/test-learner_rfsrc_s4.R b/tests/testthat/test-learner_rfsrc_s4.R index b2685959..6efcecb9 100644 --- a/tests/testthat/test-learner_rfsrc_s4.R +++ b/tests/testthat/test-learner_rfsrc_s4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_rfsrc_learners(show_general = TRUE)) + learners = familiar:::.get_available_rfsrc_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete # test. @@ -10,13 +11,6 @@ testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_rfsrc_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5 - ), "continuous" = list( "n_tree" = 4, "sample_size" = 0.50, @@ -51,13 +45,6 @@ familiar:::test_all_learners_train_predict_vimp( familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_rfsrc_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5 - ), "continuous" = list( "n_tree" = 4, "sample_size" = 0.50, @@ -89,90 +76,11 @@ familiar:::test_all_learners_parallel_train_predict_vimp( ) ) -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") - -testthat::test_that("Random forest SRC model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # That no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - -testthat::test_that("Random forest SRC model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model, data = good_data) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 13) - - # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that avg_rooms has rank 1 and per_capita_crime has rank 2. Disabled - # test because vimp by the random forest is unstable. -}) - -testthat::test_that("Random forest SRC model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty( - familiar:::get_vimp_table(wide_model, data = wide_data))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -185,26 +93,14 @@ good_model <- familiar:::test_train( "sample_size" = 0.50, "m_try" = 0.3, "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") + "tree_depth" = 5 + ), + learner = "random_forest_rfsrc" +) testthat::test_that("Random forest SRC model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -213,46 +109,27 @@ testthat::test_that("Random forest SRC model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("Random forest SRC model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model, data = good_data) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 10) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that avginc has rank 1 and mealpct has rank 2. - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct"))) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Random forest SRC model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false( - familiar:::is_empty(familiar:::get_vimp_table(wide_model, data = wide_data))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Binomial tests----------------------------------------------------------------s # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -265,26 +142,14 @@ good_model <- familiar:::test_train( "sample_size" = 0.50, "m_try" = 0.3, "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") + "tree_depth" = 5 + ), + learner = "random_forest_rfsrc" +) testthat::test_that("Random forest SRC model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -296,41 +161,24 @@ testthat::test_that("Random forest SRC model trained correctly", { testthat::test_that("Random forest SRC model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model, data = good_data) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 8) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Disabled test ranking test because vimp by the random forest is unstable. + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Random forest SRC model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false( - familiar:::is_empty(familiar:::get_vimp_table(wide_model, data = wide_data))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -343,26 +191,14 @@ good_model <- familiar:::test_train( "sample_size" = 0.50, "m_try" = 0.3, "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") + "tree_depth" = 5 + ), + learner = "random_forest_rfsrc" +) testthat::test_that("Random forest SRC model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -374,42 +210,24 @@ testthat::test_that("Random forest SRC model trained correctly", { testthat::test_that("Random forest SRC model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model, data = good_data) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 4) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that Petal length has rank 1 and petal width has rank 2. Disabled - # test because vimp by the random forest is unstable. + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Random forest SRC model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false( - familiar:::is_empty(familiar:::get_vimp_table(wide_model, data = wide_data))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Survival tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -422,39 +240,17 @@ good_model <- familiar:::test_train( "sample_size" = 0.50, "m_try" = 0.3, "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_tree" = 4, - "sample_size" = 0.50, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5), - learner = "random_forest_rfsrc") + "tree_depth" = 5 + ), + learner = "random_forest_rfsrc" +) testthat::test_that("Random forest SRC model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Calibration info is present - testthat::expect_equal(familiar:::has_calibration_info(good_model), TRUE) - - # Test that the model predicts cumulative hazard - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "cumulative_hazard") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") + testthat::expect_true(familiar:::has_calibration_info(good_model)) # That no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -466,44 +262,27 @@ testthat::test_that("Random forest SRC model trained correctly", { testthat::test_that("Random forest SRC model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model, data = good_data) - - # Expect that the vimp table has three rows. - testthat::expect_equal(nrow(vimp_table), 3) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that nodes and rx are the best features. The ordering is - # non-deterministic. - testthat::expect_equal(vimp_table[rank == 1, ]$name %in% c("nodes", "rx"), TRUE) - testthat::expect_equal(vimp_table[rank == 2, ]$name %in% c("rx", "adhere"), TRUE) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Random forest SRC model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present - testthat::expect_false( - familiar:::is_empty(familiar:::get_vimp_table(wide_model, data = wide_data))) - - # Valid predictions are possible. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Valid survival probability predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "random_forest_rfsrc", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") diff --git a/tests/testthat/test-learner_survival_regression_S4.R b/tests/testthat/test-learner_survival_regression_S4.R index 75a4cd20..e042e7b6 100644 --- a/tests/testthat/test-learner_survival_regression_S4.R +++ b/tests/testthat/test-learner_survival_regression_S4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_survival_regression_learners(show_general = TRUE)) + learners = familiar:::.get_available_survival_regression_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete # test. @@ -8,14 +9,17 @@ testthat::skip_on_cran() testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( - learners = familiar:::.get_available_survival_regression_learners(show_general = FALSE)) - + learners = familiar:::.get_available_survival_regression_learners(show_general = FALSE) +) familiar:::test_all_learners_parallel_train_predict_vimp( - learners = familiar:::.get_available_survival_regression_learners(show_general = FALSE)) + learners = familiar:::.get_available_survival_regression_learners(show_general = FALSE) +) + + +# Survival tests --------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -23,31 +27,14 @@ good_model <- familiar:::test_train( cluster_method = "none", imputation_method = "simple", hyperparameter_list = list("sign_size" = familiar:::get_n_features(good_data)), - learner = "survival_regr_weibull") - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(wide_data)), - learner = "survival_regr_weibull")) + learner = "survival_regr_weibull" +) testthat::test_that("Survival regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test the prediction type - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "expected_survival_time") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") - - # Checkt that no deprecation warnings are given. + testthat::expect_true(familiar:::model_is_trained(good_model)) + + # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) # Test that no errors appear. @@ -57,43 +44,27 @@ testthat::test_that("Survival regression model trained correctly", { testthat::test_that("Survival regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has three rows. - testthat::expect_equal(nrow(vimp_table), 3) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "nodes") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "rx") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Survival regression model can train for wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # With variable importance table. - testthat::expect_false( - familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # No valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # No valid survival probability predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "survival_regr", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") diff --git a/tests/testthat/test-learner_svm_S4.R b/tests/testthat/test-learner_svm_S4.R index 5ee8dab8..89934ee8 100644 --- a/tests/testthat/test-learner_svm_S4.R +++ b/tests/testthat/test-learner_svm_S4.R @@ -1,10 +1,13 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_svm_c_learners(show_general = TRUE)) + learners = familiar:::.get_available_svm_c_learners(show_general = TRUE) +) familiar:::test_all_learners_available( - learners = familiar:::.get_available_svm_nu_learners(show_general = TRUE)) + learners = familiar:::.get_available_svm_nu_learners(show_general = TRUE) +) familiar:::test_all_learners_available( - learners = familiar:::.get_available_svm_eps_learners(show_general = TRUE)) + learners = familiar:::.get_available_svm_eps_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete # test. @@ -25,7 +28,8 @@ familiar:::test_all_learners_train_predict_vimp( "gamma" = 0.1, "degree" = 2.0, "offset" = 0.0 - )), + ) + ), has_vimp = FALSE ) @@ -33,14 +37,6 @@ familiar:::test_all_learners_train_predict_vimp( familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_svm_nu_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "c" = -1.0, - "epsilon" = 0.0, - "nu" = -4.0, - "gamma" = 0.1, - "degree" = 2.0, - "offset" = 0.0 - ), "continuous" = list( "c" = -1.0, "epsilon" = 0.0, @@ -64,7 +60,8 @@ familiar:::test_all_learners_train_predict_vimp( "gamma" = 0.1, "degree" = 2.0, "offset" = 0.0 - )), + ) + ), has_vimp = FALSE ) @@ -72,20 +69,14 @@ familiar:::test_all_learners_train_predict_vimp( familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_svm_eps_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "c" = -1.0, - "epsilon" = 0.0, - "gamma" = 0.1, - "degree" = 2.0, - "offset" = 0.0 - ), "continuous" = list( "c" = -1.0, "epsilon" = 0.0, "gamma" = 0.1, "degree" = 2.0, "offset" = 0.0 - )), + ) + ), has_vimp = FALSE ) @@ -104,7 +95,8 @@ familiar:::test_all_learners_parallel_train_predict_vimp( "gamma" = 0.1, "degree" = 2.0, "offset" = 0.0 - )), + ) + ), has_vimp = FALSE ) @@ -112,14 +104,6 @@ familiar:::test_all_learners_parallel_train_predict_vimp( familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_svm_nu_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "c" = -1.0, - "epsilon" = 0.0, - "nu" = -4.0, - "gamma" = 0.1, - "degree" = 2.0, - "offset" = 0.0 - ), "continuous" = list( "c" = -1.0, "epsilon" = 0.0, @@ -143,7 +127,8 @@ familiar:::test_all_learners_parallel_train_predict_vimp( "gamma" = 0.1, "degree" = 2.0, "offset" = 0.0 - )), + ) + ), has_vimp = FALSE ) @@ -151,97 +136,22 @@ familiar:::test_all_learners_parallel_train_predict_vimp( familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_svm_eps_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "c" = -1.0, - "epsilon" = 0.0, - "gamma" = 0.1, - "degree" = 2.0, - "offset" = 0.0 - ), "continuous" = list( "c" = -1.0, "epsilon" = 0.0, "gamma" = 0.1, "degree" = 2.0, "offset" = 0.0 - )), + ) + ), has_vimp = FALSE ) -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "c" = -1.0, - "epsilon" = 0.0, - "gamma" = 0.0), - learner = "svm_eps_radial") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "c" = -1.0, - "epsilon" = 0.0, - "gamma" = 0.0), - learner = "svm_eps_radial") - -testthat::test_that("SVM model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - -testthat::test_that("SVM model has no variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) -}) - -testthat::test_that("SVM model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -252,24 +162,14 @@ good_model <- familiar:::test_train( "sign_size" = familiar:::get_n_features(good_data), "c" = -1.0, "epsilon" = 0.0, - "gamma" = 1.0), - learner = "svm_eps_radial") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "c" = -1.0, - "epsilon" = 0.0, - "gamma" = 1.0), - learner = "svm_eps_radial") + "gamma" = 1.0 + ), + learner = "svm_eps_radial" +) testthat::test_that("SVM model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -283,33 +183,14 @@ testthat::test_that("SVM model has no variable importance", { vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) }) -testthat::test_that("SVM model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -319,23 +200,14 @@ good_model <- familiar:::test_train( hyperparameter_list = list( "sign_size" = familiar:::get_n_features(good_data), "c" = -1.0, - "gamma" = 1.0), - learner = "svm_c_radial") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "c" = -1.0, - "gamma" = 1.0), - learner = "svm_c_radial") + "gamma" = 1.0 + ), + learner = "svm_c_radial" +) testthat::test_that("SVM model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -349,33 +221,14 @@ testthat::test_that("SVM model has no variable importance", { vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) }) -testthat::test_that("SVM model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -385,23 +238,14 @@ good_model <- familiar:::test_train( hyperparameter_list = list( "sign_size" = familiar:::get_n_features(good_data), "c" = -1.0, - "gamma" = 1.0), - learner = "svm_c_radial") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "c" = -1.0, - "gamma" = 1.0), - learner = "svm_c_radial") + "gamma" = 1.0 + ), + learner = "svm_c_radial" +) testthat::test_that("SVM model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -415,27 +259,31 @@ testthat::test_that("SVM model has no variable importance", { vimp_table <- familiar:::get_vimp_table(good_model) # Expect that the vimp table is empty. - testthat::expect_equal(is_empty(vimp_table), TRUE) + testthat::expect_true(is_empty(vimp_table)) }) -testthat::test_that("SVM model can train on wide data", { - # Model cannot be trained. - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - # Variable importance table is empty. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) +familiar:::test_hyperparameter_optimisation( + learners = "svm_c_radial", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Valid predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) +familiar:::test_hyperparameter_optimisation( + learners = "svm_nu_radial", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "svm_eps_radial", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") diff --git a/tests/testthat/test-learner_xgboost_dart_S4.R b/tests/testthat/test-learner_xgboost_dart_S4.R index 2a702cc5..6c3ff46b 100644 --- a/tests/testthat/test-learner_xgboost_dart_S4.R +++ b/tests/testthat/test-learner_xgboost_dart_S4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_xgboost_dart_learners(show_general = TRUE)) + learners = familiar:::.get_available_xgboost_dart_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete # test. @@ -10,18 +11,6 @@ testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_xgboost_dart_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0 - ), "continuous" = list( "n_boost" = 2, "learning_rate" = -1, @@ -76,18 +65,6 @@ familiar:::test_all_learners_train_predict_vimp( familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_xgboost_dart_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0 - ), "continuous" = list( "n_boost" = 2, "learning_rate" = -1, @@ -139,103 +116,11 @@ familiar:::test_all_learners_parallel_train_predict_vimp( ) ) -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_gaussian") - -testthat::test_that("Extreme gradient boosting dart tree model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - -testthat::test_that("Extreme gradient boosting dart tree model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has less than 10 rows. - testthat::expect_equal(nrow(vimp_table) <= get_n_features(good_data), TRUE) - - # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that avg_rooms has rank 1 and lower_status_percentage has rank 2. - testthat::expect_true(vimp_table[rank == 1, ]$name %in% c( - "avg_rooms", "lower_status_percentage", "per_capita_crime", "residence_before_1940_proportion")) - testthat::expect_true(vimp_table[rank == 2, ]$name %in% c( - "avg_rooms", "lower_status_percentage", "per_capita_crime", "residence_before_1940_proportion")) -}) - - -testthat::test_that("Extreme gradient boosting dart tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -253,31 +138,14 @@ good_model <- familiar:::test_train( "sample_size" = 1.0, "gamma" = -6.0, "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_gaussian") + "rate_drop" = 0.0 + ), + learner = "xgboost_dart_gaussian" +) testthat::test_that("Extreme gradient boosting dart tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -289,43 +157,24 @@ testthat::test_that("Extreme gradient boosting dart tree model trained correctly testthat::test_that("Extreme gradient boosting dart tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 10) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that avginc has rank 1 and calwpct has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "avginc") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "calwpct") + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting dart tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -343,31 +192,14 @@ good_model <- familiar:::test_train( "sample_size" = 1.0, "gamma" = -6.0, "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_logistic") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_logistic") + "rate_drop" = 0.0 + ), + learner = "xgboost_dart_logistic" +) testthat::test_that("Extreme gradient boosting dart tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -379,44 +211,24 @@ testthat::test_that("Extreme gradient boosting dart tree model trained correctly testthat::test_that("Extreme gradient boosting dart tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 6) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that cell_shape_uniformity has rank 1 and epithelial_cell_size has - # rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "cell_shape_uniformity") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "epithelial_cell_size") + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting dart tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -434,31 +246,14 @@ good_model <- familiar:::test_train( "sample_size" = 1.0, "gamma" = -6.0, "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_logistic") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0), - learner = "xgboost_dart_logistic") + "rate_drop" = 0.0 + ), + learner = "xgboost_dart_logistic" +) testthat::test_that("Extreme gradient boosting dart tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -471,42 +266,24 @@ testthat::test_that("Extreme gradient boosting dart tree model trained correctly testthat::test_that("Extreme gradient boosting dart tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 4) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that Petal_Length has rank 1 and Petal_Width has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "Petal_Length") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "Petal_Width") + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting dart tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Survival tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -524,43 +301,15 @@ good_model <- familiar:::test_train( "sample_size" = 1.0, "gamma" = -6.0, "sample_type" = "uniform", - "rate_drop" = 0.0), - time_max = 1832, - learner = "xgboost_dart_cox") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0, - "sample_type" = "uniform", - "rate_drop" = 0.0), - time_max = 1832, - learner = "xgboost_dart_cox") + "rate_drop" = 0.0 + ), + time_max = 3.5, + learner = "xgboost_dart_cox" +) testthat::test_that("Extreme gradient boosting dart tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test the prediction type - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "hazard_ratio") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -572,41 +321,27 @@ testthat::test_that("Extreme gradient boosting dart tree model trained correctly testthat::test_that("Extreme gradient boosting dart tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has three or two rows. - testthat::expect_equal(nrow(vimp_table) %in% c(2, 3), TRUE) - + + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(any(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "nodes") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "rx") + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting dart tree model can train and predict on wide data", { - # Model was trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions are present. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Valid survival probability predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "xgboost_dart", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") diff --git a/tests/testthat/test-learner_xgboost_lm_S4.R b/tests/testthat/test-learner_xgboost_lm_S4.R index 1cfe22bf..e1781db2 100644 --- a/tests/testthat/test-learner_xgboost_lm_S4.R +++ b/tests/testthat/test-learner_xgboost_lm_S4.R @@ -1,6 +1,7 @@ # First test if all selectable learners are also available familiar:::test_all_learners_available( - learners = familiar:::.get_available_xgboost_lm_learners(show_general = TRUE)) + learners = familiar:::.get_available_xgboost_lm_learners(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete # test. @@ -10,12 +11,6 @@ testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_xgboost_lm_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -5, - "lambda" = 0.0, - "alpha" = -6.0 - ), "continuous" = list( "n_boost" = 2, "learning_rate" = -1, @@ -46,12 +41,6 @@ familiar:::test_all_learners_train_predict_vimp( familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_xgboost_lm_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -5, - "lambda" = 0.0, - "alpha" = -6.0 - ), "continuous" = list( "n_boost" = 2, "learning_rate" = -1, @@ -79,87 +68,10 @@ familiar:::test_all_learners_parallel_train_predict_vimp( ) ) -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_gaussian") - -testthat::test_that("Extreme gradient boosting regression model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - -testthat::test_that("Extreme gradient boosting regression model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 13) - - # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that ranks 1 and 2 to be occupied by avg_rooms and lower_status_percentage. - testthat::expect_setequal(vimp_table[rank %in% c(1, 2), ]$name, c("avg_rooms", "lower_status_percentage")) -}) - -testthat::test_that("Extreme gradient boosting regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -171,25 +83,14 @@ good_model <- familiar:::test_train( "n_boost" = 2, "learning_rate" = -1, "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_gaussian") + "alpha" = -6.0 + ), + learner = "xgboost_lm_gaussian" +) testthat::test_that("Extreme gradient boosting regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -201,42 +102,24 @@ testthat::test_that("Extreme gradient boosting regression model trained correctl testthat::test_that("Extreme gradient boosting regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 10) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that avginc and calwpct have rank 1 and 2. - testthat::expect_true(vimp_table[rank == 1, ]$name %in% c("calwpct", "avginc", "grspan")) - testthat::expect_true(vimp_table[rank == 2, ]$name %in% c("calwpct", "avginc", "grspan")) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -248,25 +131,14 @@ good_model <- familiar:::test_train( "n_boost" = 2, "learning_rate" = -1, "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_logistic") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_logistic") + "alpha" = -6.0 + ), + learner = "xgboost_lm_logistic" +) testthat::test_that("Extreme gradient boosting regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -278,43 +150,24 @@ testthat::test_that("Extreme gradient boosting regression model trained correctl testthat::test_that("Extreme gradient boosting regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 8) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - testthat::expect_true(vimp_table[rank == 1, ]$name %in% c( - "normal_nucleoli", "cell_shape_uniformity", "epithelial_cell_size", "bare_nuclei")) - testthat::expect_true(vimp_table[rank == 2, ]$name %in% c( - "normal_nucleoli", "cell_shape_uniformity", "epithelial_cell_size", "bare_nuclei")) + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -326,25 +179,14 @@ good_model <- familiar:::test_train( "n_boost" = 2, "learning_rate" = -1, "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_logistic") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0), - learner = "xgboost_lm_logistic") + "alpha" = -6.0 + ), + learner = "xgboost_lm_logistic" +) testthat::test_that("Extreme gradient boosting regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -356,42 +198,24 @@ testthat::test_that("Extreme gradient boosting regression model trained correctl testthat::test_that("Extreme gradient boosting regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 4) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that Petal_Length has rank 1 and Petal_Width has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "Petal_Length") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "Petal_Width") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting regression model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Survival tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -403,37 +227,15 @@ good_model <- familiar:::test_train( "n_boost" = 2, "learning_rate" = -1, "lambda" = 0.0, - "alpha" = -6.0), - time_max = 1832, - learner = "xgboost_lm_cox") - -# Train the model using wide data. -wide_model <- suppressWarnings(familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0), - time_max = 1832, - learner = "xgboost_lm_cox")) + "alpha" = -6.0 + ), + time_max = 3.5, + learner = "xgboost_lm_cox" +) testthat::test_that("Extreme gradient boosting regression model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test the prediction type - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "hazard_ratio") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -445,42 +247,27 @@ testthat::test_that("Extreme gradient boosting regression model trained correctl testthat::test_that("Extreme gradient boosting regression model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has three rows. - testthat::expect_equal(nrow(vimp_table), 3) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "nodes") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "rx") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting regression model can train and predict on wide data", { - # Model was trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is present. - testthat::expect_false(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions are present. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Valid survival probability predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "xgboost_lm", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") diff --git a/tests/testthat/test-learner_xgboost_tree_S4.R b/tests/testthat/test-learner_xgboost_tree_S4.R index 2f1a9a25..b4a201b7 100644 --- a/tests/testthat/test-learner_xgboost_tree_S4.R +++ b/tests/testthat/test-learner_xgboost_tree_S4.R @@ -10,16 +10,6 @@ testthat::skip_on_ci() familiar:::test_all_learners_train_predict_vimp( learners = familiar:::.get_available_xgboost_tree_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0 - ), "continuous" = list( "n_boost" = 2, "learning_rate" = -1, @@ -66,16 +56,6 @@ familiar:::test_all_learners_train_predict_vimp( familiar:::test_all_learners_parallel_train_predict_vimp( learners = familiar:::.get_available_xgboost_tree_learners(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0 - ), "continuous" = list( "n_boost" = 2, "learning_rate" = -1, @@ -119,98 +99,11 @@ familiar:::test_all_learners_parallel_train_predict_vimp( ) ) -# Count outcome tests----------------------------------------------------------- - -# Create test data sets. -good_data <- familiar:::test_create_good_data("count") -wide_data <- familiar:::test_create_wide_data("count") - -# Train the model using the good dataset. -good_model <- familiar:::test_train( - data = good_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(good_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_gaussian") - -testthat::test_that("Extreme gradient boosting tree model trained correctly", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Check that no deprecation warnings are given. - familiar:::test_not_deprecated(good_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(good_model@messages$error, NULL) -}) - -testthat::test_that("Extreme gradient boosting tree model has variable importance", { - # Extract the variable importance table. - vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has less than 10 rows. - testthat::expect_equal(nrow(vimp_table) <= get_n_features(good_data), TRUE) - - # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that avg_rooms has rank 1 and lower_status_percentage has rank 2. - testthat::expect_true(vimp_table[rank == 1, ]$name %in% c( - "avg_rooms", "lower_status_percentage", "per_capita_crime", "residence_before_1940_proportion")) - testthat::expect_true(vimp_table[rank == 2, ]$name %in% c( - "avg_rooms", "lower_status_percentage", "per_capita_crime", "residence_before_1940_proportion")) -}) - -testthat::test_that("Extreme gradient boosting tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Continuous outcome tests------------------------------------------------------ # Create test data sets. good_data <- familiar:::test_create_good_data("continuous") -wide_data <- familiar:::test_create_wide_data("continuous") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -226,29 +119,14 @@ good_model <- familiar:::test_train( "min_child_weight" = 1.04, "tree_depth" = 3, "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_gaussian") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_gaussian") + "gamma" = -6.0 + ), + learner = "xgboost_tree_gaussian" +) testthat::test_that("Extreme gradient boosting tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -260,42 +138,24 @@ testthat::test_that("Extreme gradient boosting tree model trained correctly", { testthat::test_that("Extreme gradient boosting tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 10) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that avginc has rank 1 and calwpct has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "avginc") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "calwpct") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Binomial tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("binomial") -wide_data <- familiar:::test_create_wide_data("binomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -311,29 +171,14 @@ good_model <- familiar:::test_train( "min_child_weight" = 1.04, "tree_depth" = 3, "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_logistic") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_logistic") + "gamma" = -6.0 + ), + learner = "xgboost_tree_logistic" +) testthat::test_that("Extreme gradient boosting tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -342,47 +187,27 @@ testthat::test_that("Extreme gradient boosting tree model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("Extreme gradient boosting tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 6) - + + # Expect that the vimp table has up to six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(vimp_table$name %in% familiar:::get_feature_columns(good_data))) - - # Expect that cell_shape_uniformity has rank 1 and epithelial_cell_size has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "cell_shape_uniformity") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "epithelial_cell_size") + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(good_data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) - # Multinomial tests------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("multinomial") -wide_data <- familiar:::test_create_wide_data("multinomial") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -398,29 +223,14 @@ good_model <- familiar:::test_train( "min_child_weight" = 1.04, "tree_depth" = 3, "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_logistic") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0), - learner = "xgboost_tree_logistic") + "gamma" = -6.0 + ), + learner = "xgboost_tree_logistic" +) testthat::test_that("Extreme gradient boosting tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -429,46 +239,27 @@ testthat::test_that("Extreme gradient boosting tree model trained correctly", { testthat::expect_equal(good_model@messages$error, NULL) }) - testthat::test_that("Extreme gradient boosting tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has two rows. - testthat::expect_equal(nrow(vimp_table), 4) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. - testthat::expect_true(all(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that cell_shape_uniformity has rank 1 and bare_nuclei has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "Petal_Length") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "Petal_Width") + testthat::expect_true( + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting tree model can train on wide data", { - # Model trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent. - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) - - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) # Survival tests---------------------------------------------------------------- # Create test data sets. good_data <- familiar:::test_create_good_data("survival") -wide_data <- familiar:::test_create_wide_data("survival") # Train the model using the good dataset. good_model <- familiar:::test_train( @@ -484,41 +275,15 @@ good_model <- familiar:::test_train( "min_child_weight" = 1.04, "tree_depth" = 3, "sample_size" = 1.0, - "gamma" = -6.0), - time_max = 1832, - learner = "xgboost_tree_cox") - -# Train the model using wide data. -wide_model <- familiar:::test_train( - data = wide_data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list( - "sign_size" = familiar:::get_n_features(wide_data), - "n_boost" = 2, - "learning_rate" = -1, - "lambda" = 0.0, - "alpha" = -6.0, - "min_child_weight" = 1.04, - "tree_depth" = 3, - "sample_size" = 1.0, - "gamma" = -6.0), - time_max = 1832, - learner = "xgboost_tree_cox") + "gamma" = -6.0 + ), + time_max = 3.5, + learner = "xgboost_tree_cox" +) testthat::test_that("Extreme gradient boosting tree model trained correctly", { # Model trained - testthat::expect_equal(familiar:::model_is_trained(good_model), TRUE) - - # Test the prediction type - testthat::expect_equal( - familiar:::get_prediction_type(good_model), - "hazard_ratio") - - # Test that the model predicts hazard ratios - testthat::expect_equal( - familiar:::get_prediction_type(good_model, type = "survival_probability"), - "survival_probability") + testthat::expect_true(familiar:::model_is_trained(good_model)) # Check that no deprecation warnings are given. familiar:::test_not_deprecated(good_model@messages$warning) @@ -530,42 +295,27 @@ testthat::test_that("Extreme gradient boosting tree model trained correctly", { testthat::test_that("Extreme gradient boosting tree model has variable importance", { # Extract the variable importance table. vimp_table <- familiar:::get_vimp_table(good_model) - - # Expect that the vimp table has three rows. - testthat::expect_equal(nrow(vimp_table) %in% c(2, 3), TRUE) - + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + # Expect that the names are the same as that of the features. testthat::expect_true( - any(familiar:::get_feature_columns(good_data) %in% vimp_table$name)) - - # Expect that nodes has rank 1 and rx has rank 2. - testthat::expect_equal(vimp_table[rank == 1, ]$name, "nodes") - testthat::expect_equal(vimp_table[rank == 2, ]$name, "rx") + all(familiar:::get_feature_columns(good_data) %in% vimp_table$name) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) -testthat::test_that("Extreme gradient boosting tree model can train and predict on wide data", { - # Model was trained - testthat::expect_equal(familiar:::model_is_trained(wide_model), TRUE) - - # Variable importance table is absent - testthat::expect_true(familiar:::is_empty(familiar:::get_vimp_table(wide_model))) - - # Valid predictions are present. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data), - outcome_type = wide_data@outcome_type)) - - # Valid survival probability predictions can be made. - testthat::expect_true(familiar:::any_predictions_valid( - familiar:::.predict(wide_model, wide_data, type = "survival_probability", time = 1000), - outcome_type = wide_data@outcome_type)) - # Test that no deprecation warnings are given. - familiar:::test_not_deprecated(wide_model@messages$warning) +familiar:::test_hyperparameter_optimisation( + learners = "xgboost_tree", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) - # Test that no errors appear. - testthat::expect_equal(wide_model@messages$error, NULL) -}) testthat::skip("Skip hyperparameter optimisation, unless manual.") diff --git a/tests/testthat/test-leave_one_out_cv.R b/tests/testthat/test-leave_one_out_cv.R new file mode 100644 index 00000000..d4ac0163 --- /dev/null +++ b/tests/testthat/test-leave_one_out_cv.R @@ -0,0 +1,50 @@ +# Don't perform tests on CRAN due to time of running the complete test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +# debug flag +debug <- FALSE + +# Create datasets +full_data <- familiar:::test_create_good_data("binomial") +full_data@data <- full_data@data[1L:20L] + +# Set learner +learner <- "lasso" + +# Parse hyperparameter list +hyperparameters <- list( + "lasso" = list( + "sign_size" = familiar:::get_n_features(full_data), + "family" = "binomial" + ) +) + +output <- familiar:::summon_familiar( + data = full_data, + experimental_design = "lv(fs+mb)", + vimp_method = "none", + cluster_method = "none", + imputation_method = "simple", + learner = learner, + hyperparameter = hyperparameters, + skip_evaluation_elements = c( + "auc_data", "calibration_data", "calibration_info", + "decision_curve_analyis", "feature_expressions", "feature_similarity", + "fs_vimp", "hyperparameters", "ice_data", "shap", + "model_vimp", "permutation_vimp", "sample_similarity", + "risk_stratification_data", "risk_stratification_info", "univariate_analysis" + ), + parallel = FALSE, + verbose = debug +) + +testthat::test_that("LOOCV is performed correctly.", { + + # Expect that model performance is computed for all data. + testthat::expect_length(output$familiarCollection@model_performance, 4L) + testthat::expect_length(output$familiarData, 2L) + testthat::expect_length(output$familiarData[[1L]]@model_performance, 2L) + testthat::expect_length(output$familiarData[[2L]]@model_performance, 2L) + +}) diff --git a/tests/testthat/test-metric_auc_roc_S4.R b/tests/testthat/test-metric_auc_roc_S4.R index e1c6c9e1..56caa8b9 100644 --- a/tests/testthat/test-metric_auc_roc_S4.R +++ b/tests/testthat/test-metric_auc_roc_S4.R @@ -3,112 +3,135 @@ familiar:::test_all_metrics_available(metrics = familiar:::.get_available_auc_ro # Skip remainder on CRAN due to runtimes. testthat::skip_on_cran() +# power.transform and other packages are required. +if (!rlang::is_installed("power.transform")) testthat::skip() + familiar:::test_all_metrics( metrics = familiar:::.get_available_auc_roc_metrics(), not_available_single_sample = TRUE, not_available_all_samples_identical = TRUE ) -data_good_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0), - "predicted_class_probability_b" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1) + +data_good_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0), + "b" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_bad_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "b", "a", "b", "a", "b", "a", "b", "a", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5), - "predicted_class_probability_b" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5) +data_bad_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5), + "b" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_ok_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "a", "a", "b", "b", "a", "a", "b", "b", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(1.0, 0.9, 0.8, 0.4, 0.3, 0.7, 0.6, 0.2, 0.1, 0.0), - "predicted_class_probability_b" = c(0.0, 0.1, 0.2, 0.6, 0.7, 0.3, 0.4, 0.8, 0.9, 1.0) +data_ok_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1.0, 0.9, 0.8, 0.4, 0.3, 0.7, 0.6, 0.2, 0.1, 0.0), + "b" = c(0.0, 0.1, 0.2, 0.6, 0.7, 0.3, 0.4, 0.8, 0.9, 1.0) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_inv_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("b", "b", "b", "b", "b", "a", "a", "a", "b", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1), - "predicted_class_probability_b" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0) +data_inv_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1), + "b" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_good_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), - "predicted_class_probability_b" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0), - "predicted_class_probability_c" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1) +data_good_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), + "b" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0), + "c" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_bad_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "b", "c", "a", "b", "c", "a", "b", "c", "a"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), - "predicted_class_probability_b" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), - "predicted_class_probability_c" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3) +data_bad_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), + "b" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), + "c" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_ok_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "b", "a", "b", "a", "b", "c", "b", "c", "c"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(1.0, 0.2, 0.4, 0.0, 0.4, 0.1, 0.0, 0.0, 0.0, 0.1), - "predicted_class_probability_b" = c(0.0, 0.5, 0.3, 1.0, 0.3, 0.5, 0.0, 0.6, 0.4, 0.3), - "predicted_class_probability_c" = c(0.0, 0.3, 0.3, 0.0, 0.3, 0.4, 1.0, 0.4, 0.6, 0.7) +data_ok_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1.0, 0.2, 0.4, 0.0, 0.4, 0.1, 0.0, 0.0, 0.0, 0.1), + "b" = c(0.0, 0.5, 0.3, 1.0, 0.3, 0.5, 0.0, 0.6, 0.4, 0.3), + "c" = c(0.0, 0.3, 0.3, 0.0, 0.3, 0.4, 1.0, 0.4, 0.6, 0.7) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_inv_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("b", "b", "b", "c", "c", "c", "a", "a", "a", "a"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1), - "predicted_class_probability_b" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), - "predicted_class_probability_c" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0) +data_inv_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1), + "b" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), + "c" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) # Package data in a list for easier iterative tests data_list <- list( - "good_binomial" = list("data" = data_good_binomial, "outcome_type" = "binomial"), - "bad_binomial" = list("data" = data_bad_binomial, "outcome_type" = "binomial"), - "ok_binomial" = list("data" = data_ok_binomial, "outcome_type" = "binomial"), - "inv_binomial" = list("data" = data_inv_binomial, "outcome_type" = "binomial"), - "good_multinomial" = list("data" = data_good_multinomial, "outcome_type" = "multinomial"), - "bad_multinomial" = list("data" = data_bad_multinomial, "outcome_type" = "multinomial"), - "ok_multinomial" = list("data" = data_ok_multinomial, "outcome_type" = "multinomial"), - "inv_multinomial" = list("data" = data_inv_multinomial, "outcome_type" = "multinomial") + "good_binomial" = data_good_binomial, + "bad_binomial" = data_bad_binomial, + "ok_binomial" = data_ok_binomial, + "inv_binomial" = data_inv_binomial, + "good_multinomial" = data_good_multinomial, + "bad_multinomial" = data_bad_multinomial, + "ok_multinomial" = data_ok_multinomial, + "inv_multinomial" = data_inv_multinomial ) # Area under the curve --------------------------------------------------------- testthat::test_that("AUC-ROC is correct", { expected_score <- c(1.0, 0.5, 21 / 25, 0.0, 1.0, 0.5, 61 / 72, 1 / 3) expected_objective <- c(1.0, 0.0, 17 / 25, -1.0, 1.0, 0.0, 25 / 36, -1 / 3) - + # Iterate over the data sets. for (ii in seq_along(data_list)) { # Create metric object. metric_object <- familiar:::as_metric( metric = "auc_roc", - outcome_type = data_list[[ii]]$outcome_type) - + outcome_type = data_list[[ii]]@outcome_type + ) + # Set baseline-value explicitly. metric_object@baseline_value <- 0.5 - + # Check that the metric is available - testthat::expect_equal(familiar:::is_available(metric_object), TRUE) - + testthat::expect_true(familiar:::is_available(metric_object)) + # Compute the metric value. score <- familiar:::compute_metric_score( metric = metric_object, - data = data_list[[ii]]$data) - + data = data_list[[ii]] + ) + # Compute the objective score. objective_score <- familiar:::compute_objective_score( metric = metric_object, - data = data_list[[ii]]$data) - + data = data_list[[ii]] + ) + # Test the values. testthat::expect_equal(score, expected_score[ii]) testthat::expect_equal(objective_score, expected_objective[ii]) diff --git a/tests/testthat/test-metric_brier_S4.R b/tests/testthat/test-metric_brier_S4.R index 0d4edcfc..f78b5e92 100644 --- a/tests/testthat/test-metric_brier_S4.R +++ b/tests/testthat/test-metric_brier_S4.R @@ -3,80 +3,100 @@ familiar:::test_all_metrics_available(metrics = familiar:::.get_available_brier_ # Skip remainder on CRAN due to runtimes. testthat::skip_on_cran() +# power.transform and other packages are required. +if (!rlang::is_installed("power.transform")) testthat::skip() + familiar:::test_all_metrics(metrics = familiar:::.get_available_brier_metrics()) -data_good_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0), - "predicted_class_probability_b" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1) +data_good_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0), + "b" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_bad_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "b", "a", "b", "a", "b", "a", "b", "a", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5), - "predicted_class_probability_b" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5) +data_bad_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5), + "b" = c(.5, .5, .5, .5, .5, .5, .5, .5, .5, .5) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_ok_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "a", "a", "b", "b", "a", "a", "b", "b", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(1.0, 0.9, 0.8, 0.4, 0.3, 0.7, 0.6, 0.2, 0.1, 0.0), - "predicted_class_probability_b" = c(0.0, 0.1, 0.2, 0.6, 0.7, 0.3, 0.4, 0.8, 0.9, 1.0) +data_ok_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1.0, 0.9, 0.8, 0.4, 0.3, 0.7, 0.6, 0.2, 0.1, 0.0), + "b" = c(0.0, 0.1, 0.2, 0.6, 0.7, 0.3, 0.4, 0.8, 0.9, 1.0) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_inv_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("b", "b", "b", "b", "b", "a", "a", "a", "b", "b"), levels = c("a", "b")), - "predicted_class_probability_a" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1), - "predicted_class_probability_b" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0) +data_inv_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1), + "b" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_good_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), - "predicted_class_probability_b" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0), - "predicted_class_probability_c" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1) +data_good_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), + "b" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0), + "c" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_bad_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "b", "c", "a", "b", "c", "a", "b", "c", "a"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), - "predicted_class_probability_b" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), - "predicted_class_probability_c" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3) +data_bad_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), + "b" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3), + "c" = c(1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3, 1 / 3) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_ok_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "b", "a", "b", "a", "b", "c", "b", "c", "c"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(1.0, 0.2, 0.4, 0.0, 0.4, 0.1, 0.0, 0.0, 0.0, 0.1), - "predicted_class_probability_b" = c(0.0, 0.5, 0.3, 1.0, 0.3, 0.5, 0.0, 0.6, 0.4, 0.3), - "predicted_class_probability_c" = c(0.0, 0.3, 0.3, 0.0, 0.3, 0.4, 1.0, 0.4, 0.6, 0.7) +data_ok_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1.0, 0.2, 0.4, 0.0, 0.4, 0.1, 0.0, 0.0, 0.0, 0.1), + "b" = c(0.0, 0.5, 0.3, 1.0, 0.3, 0.5, 0.0, 0.6, 0.4, 0.3), + "c" = c(0.0, 0.3, 0.3, 0.0, 0.3, 0.4, 1.0, 0.4, 0.6, 0.7) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_inv_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("b", "b", "b", "c", "c", "c", "a", "a", "a", "a"), levels = c("a", "b", "c")), - "predicted_class_probability_a" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1), - "predicted_class_probability_b" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), - "predicted_class_probability_c" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0) +data_inv_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1), + "b" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), + "c" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) # Package data in a list for easier iterative tests data_list <- list( - "good_binomial" = list("data" = data_good_binomial, "outcome_type" = "binomial"), - "bad_binomial" = list("data" = data_bad_binomial, "outcome_type" = "binomial"), - "ok_binomial" = list("data" = data_ok_binomial, "outcome_type" = "binomial"), - "inv_binomial" = list("data" = data_inv_binomial, "outcome_type" = "binomial"), - "good_multinomial" = list("data" = data_good_multinomial, "outcome_type" = "multinomial"), - "bad_multinomial" = list("data" = data_bad_multinomial, "outcome_type" = "multinomial"), - "ok_multinomial" = list("data" = data_ok_multinomial, "outcome_type" = "multinomial"), - "inv_multinomial" = list("data" = data_inv_multinomial, "outcome_type" = "multinomial") + "good_binomial" = data_good_binomial, + "bad_binomial" = data_bad_binomial, + "ok_binomial" = data_ok_binomial, + "inv_binomial" = data_inv_binomial, + "good_multinomial" = data_good_multinomial, + "bad_multinomial" = data_bad_multinomial, + "ok_multinomial" = data_ok_multinomial, + "inv_multinomial" = data_inv_multinomial ) + # Brier score ------------------------------------------------------------------ testthat::test_that("Brier score is correct", { expected_score <- c(0.0, 1 / 4, 0.18, 1.0, 0.0, 1 / 3, 391 / 2000, 1.0) @@ -87,23 +107,26 @@ testthat::test_that("Brier score is correct", { # Create metric object. metric_object <- familiar:::as_metric( metric = "brier", - outcome_type = data_list[[ii]]$outcome_type) - + outcome_type = data_list[[ii]]@outcome_type + ) + # Set baseline-value explicitly. metric_object@baseline_value <- 1.0 # Check that the metric is available - testthat::expect_equal(familiar:::is_available(metric_object), TRUE) + testthat::expect_true(familiar:::is_available(metric_object)) # Compute the metric score. score <- familiar:::compute_metric_score( metric = metric_object, - data = data_list[[ii]]$data) + data = data_list[[ii]] + ) objective_score <- familiar:::compute_objective_score( metric = metric_object, - data = data_list[[ii]]$data) - + data = data_list[[ii]] + ) + # Test the values. testthat::expect_equal(score, expected_score[ii]) testthat::expect_equal(objective_score, expected_objective[ii]) diff --git a/tests/testthat/test-metric_concordance_index_S4.R b/tests/testthat/test-metric_concordance_index_S4.R index 82e64291..aa5e7e35 100644 --- a/tests/testthat/test-metric_concordance_index_S4.R +++ b/tests/testthat/test-metric_concordance_index_S4.R @@ -1,14 +1,37 @@ -familiar:::test_all_metrics_available(metrics = familiar:::.get_available_concordance_index_metrics()) +familiar:::test_all_metrics_available( + metrics = familiar:::.get_available_concordance_index_metrics() +) # Skip remainder on CRAN due to runtimes. testthat::skip_on_cran() +# power.transform and other packages are required. +if (!rlang::is_installed("power.transform")) testthat::skip() + familiar:::test_all_metrics( metrics = familiar:::.get_available_concordance_index_metrics(), not_available_single_sample = TRUE, - not_available_all_samples_identical = TRUE) + not_available_all_samples_identical = TRUE +) + +.as_risk <- function(x) { + familiar::as_prediction_table( + x = x$predicted_outcome, + y = list("outcome_time" = x$outcome_time, "outcome_event" = x$outcome_event), + type = "hazard_ratio" + ) +} + +.as_lifetime <- function(x) { + familiar::as_prediction_table( + x = x$predicted_outcome, + y = list("outcome_time" = x$outcome_time, "outcome_event" = x$outcome_event), + type = "expected_survival_time" + ) +} + data_good_no_censoring_risk <- data.table::data.table( "outcome_time" = c(1, 2, 3, 4, 5), "outcome_event" = c(1, 1, 1, 1, 1), @@ -112,25 +135,27 @@ data_all_censoring_risk <- data.table::data.table( ) data_list <- list( - "good_no_censoring_risk" = list("data" = data_good_no_censoring_risk), - "inv_no_censoring_risk" = list("data" = data_inv_no_censoring_risk), - "bad_no_censoring_risk" = list("data" = data_bad_no_censoring_risk), - "moderate_no_censoring_risk" = list("data" = data_moderate_no_censoring_risk), - "good_init_censoring_risk" = list("data" = data_good_init_censoring_risk), - "inv_init_censoring_risk" = list("data" = data_inv_init_censoring_risk), - "bad_init_censoring_risk" = list("data" = data_bad_init_censoring_risk), - "moderate_init_censoring_risk" = list("data" = data_moderate_init_censoring_risk), - "good_end_censoring_risk" = list("data" = data_good_end_censoring_risk), - "inv_end_censoring_risk" = list("data" = data_inv_end_censoring_risk), - "bad_end_censoring_risk" = list("data" = data_bad_end_censoring_risk), - "moderate_end_censoring_risk" = list("data" = data_moderate_end_censoring_risk), - "good_mid_censoring_risk" = list("data" = data_good_mid_censoring_risk), - "inv_mid_censoring_risk" = list("data" = data_inv_mid_censoring_risk), - "bad_mid_censoring_risk" = list("data" = data_bad_mid_censoring_risk), - "moderate_mid_censoring_risk" = list("data" = data_moderate_mid_censoring_risk), - "all_censoring_risk" = list("data" = data_all_censoring_risk) + "good_no_censoring_risk" = data_good_no_censoring_risk, + "inv_no_censoring_risk" = data_inv_no_censoring_risk, + "bad_no_censoring_risk" = data_bad_no_censoring_risk, + "moderate_no_censoring_risk" = data_moderate_no_censoring_risk, + "good_init_censoring_risk" = data_good_init_censoring_risk, + "inv_init_censoring_risk" = data_inv_init_censoring_risk, + "bad_init_censoring_risk" = data_bad_init_censoring_risk, + "moderate_init_censoring_risk" = data_moderate_init_censoring_risk, + "good_end_censoring_risk" = data_good_end_censoring_risk, + "inv_end_censoring_risk" = data_inv_end_censoring_risk, + "bad_end_censoring_risk" = data_bad_end_censoring_risk, + "moderate_end_censoring_risk" = data_moderate_end_censoring_risk, + "good_mid_censoring_risk" = data_good_mid_censoring_risk, + "inv_mid_censoring_risk" = data_inv_mid_censoring_risk, + "bad_mid_censoring_risk" = data_bad_mid_censoring_risk, + "moderate_mid_censoring_risk" = data_moderate_mid_censoring_risk, + "all_censoring_risk" = data_all_censoring_risk ) + + # Test for risk-like predictions ----------------------------------------------- testthat::test_that("Concordance index for risk-like predictions is correct", { expected_score <- c( @@ -145,23 +170,25 @@ testthat::test_that("Concordance index for risk-like predictions is correct", { # Create metric object. metric_object <- familiar:::as_metric( metric = "concordance_index", - outcome_type = "survival", - prediction_type = "hazard_ratio") + outcome_type = "survival" + ) # Iterate over the data sets. for (ii in seq_along(data_list)) { # Check that the metric is available - testthat::expect_equal(familiar:::is_available(metric_object), TRUE) + testthat::expect_true(familiar:::is_available(metric_object)) # Compute the metric value. score <- familiar:::compute_metric_score( metric = metric_object, - data = data_list[[ii]]$data) + data = .as_risk(data_list[[ii]]) + ) # Compute the objective score. objective_score <- familiar:::compute_objective_score( metric = metric_object, - data = data_list[[ii]]$data) + data = .as_risk(data_list[[ii]]) + ) # Test the values. testthat::expect_equal(score, expected_score[ii]) @@ -183,23 +210,25 @@ testthat::test_that("Concordance index for time-like predictions is correct", { # Create metric object. metric_object <- familiar:::as_metric( metric = "concordance_index", - outcome_type = "survival", - prediction_type = "expected_survival_time") + outcome_type = "survival" + ) # Iterate over the data sets. for (ii in seq_along(data_list)) { # Check that the metric is available - testthat::expect_equal(familiar:::is_available(metric_object), TRUE) + testthat::expect_true(familiar:::is_available(metric_object)) # Compute the metric value. score <- familiar:::compute_metric_score( metric = metric_object, - data = data_list[[ii]]$data) + data = .as_lifetime(data_list[[ii]]) + ) # Compute the objective score. objective_score <- familiar:::compute_objective_score( metric = metric_object, - data = data_list[[ii]]$data) + data = .as_lifetime(data_list[[ii]]) + ) # Test the values. testthat::expect_equal(score, expected_score[ii]) diff --git a/tests/testthat/test-metric_confusion_matrix_metrics_S4.R b/tests/testthat/test-metric_confusion_matrix_metrics_S4.R index afeff479..af4642e7 100644 --- a/tests/testthat/test-metric_confusion_matrix_metrics_S4.R +++ b/tests/testthat/test-metric_confusion_matrix_metrics_S4.R @@ -1,18 +1,22 @@ familiar:::test_all_metrics_available( - metrics = familiar:::.get_available_confusion_matrix_metrics()) + metrics = familiar:::.get_available_confusion_matrix_metrics() +) # Don't perform any further tests on CRAN due to time of running the complete # test. testthat::skip_on_cran() testthat::skip_on_ci() +# power.transform and other packages are required. +if (!rlang::is_installed("power.transform")) testthat::skip() cm_metric_test <- function( metric, data_list, baseline_value, expected_score, - expected_objective = NULL) { + expected_objective = NULL +) { # For several metrics the objective score and the expected score are the same. if (is.null(expected_objective)) expected_objective <- expected_score @@ -35,78 +39,105 @@ cm_metric_test <- function( # Create metric object metric_object <- familiar:::as_metric( metric = metric, - outcome_type = data_list[[ii]]$outcome_type) + outcome_type = data_list[[ii]]@outcome_type + ) # Set baseline-value explicitly. metric_object@baseline_value <- baseline_value # Check that the metric is available - testthat::expect_equal(familiar:::is_available(metric_object), TRUE) + testthat::expect_true(familiar:::is_available(metric_object)) # Compute the metric value. score <- familiar:::compute_metric_score( metric = metric_object, - data = data_list[[ii]]$data) + data = data_list[[ii]] + ) # Compute the objective score. objective_score <- familiar:::compute_objective_score( metric = metric_object, - data = data_list[[ii]]$data) + data = data_list[[ii]] + ) # Test the values. testthat::expect_equal(score, expected_score[ii]) testthat::expect_equal(objective_score, expected_objective[ii]) } } - -# Set up examples -data_good_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")) +data_good_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0), + "b" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_bad_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("b", "b", "b", "b", "b", "a", "a", "a", "a", "a"), levels = c("a", "b")) +data_ok_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1.0, 0.9, 0.8, 0.7, 0.3, 0.7, 0.6, 0.2, 0.1, 0.0), + "b" = c(0.0, 0.1, 0.2, 0.3, 0.7, 0.3, 0.4, 0.8, 0.9, 1.0) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_ok_binomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b")), - "predicted_class" = factor(c("a", "a", "a", "a", "b", "a", "a", "b", "b", "b"), levels = c("a", "b")) +data_bad_binomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1), + "b" = c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0) + ), + y = list("outcome" = factor(c("a", "a", "a", "a", "a", "b", "b", "b", "b", "b"), levels = c("a", "b"))), + type = "classification" ) -data_good_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")) +data_good_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0), + "b" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0), + "c" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_bad_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("c", "c", "c", "a", "a", "a", "b", "b", "b", "b"), levels = c("a", "b", "c")) +data_ok_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(1.0, 0.4, 0.3, 0.7, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0), + "b" = c(0.0, 0.3, 0.4, 0.2, 1.0, 0.4, 0.0, 0.4, 0.4, 0.3), + "c" = c(0.0, 0.3, 0.3, 0.1, 0.0, 0.5, 1.0, 0.6, 0.6, 0.7) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) -data_ok_multinomial <- data.table::data.table( - "outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c")), - "predicted_class" = factor(c("a", "a", "b", "a", "b", "c", "c", "c", "c", "c"), levels = c("a", "b", "c")) +data_bad_multinomial <- familiar::as_prediction_table( + x = data.table::data.table( + "a" = c(0, 0, 0, 1, 1, 1, 0, 0, 0, 0), + "b" = c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1), + "c" = c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0) + ), + y = list("outcome" = factor(c("a", "a", "a", "b", "b", "b", "c", "c", "c", "c"), levels = c("a", "b", "c"))), + type = "classification" ) + # Package data in a list for easier iterative tests data_list <- list( - "good_binomial" = list("data" = data_good_binomial, "outcome_type" = "binomial"), - "bad_binomial" = list("data" = data_bad_binomial, "outcome_type" = "binomial"), - "ok_binomial" = list("data" = data_ok_binomial, "outcome_type" = "binomial"), - "good_multinomial" = list("data" = data_good_multinomial, "outcome_type" = "multinomial"), - "bad_multinomial" = list("data" = data_bad_multinomial, "outcome_type" = "multinomial"), - "ok_multinomial" = list("data" = data_ok_multinomial, "outcome_type" = "multinomial") + "good_binomial" = data_good_binomial, + "bad_binomial" = data_bad_binomial, + "ok_binomial" = data_ok_binomial, + "good_multinomial" = data_good_multinomial, + "bad_multinomial" = data_bad_multinomial, + "ok_multinomial" = data_ok_multinomial ) # Confusion matrix ------------------------------------------------------------- testthat::test_that("confusion matrix is correct", { # Good binomial - cm_gb <- familiar:::..compute_confusion_matrix_data( - data = data_good_binomial, - outcome_type = "binomial") + cm_gb <- familiar:::..compute_confusion_matrix_data(data = data_good_binomial) testthat::expect_equal(cm_gb$tp, c(5, 5)) testthat::expect_equal(cm_gb$tn, c(5, 5)) @@ -118,9 +149,7 @@ testthat::test_that("confusion matrix is correct", { testthat::expect_equal(cm_gb$n_classes, 2) # Bad binomial - cm_bb <- familiar:::..compute_confusion_matrix_data( - data = data_bad_binomial, - outcome_type = "binomial") + cm_bb <- familiar:::..compute_confusion_matrix_data(data = data_bad_binomial) testthat::expect_equal(cm_bb$tp, c(0, 0)) testthat::expect_equal(cm_bb$tn, c(0, 0)) @@ -132,9 +161,7 @@ testthat::test_that("confusion matrix is correct", { testthat::expect_equal(cm_bb$n_classes, 2) # Ok binomial - cm_ob <- familiar:::..compute_confusion_matrix_data( - data = data_ok_binomial, - outcome_type = "binomial") + cm_ob <- familiar:::..compute_confusion_matrix_data(data = data_ok_binomial) testthat::expect_equal(cm_ob$tp, c(4, 3)) testthat::expect_equal(cm_ob$tn, c(3, 4)) @@ -146,9 +173,7 @@ testthat::test_that("confusion matrix is correct", { testthat::expect_equal(cm_ob$n_classes, 2) # Good multinomial - cm_gm <- familiar:::..compute_confusion_matrix_data( - data = data_good_multinomial, - outcome_type = "multinomial") + cm_gm <- familiar:::..compute_confusion_matrix_data(data = data_good_multinomial) testthat::expect_equal(cm_gm$tp, c(3, 3, 4)) testthat::expect_equal(cm_gm$tn, c(7, 7, 6)) @@ -160,9 +185,7 @@ testthat::test_that("confusion matrix is correct", { testthat::expect_equal(cm_gm$n_classes, 3) # Bad multinomial - cm_bm <- familiar:::..compute_confusion_matrix_data( - data = data_bad_multinomial, - outcome_type = "multinomial") + cm_bm <- familiar:::..compute_confusion_matrix_data(data = data_bad_multinomial) testthat::expect_equal(cm_bm$tp, c(0, 0, 0)) testthat::expect_equal(cm_bm$tn, c(4, 3, 3)) @@ -174,9 +197,7 @@ testthat::test_that("confusion matrix is correct", { testthat::expect_equal(cm_bm$n_classes, 3) # Ok multinomial - cm_om <- familiar:::..compute_confusion_matrix_data( - data = data_ok_multinomial, - outcome_type = "multinomial") + cm_om <- familiar:::..compute_confusion_matrix_data(data = data_ok_multinomial) testthat::expect_equal(cm_om$tp, c(2, 1, 4)) testthat::expect_equal(cm_om$tn, c(6, 6, 5)) @@ -192,7 +213,8 @@ testthat::test_that("confusion matrix is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_accuracy_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("accuracy is correct", { for (metric in familiar:::.get_available_accuracy_metrics()) { @@ -209,7 +231,8 @@ testthat::test_that("accuracy is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_balanced_accuracy_metrics(), not_available_single_sample = TRUE, - not_available_all_samples_identical = TRUE) + not_available_all_samples_identical = TRUE +) testthat::test_that("balanced accuracy is correct", { for (metric in familiar:::.get_available_balanced_accuracy_metrics()) { diff --git a/tests/testthat/test-metric_regression_S4.R b/tests/testthat/test-metric_regression_S4.R index a9bbf560..07958568 100644 --- a/tests/testthat/test-metric_regression_S4.R +++ b/tests/testthat/test-metric_regression_S4.R @@ -1,11 +1,14 @@ familiar:::test_all_metrics_available( - metrics = familiar:::.get_available_regression_metrics()) + metrics = familiar:::.get_available_regression_metrics() +) # Don't perform any further tests on CRAN due to time of running the complete # test. testthat::skip_on_cran() testthat::skip_on_ci() +# power.transform and other packages are required. +if (!rlang::is_installed("power.transform")) testthat::skip() regr_metric_test <- function( metric, @@ -18,26 +21,30 @@ regr_metric_test <- function( # Create metric object metric_object <- familiar:::as_metric( metric = metric, - outcome_type = "continuous") + outcome_type = "continuous" + ) # Set baseline-value explicitly. metric_object@baseline_value <- familiar:::compute_metric_score( metric = metric_object, - data = data_list[["no_slope"]]$data) + data = data_list[["no_slope"]] + ) for (ii in seq_along(data_list)) { # Check that the metric is available - testthat::expect_equal(familiar:::is_available(metric_object), TRUE) + testthat::expect_true(familiar:::is_available(metric_object)) # Compute the metric value. score <- familiar:::compute_metric_score( metric = metric_object, - data = data_list[[ii]]$data) + data = data_list[[ii]] + ) # Compute the objective score. objective_score <- familiar:::compute_objective_score( metric = metric_object, - data = data_list[[ii]]$data) + data = data_list[[ii]] + ) # Test the values. testthat::expect_equal(score, expected_score[ii]) @@ -45,39 +52,44 @@ regr_metric_test <- function( } } - -good_data <- data.table::data.table( - "outcome" = c(1, 2, 3, 4, 5), - "predicted_outcome" = c(1, 2, 3, 4, 5) +good_data <- familiar::as_prediction_table( + x = c(1, 2, 3, 4, 5), + y = c(1, 2, 3, 4, 5), + type = "regression" ) -bad_data <- data.table::data.table( - "outcome" = c(1, 2, 3, 4, 5), - "predicted_outcome" = c(5, 4, 3, 2, 1) +bad_data <- familiar::as_prediction_table( + x = c(5, 4, 3, 2, 1), + y = c(1, 2, 3, 4, 5), + type = "regression" ) -no_slope_data <- data.table::data.table( - "outcome" = c(1, 2, 3, 4, 5), - "predicted_outcome" = c(3, 3, 3, 3, 3) +no_slope_data <- familiar::as_prediction_table( + x = c(3, 3, 3, 3, 3), + y = c(1, 2, 3, 4, 5), + type = "regression" ) -bias_offset_data <- data.table::data.table( - "outcome" = c(1, 2, 3, 4, 5), - "predicted_outcome" = c(0, 1, 2, 3, 4) +bias_offset_data <- familiar::as_prediction_table( + x = c(0, 1, 2, 3, 4), + y = c(1, 2, 3, 4, 5), + type = "regression" ) data_list <- list( - "good" = list("data" = good_data), - "bad" = list("data" = bad_data), - "no_slope" = list("data" = no_slope_data), - "bias_offset" = list("data" = bias_offset_data) + "good" = good_data, + "bad" = bad_data, + "no_slope" = no_slope_data, + "bias_offset" = bias_offset_data ) + # Mean absolute error ---------------------------------------------------------- familiar:::test_all_metrics( metrics = familiar:::.get_available_mae_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("Mean absolute error is correct", { for (metric in familiar:::.get_available_mae_metrics()) { @@ -94,7 +106,8 @@ testthat::test_that("Mean absolute error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_rae_metrics(), not_available_single_sample = TRUE, - not_available_all_samples_identical = TRUE) + not_available_all_samples_identical = TRUE +) testthat::test_that("Relative absolute error is correct", { for (metric in familiar:::.get_available_rae_metrics()) { @@ -111,7 +124,8 @@ testthat::test_that("Relative absolute error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_mlae_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("Mean log absolute error is correct", { for (metric in familiar:::.get_available_mlae_metrics()) { @@ -139,7 +153,8 @@ testthat::test_that("Mean log absolute error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_mse_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("Mean squared error is correct", { for (metric in familiar:::.get_available_mse_metrics()) { @@ -174,7 +189,8 @@ testthat::test_that("Relative squared error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_msle_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("Mean squared log error is correct", { expected_score <- c( @@ -199,7 +215,8 @@ testthat::test_that("Mean squared log error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_medea_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("Median absolute error is correct", { for (metric in familiar:::.get_available_medea_metrics()) { @@ -234,7 +251,8 @@ testthat::test_that("Root mean square error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_rrse_metrics(), not_available_single_sample = TRUE, - not_available_all_samples_identical = TRUE) + not_available_all_samples_identical = TRUE +) testthat::test_that("Root relative squared error is correct", { for (metric in familiar:::.get_available_rrse_metrics()) { @@ -251,7 +269,8 @@ testthat::test_that("Root relative squared error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_rmsle_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("Root mean square log error is correct", { expected_score <- sqrt(c( @@ -282,7 +301,8 @@ testthat::test_that("Root mean square log error is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_explained_variance_metrics(), not_available_single_sample = FALSE, - not_available_all_samples_identical = FALSE) + not_available_all_samples_identical = FALSE +) testthat::test_that("Explained variance is correct", { for (metric in familiar:::.get_available_explained_variance_metrics()) { @@ -299,7 +319,8 @@ testthat::test_that("Explained variance is correct", { familiar:::test_all_metrics( metrics = familiar:::.get_available_r_squared_metrics(), not_available_single_sample = TRUE, - not_available_all_samples_identical = TRUE) + not_available_all_samples_identical = TRUE +) testthat::test_that("R2 score is correct", { for (metric in familiar:::.get_available_r_squared_metrics()) { diff --git a/tests/testthat/test-multi_learner_vimp.R b/tests/testthat/test-multi_learner_vimp.R new file mode 100644 index 00000000..7e4966a5 --- /dev/null +++ b/tests/testthat/test-multi_learner_vimp.R @@ -0,0 +1,52 @@ +# Don't perform these tests on CRAN due to running time. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +outcome_type_available = c("continuous", "binomial", "multinomial", "survival") + +for (outcome_type in outcome_type_available) { + # Create dataset + full_data <- familiar:::test_create_good_data(outcome_type) + full_data@data[, "batch_id" := "train"] + full_data@data[121:150, "batch_id" := "test"] + + # Set variable importance method. + vimp_method <- c("concordance", "mim") + + # Set learner + learner_glm <- switch( + outcome_type, + "continuous" = "glm_gaussian", + "binomial" = "glm_logistic", + "multinomial" = "glm_multinomial", + "survival" = "cox" + ) + learner_lasso <- switch( + outcome_type, + "continuous" = "lasso_gaussian", + "binomial" = "lasso_binomial", + "multinomial" = "lasso_multinomial", + "survival" = "lasso_cox" + ) + + # Get output. + output <- suppressWarnings(familiar::summon_familiar( + data = full_data, + experimental_design = "mb + ev", + validation_batch_id = "test", + vimp_method = vimp_method, + learner = c(learner_glm, learner_lasso), + estimation_type = "point", + time_max = 3.5, + verbose = debug_flag, + parallel = FALSE + )) + + testthat::test_that("Output is correctly formed.", { + testthat::expect_length(output$familiarModel, 4L) + testthat::expect_length(output$familiarData, 8L) + testthat::expect_length(output$familiarCollection, 1L) + }) +} diff --git a/tests/testthat/test-naive_model.R b/tests/testthat/test-naive_model.R index 58649a54..7a5d4991 100644 --- a/tests/testthat/test-naive_model.R +++ b/tests/testthat/test-naive_model.R @@ -6,9 +6,10 @@ debug_flag <- FALSE # Test that creates a single naive model. familiar:::integrated_test( experimental_design = "fs+mb", - fs_method = "no_features", + vimp_method = "no_features", cluster_method = "none", imputation_method = "simple", estimation_type = "point", parallel = FALSE, - debug = debug_flag) + debug = debug_flag +) diff --git a/tests/testthat/test-object_conversion.R b/tests/testthat/test-object_conversion.R index 9557463f..9aeef8d4 100644 --- a/tests/testthat/test-object_conversion.R +++ b/tests/testthat/test-object_conversion.R @@ -166,8 +166,8 @@ testthat::test_that("Conversion of multiple familiarData objects to familiarColl "familiarCollection") }) -testthat::test_that("Conversion of multiple identical familiarEnsemble objects to familiarCollection fails", { - testthat::expect_error( +testthat::test_that("Conversion of multiple identical familiarData objects to familiarCollection fails", { + testthat::expect_s4_class( familiar::as_familiar_collection(object = list(fam_data_1, fam_data_1)), "familiarCollection") }) diff --git a/tests/testthat/test-plot_auc_curves.R b/tests/testthat/test-plot_auc_curves.R index 6e10c215..7e9e938a 100644 --- a/tests/testthat/test-plot_auc_curves.R +++ b/tests/testthat/test-plot_auc_curves.R @@ -12,7 +12,7 @@ familiar:::test_plots( data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, debug = debug_flag ) @@ -22,7 +22,7 @@ familiar:::test_plots( plot_function = familiar::plot_auc_roc_curve, data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("conf_int_style" = "step"), debug = debug_flag ) @@ -32,7 +32,7 @@ familiar:::test_plots( plot_function = familiar::plot_auc_roc_curve, data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("conf_int_style" = "none"), debug = debug_flag ) @@ -43,7 +43,7 @@ familiar:::test_plots( data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), estimation_type = "point", - test_specific_config = TRUE, + test_config = "normal", debug = debug_flag ) @@ -61,7 +61,7 @@ familiar:::test_plot_ordering( data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), plot_args = list( - "facet_by" = c("fs_method", "learner"), + "facet_by" = c("vimp_method", "learner"), "color_by" = c("data_set", "positive_class")), debug = debug_flag ) @@ -73,7 +73,7 @@ familiar:::test_plots( data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, debug = debug_flag ) @@ -83,7 +83,7 @@ familiar:::test_plots( plot_function = familiar::plot_auc_precision_recall_curve, data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("conf_int_style" = "step"), debug = debug_flag ) @@ -93,7 +93,7 @@ familiar:::test_plots( plot_function = familiar::plot_auc_precision_recall_curve, data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("conf_int_style" = "none"), debug = debug_flag ) @@ -104,7 +104,7 @@ familiar:::test_plots( data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), estimation_type = "point", - test_specific_config = TRUE, + test_config = "normal", debug = debug_flag ) @@ -122,7 +122,7 @@ familiar:::test_plot_ordering( data_element = "auc_data", outcome_type_available = c("binomial", "multinomial"), plot_args = list( - "facet_by" = c("fs_method", "learner"), + "facet_by" = c("vimp_method", "learner"), "color_by" = c("data_set", "positive_class")), debug = debug_flag ) diff --git a/tests/testthat/test-plot_confusion_matrix.R b/tests/testthat/test-plot_confusion_matrix.R index 95a7b6d6..d9ed3683 100644 --- a/tests/testthat/test-plot_confusion_matrix.R +++ b/tests/testthat/test-plot_confusion_matrix.R @@ -20,7 +20,7 @@ familiar:::test_plots( plot_function = familiar:::plot_confusion_matrix, data_element = "confusion_matrix", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("show_alpha" = "none"), debug = debug_flag ) @@ -30,7 +30,7 @@ familiar:::test_plots( plot_function = familiar:::plot_confusion_matrix, data_element = "confusion_matrix", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("show_alpha" = "by_class"), debug = debug_flag ) @@ -40,7 +40,7 @@ familiar:::test_plots( plot_function = familiar:::plot_confusion_matrix, data_element = "confusion_matrix", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("show_alpha" = "by_figure"), debug = debug_flag ) @@ -50,7 +50,7 @@ familiar:::test_plots( plot_function = familiar:::plot_confusion_matrix, data_element = "confusion_matrix", outcome_type_available = c("binomial", "multinomial"), - test_specific_config = TRUE, + test_config = "normal", plot_args = list("show_alpha" = "by_all"), debug = debug_flag ) @@ -68,6 +68,15 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_confusion_matrix, data_element = "confusion_matrix", outcome_type_available = c("binomial", "multinomial"), - plot_args = list("facet_by" = c("data_set", "learner", "fs_method")), + test_config = "normal", + debug = debug_flag +) + +# Test alignment of different plots, with missing data. +familiar:::test_plot_ordering( + plot_function = familiar:::plot_confusion_matrix, + data_element = "confusion_matrix", + outcome_type_available = c("binomial", "multinomial"), + plot_args = list("facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) diff --git a/tests/testthat/test-plot_decision_curve.R b/tests/testthat/test-plot_decision_curve.R index 1bc72743..9e59fdc8 100644 --- a/tests/testthat/test-plot_decision_curve.R +++ b/tests/testthat/test-plot_decision_curve.R @@ -11,7 +11,7 @@ familiar:::test_plots( outcome_type_available = c("binomial", "multinomial", "survival"), data_element = "decision_curve_analyis", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, not_available_extreme_probability = TRUE, debug = debug_flag @@ -22,7 +22,7 @@ familiar:::test_plots( plot_function = familiar:::plot_decision_curve, outcome_type_available = c("binomial", "multinomial", "survival"), data_element = "decision_curve_analyis", - test_specific_config = TRUE, + test_config = "normal", plot_args = list("conf_int_style" = "step"), debug = debug_flag ) @@ -32,7 +32,7 @@ familiar:::test_plots( plot_function = familiar:::plot_decision_curve, outcome_type_available = c("binomial", "multinomial", "survival"), data_element = "decision_curve_analyis", - test_specific_config = TRUE, + test_config = "normal", plot_args = list("conf_int_style" = "none"), debug = debug_flag ) @@ -43,7 +43,7 @@ familiar:::test_plots( outcome_type_available = c("binomial", "multinomial", "survival"), data_element = "decision_curve_analyis", estimation_type = "point", - test_specific_config = TRUE, + test_config = "normal", debug = debug_flag ) @@ -56,13 +56,26 @@ familiar:::test_plot_ordering( debug = debug_flag ) +# Test alignment of different plots, with missing data. Survival requires +# survival probability and cannot be generated. +familiar:::test_plot_ordering( + plot_function = familiar:::plot_decision_curve, + data_element = "decision_curve_analyis", + estimation_type = "point", + outcome_type_available = c("binomial", "multinomial", "survival"), + test_config = "normal", + prediction_type = list("survival" = "survival_probability"), + debug = debug_flag +) + + # Test alignment of different plots, with missing data. familiar:::test_plot_ordering( plot_function = familiar:::plot_decision_curve, data_element = "decision_curve_analyis", outcome_type_available = c("binomial"), plot_args = list( - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "color_by" = "data_set"), debug = debug_flag ) @@ -73,7 +86,7 @@ familiar:::test_plot_ordering( data_element = "decision_curve_analyis", outcome_type_available = c("multinomial"), plot_args = list( - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "color_by" = c("data_set", "positive_class")), debug = debug_flag ) @@ -84,7 +97,7 @@ familiar:::test_plot_ordering( data_element = "decision_curve_analyis", outcome_type_available = c("survival"), plot_args = list( - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "color_by" = c("data_set")), debug = debug_flag ) diff --git a/tests/testthat/test-plot_feature_similarity.R b/tests/testthat/test-plot_feature_similarity.R index 09dfd22a..24828404 100644 --- a/tests/testthat/test-plot_feature_similarity.R +++ b/tests/testthat/test-plot_feature_similarity.R @@ -6,14 +6,13 @@ testthat::skip_on_ci() debug_flag <- FALSE # Generic test -# Feature similarity can be computed for failing survival predictions. familiar:::test_plots( plot_function = familiar:::plot_feature_similarity, not_available_single_feature = TRUE, not_available_single_sample = TRUE, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), data_element = "feature_similarity", debug = debug_flag ) @@ -22,7 +21,7 @@ familiar:::test_plots( familiar:::test_plot_ordering( plot_function = familiar:::plot_feature_similarity, data_element = "feature_similarity", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), debug = debug_flag ) @@ -30,8 +29,8 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_feature_similarity, data_element = "feature_similarity", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), - plot_args = list("facet_by" = c("learner", "fs_method", "data_set")), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + plot_args = list("facet_by" = c("learner", "vimp_method", "data_set")), debug = debug_flag ) @@ -39,7 +38,73 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_feature_similarity, data_element = "feature_similarity", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list("show_dendrogram" = c("left", "bottom")), debug = debug_flag ) + + +# Test normal tests. +familiar:::test_plots( + plot_function = familiar:::plot_feature_similarity, + feature_similarity_metric = "spearman", + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + data_element = "feature_similarity", + debug = debug_flag, + test_config = "normal" +) + + +familiar:::test_plots( + plot_function = familiar:::plot_feature_similarity, + feature_similarity_metric = "mutual_information", + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + data_element = "feature_similarity", + debug = debug_flag, + test_config = "normal" +) + + +# Test plotting from dataObject. +data <- familiar:::test_create_good_data(outcome_type = "continuous") +p <- familiar::plot_feature_similarity(object = data, feature_similarity_metric = "spearman") +testthat::test_that("Plotting feature similarity using dataObject works.", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + +# Test plotting from dataObject with two groups. +data <- familiar:::test_create_good_data(outcome_type = "continuous", two_groups = TRUE) +p <- familiar::plot_feature_similarity(object = data, feature_similarity_metric = "spearman") +testthat::test_that("Plotting feature similarity for two groups works.", { + testthat::expect_length(p, 2L) + testthat::expect_true(is(p[[1L]], "gtable")) + testthat::expect_true(is(p[[2L]], "gtable")) +}) + + +# Test plotting from data.table. +data <- familiar:::test_create_good_data(outcome_type = "continuous", to_data_object = FALSE) +p <- familiar::plot_feature_similarity( + object = data, + feature_similarity_metric = "spearman", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_type = "continuous", + outcome_column = "outcome" +) +testthat::test_that("Plotting feature similarity using data.table works.", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + + +# Test plotting from data.table without outcome data. +data <- familiar:::test_create_good_data(outcome_type = "continuous", to_data_object = FALSE) +data[, ":="("batch_id" = NULL, "sample_id" = NULL, "series_id" = NULL, "outcome" = NULL)] +p <- familiar::plot_feature_similarity( + object = data, + feature_similarity_metric = "spearman" +) +testthat::test_that("Plotting feature similarity using data.table works.", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) diff --git a/tests/testthat/test-plot_ice_a.R b/tests/testthat/test-plot_ice_a.R new file mode 100644 index 00000000..c67877c5 --- /dev/null +++ b/tests/testthat/test-plot_ice_a.R @@ -0,0 +1,30 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +familiar:::test_plots( + plot_function = familiar:::plot_ice, + not_available_some_predictions_fail = FALSE, + data_element = "ice_data", + debug = debug_flag +) + +# The default limit for the number of important features exceeds the number of +# features in the data, which means that no actual feature selection has +# to take place. To test all path ways, we set the number of important features +# to one here. Because the test routine relies on "none" as variable importance +# method, this triggers ad-hoc feature selection when computing the dataset. +# This will fail if outcome data are absent, mostly absent, or singular. +familiar:::test_plots( + plot_function = familiar:::plot_ice, + not_available_some_predictions_fail = FALSE, + not_available_all_prospective = TRUE, + not_available_mostly_prospective = TRUE, + not_available_single_sample = TRUE, + data_element = "ice_data", + n_important_features = 1L, + debug = debug_flag +) diff --git a/tests/testthat/test-0_plot_ice_b.R b/tests/testthat/test-plot_ice_b.R similarity index 81% rename from tests/testthat/test-0_plot_ice_b.R rename to tests/testthat/test-plot_ice_b.R index 161e15a9..4cf4c60e 100644 --- a/tests/testthat/test-0_plot_ice_b.R +++ b/tests/testthat/test-plot_ice_b.R @@ -10,7 +10,7 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "survival", - features = c("adhere"), + features = c("feature_4"), sample_limit = 20L, n_sample_points = 10L, debug = debug_flag @@ -21,9 +21,9 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "survival", - features = c("nodes"), + features = c("feature_1"), plot_args = list( - "anchor_values" = list("nodes" = 2.5), + "anchor_values" = list("feature_1" = 0.4), "value_scales" = "figure"), sample_limit = 20L, n_sample_points = 10L, @@ -35,9 +35,9 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "survival", - features = c("nodes"), + features = c("feature_1"), plot_args = list( - "anchor_values" = list("nodes" = 2.5), + "anchor_values" = list("feature_1" = 0.4), "value_scales" = "figure"), sample_limit = 20L, n_sample_points = 10L, @@ -50,7 +50,7 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "survival", - features = c("nodes"), + features = c("feature_1"), plot_args = list("show_ice" = FALSE), sample_limit = 20L, n_sample_points = 10L, @@ -63,7 +63,7 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "survival", - features = c("nodes"), + features = c("feature_1"), plot_args = list("show_pd" = FALSE), sample_limit = 20L, n_sample_points = 10L, @@ -77,12 +77,12 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "multinomial", - features = c("Sepal_Length"), + features = c("feature_1"), plot_args = list( - "anchor_values" = list("Sepal_Length" = 5.05), + "anchor_values" = list("feature_1" = 0.4), "value_scales" = "figure", "color_by" = "positive_class", - "facet_by" = c("data_set", "fs_method", "learner")), + "facet_by" = c("data_set", "vimp_method", "learner")), sample_limit = 20L, n_sample_points = 10L, create_novelty_detector = TRUE, @@ -96,12 +96,12 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "multinomial", - features = c("Sepal_Length"), + features = c("feature_1"), plot_args = list( - "anchor_values" = list("Sepal_Length" = 5.05), + "anchor_values" = list("feature_1" = 0.40), "value_scales" = "facet", "color_by" = "positive_class", - "facet_by" = c("data_set", "fs_method", "learner")), + "facet_by" = c("data_set", "vimp_method", "learner")), sample_limit = 20L, n_sample_points = 10L, create_novelty_detector = TRUE, @@ -114,11 +114,11 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "multinomial", - features = c("Sepal_Length"), + features = c("feature_1"), plot_args = list( - "anchor_values" = list("Sepal_Length" = 5.05), + "anchor_values" = list("feature_1" = 0.40), "value_scales" = "figure", - "split_by" = c("fs_method", "learner"), + "split_by" = c("vimp_method", "learner"), "color_by" = "positive_class", "facet_by" = "data_set"), sample_limit = 20L, @@ -132,11 +132,11 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "survival", - features = c("rx", "nodes"), + features = c("feature_1", "feature_4"), plot_args = list( "anchor_values" = list( - "rx" = "Obs", - "nodes" = 2.5), + "feature_1" = 0.4, + "feature_4" = "better"), "value_scales" = "figure"), sample_limit = 20L, n_sample_points = 10L, @@ -148,11 +148,11 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "survival", - features = c("rx", "nodes"), + features = c("feature_1", "feature_4"), plot_args = list( "anchor_values" = list( - "rx" = "Obs", - "nodes" = 2.5), + "feature_1" = 0.4, + "feature_4" = "better"), "value_scales" = "figure"), sample_limit = 20L, n_sample_points = 10L, @@ -165,11 +165,11 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_ice, data_element = "ice_data", outcome_type_available = "multinomial", - features = c("Sepal_Length", "Petal_Width"), + features = c("feature_1", "feature_2a"), plot_args = list( "anchor_values" = list( - "Sepal_Length" = 5.05, - "Petal_Width" = 1.05), + "feature_1" = 0.4, + "feature_2a" = 0.4), "value_scales" = "figure"), sample_limit = 20L, n_sample_points = 10L, diff --git a/tests/testthat/test-plot_kaplan_meier_curve.R b/tests/testthat/test-plot_kaplan_meier_curve.R index bb2fa548..43a86471 100644 --- a/tests/testthat/test-plot_kaplan_meier_curve.R +++ b/tests/testthat/test-plot_kaplan_meier_curve.R @@ -23,14 +23,24 @@ familiar:::test_plot_ordering( debug = debug_flag ) +# Test alignment of different plots, with missing data. +familiar:::test_plot_ordering( + plot_function = familiar:::plot_kaplan_meier, + data_element = "risk_stratification_data", + outcome_type_available = c("survival"), + use_prediction_table = TRUE, + prediction_type = list("survival" = "risk_stratification"), + debug = debug_flag +) + # Test alignment of different plots, with missing data. familiar:::test_plot_ordering( plot_function = familiar:::plot_kaplan_meier, data_element = "risk_stratification_data", outcome_type_available = c("survival"), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "color_by" = "risk_group"), + "facet_by" = c("learner", "vimp_method", "data_set"), + "color_by" = "group"), debug = debug_flag ) @@ -42,8 +52,8 @@ familiar:::test_plot_ordering( experiment_args = list( stratification_method = "fixed"), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "color_by" = "risk_group"), + "facet_by" = c("learner", "vimp_method", "data_set"), + "color_by" = "group"), debug = debug_flag ) @@ -56,8 +66,8 @@ familiar:::test_plot_ordering( stratification_method = "fixed", stratification_threshold = c(0.20, 0.40, 0.60, 0.80)), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "color_by" = "risk_group"), + "facet_by" = c("learner", "vimp_method", "data_set"), + "color_by" = "group"), debug = debug_flag ) @@ -70,8 +80,68 @@ familiar:::test_plot_ordering( stratification_method = c("median", "fixed"), stratification_threshold = c(0.20, 0.40, 0.60, 0.80)), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), - "color_by" = "risk_group", + "facet_by" = c("learner", "vimp_method", "data_set"), + "color_by" = "group", "split_by" = "stratification_method"), debug = debug_flag ) + + + +# Test plotting from dataObject. +data <- familiar:::test_create_good_data(outcome_type = "survival") +p <- familiar::plot_kaplan_meier(object = data) +testthat::test_that("Plotting kaplan-meier curves using dataObject works (survival).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + + +# Test plotting from dataObject with two groups. +data <- familiar:::test_create_good_data(outcome_type = "survival", two_groups = TRUE) +p <- familiar::plot_kaplan_meier(object = data) +testthat::test_that("Plotting kaplan-meier curves for two groups works.", { + testthat::expect_length(p, 1L) + testthat::expect_true(is(p[[1L]], "gtable")) +}) + + +# Test plotting from data.table. +data <- familiar:::test_create_good_data(outcome_type = "survival", to_data_object = FALSE) +p <- familiar::plot_kaplan_meier( + object = data, + feature_similarity_metric = "spearman", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_type = "survival", + outcome_column = c("outcome_time", "outcome_event") +) +testthat::test_that("Plotting kaplan-meier curves using data.table works (survival).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + + +# Test plotting from data.table without feature data. +data <- familiar:::test_create_data_without_feature(outcome_type = "survival", to_data_object = FALSE) +p <- familiar::plot_kaplan_meier( + object = data, + feature_similarity_metric = "spearman", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_type = "survival", + outcome_column = c("outcome_time", "outcome_event") +) +testthat::test_that("Plotting kaplan-meier curves using data.table without any feature works (survival).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + + +# Test plotting from dataObject with a risk_group_column. +data <- familiar:::test_create_good_data(outcome_type = "survival") +data@data[, "risk_group" := "risk-group A"] +data@data[51L:100L, "risk_group" := "risk-group B"] +p <- familiar::plot_kaplan_meier(object = data, risk_group_column = "risk_group") +testthat::test_that("Plotting kaplan-meier curves using data.table without a risk_group_column works (survival).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) diff --git a/tests/testthat/test-plot_model_performance.R b/tests/testthat/test-plot_model_performance.R index 82ff8717..7e880890 100644 --- a/tests/testthat/test-plot_model_performance.R +++ b/tests/testthat/test-plot_model_performance.R @@ -10,9 +10,9 @@ familiar:::test_plots( plot_function = familiar:::plot_model_performance, data_element = "model_performance", not_available_all_prospective = TRUE, - not_available_any_prospective = c("binomial", "multinomial", "survival"), + not_available_mostly_prospective = c("binomial", "multinomial", "survival"), not_available_single_sample = c("binomial", "multinomial", "survival"), - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), debug = debug_flag ) @@ -21,7 +21,16 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", outcome_type_available = c("binomial", "multinomial"), - plot_args = list("facet_by" = c("data_set", "learner", "fs_method")), + plot_args = list("facet_by" = c("data_set", "learner", "vimp_method")), + debug = debug_flag +) + +familiar:::test_plot_ordering( + plot_function = familiar:::plot_model_performance, + data_element = "model_performance", + outcome_type_available = c("binomial", "multinomial"), + plot_args = list("facet_by" = c("data_set", "learner", "vimp_method")), + use_prediction_table = TRUE, debug = debug_flag ) @@ -31,7 +40,7 @@ familiar:::test_plot_ordering( metric = c("auc_roc", "accuracy"), outcome_type_available = c("binomial", "multinomial"), plot_args = list( - "facet_by" = c("data_set", "learner", "fs_method"), + "facet_by" = c("data_set", "learner", "vimp_method"), "x_axis_by" = "metric"), debug = debug_flag ) @@ -42,7 +51,7 @@ familiar:::test_plot_ordering( metric = c("auc_roc", "accuracy"), outcome_type_available = c("binomial", "multinomial"), plot_args = list( - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "x_axis_by" = "data_set", "color_by" = "metric"), debug = debug_flag @@ -52,8 +61,17 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", - outcome_type_available = c("count", "continuous"), - plot_args = list("facet_by" = c("data_set", "learner", "fs_method")), + outcome_type_available = c("continuous"), + plot_args = list("facet_by" = c("data_set", "learner", "vimp_method")), + debug = debug_flag +) + +familiar:::test_plot_ordering( + plot_function = familiar:::plot_model_performance, + data_element = "model_performance", + outcome_type_available = c("continuous"), + plot_args = list("facet_by" = c("data_set", "learner", "vimp_method")), + use_prediction_table = TRUE, debug = debug_flag ) @@ -61,9 +79,9 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( - "facet_by" = c("data_set", "learner", "fs_method"), + "facet_by" = c("data_set", "learner", "vimp_method"), "x_axis_by" = "metric"), debug = debug_flag ) @@ -72,9 +90,9 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "x_axis_by" = "data_set", "color_by" = "metric"), debug = debug_flag @@ -85,7 +103,16 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", outcome_type_available = c("survival"), - plot_args = list("facet_by" = c("data_set", "learner", "fs_method")), + plot_args = list("facet_by" = c("data_set", "learner", "vimp_method")), + debug = debug_flag +) + +familiar:::test_plot_ordering( + plot_function = familiar:::plot_model_performance, + data_element = "model_performance", + outcome_type_available = c("survival"), + plot_args = list("facet_by" = c("data_set", "learner", "vimp_method")), + use_prediction_table = TRUE, debug = debug_flag ) @@ -96,7 +123,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("binomial", "multinomial"), plot_args = list( "plot_type" = "barplot", - "facet_by" = c("data_set", "learner", "fs_method")), + "facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) @@ -107,7 +134,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("binomial", "multinomial"), plot_args = list( "plot_type" = "barplot", - "facet_by" = c("data_set", "learner", "fs_method"), + "facet_by" = c("data_set", "learner", "vimp_method"), "x_axis_by" = "metric"), debug = debug_flag ) @@ -119,7 +146,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("binomial", "multinomial"), plot_args = list( "plot_type" = "barplot", - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "x_axis_by" = "data_set", "color_by" = "metric"), debug = debug_flag @@ -129,10 +156,10 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "barplot", - "facet_by" = c("data_set", "learner", "fs_method")), + "facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) @@ -140,10 +167,10 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "barplot", - "facet_by" = c("data_set", "learner", "fs_method"), + "facet_by" = c("data_set", "learner", "vimp_method"), "x_axis_by" = "metric"), debug = debug_flag ) @@ -152,10 +179,10 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "barplot", - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "x_axis_by" = "data_set", "color_by" = "metric"), debug = debug_flag @@ -168,7 +195,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("survival"), plot_args = list( "plot_type" = "barplot", - "facet_by" = c("data_set", "learner", "fs_method")), + "facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) @@ -179,7 +206,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("binomial", "multinomial"), plot_args = list( "plot_type" = "boxplot", - "facet_by" = c("data_set", "learner", "fs_method")), + "facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) @@ -190,7 +217,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("binomial", "multinomial"), plot_args = list( "plot_type" = "boxplot", - "facet_by" = c("data_set", "learner", "fs_method"), + "facet_by" = c("data_set", "learner", "vimp_method"), "x_axis_by" = "metric"), debug = debug_flag ) @@ -202,7 +229,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("binomial", "multinomial"), plot_args = list( "plot_type" = "boxplot", - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "x_axis_by" = "data_set", "color_by" = "metric"), debug = debug_flag @@ -212,10 +239,10 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "boxplot", - "facet_by" = c("data_set", "learner", "fs_method")), + "facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) @@ -223,10 +250,10 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "boxplot", - "facet_by" = c("data_set", "learner", "fs_method"), + "facet_by" = c("data_set", "learner", "vimp_method"), "x_axis_by" = "metric"), debug = debug_flag ) @@ -235,10 +262,10 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "boxplot", - "facet_by" = c("learner", "fs_method"), + "facet_by" = c("learner", "vimp_method"), "x_axis_by" = "data_set", "color_by" = "metric"), debug = debug_flag @@ -251,7 +278,7 @@ familiar:::test_plot_ordering( outcome_type_available = c("survival"), plot_args = list( "plot_type" = "boxplot", - "facet_by" = c("data_set", "learner", "fs_method")), + "facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) @@ -282,7 +309,7 @@ familiar:::test_plot_ordering( "plot_type" = "heatmap", "facet_by" = c("data_set", "metric"), "x_axis_by" = "learner", - "y_axis_by" = "fs_method"), + "y_axis_by" = "vimp_method"), debug = debug_flag ) @@ -296,7 +323,7 @@ familiar:::test_plot_ordering( "annotate_performance" = "value_ci", "facet_by" = c("data_set", "metric"), "x_axis_by" = "learner", - "y_axis_by" = "fs_method"), + "y_axis_by" = "vimp_method"), debug = debug_flag ) @@ -313,7 +340,7 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list("plot_type" = "heatmap"), debug = debug_flag ) @@ -322,12 +349,12 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "heatmap", "facet_by" = c("data_set", "metric"), "x_axis_by" = "learner", - "y_axis_by" = "fs_method"), + "y_axis_by" = "vimp_method"), debug = debug_flag ) @@ -335,13 +362,13 @@ familiar:::test_plot_ordering( plot_function = familiar:::plot_model_performance, data_element = "model_performance", metric = c("rmse", "mae"), - outcome_type_available = c("count", "continuous"), + outcome_type_available = c("continuous"), plot_args = list( "plot_type" = "heatmap", "annotate_performance" = "value_ci", "facet_by" = c("data_set", "metric"), "x_axis_by" = "learner", - "y_axis_by" = "fs_method"), + "y_axis_by" = "vimp_method"), debug = debug_flag ) diff --git a/tests/testthat/test-plot_model_ranks.R b/tests/testthat/test-plot_model_ranks.R index 2ee9f699..d7f09806 100644 --- a/tests/testthat/test-plot_model_ranks.R +++ b/tests/testthat/test-plot_model_ranks.R @@ -10,7 +10,7 @@ familiar:::test_plots( not_available_no_samples = FALSE, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), data_element = "model_vimp", debug = debug_flag ) @@ -19,7 +19,7 @@ familiar:::test_plots( familiar:::test_plot_ordering( plot_function = familiar:::plot_model_signature_occurrence, data_element = "model_vimp", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), debug = debug_flag ) @@ -27,10 +27,10 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_model_signature_occurrence, data_element = "model_vimp", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( "facet_by" = c("learner"), - "color_by" = c("fs_method")), + "color_by" = c("vimp_method")), debug = debug_flag ) @@ -40,7 +40,7 @@ familiar:::test_plots( not_available_no_samples = FALSE, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), data_element = "model_vimp", debug = debug_flag ) @@ -49,7 +49,7 @@ familiar:::test_plots( familiar:::test_plot_ordering( plot_function = familiar:::plot_model_signature_variable_importance, data_element = "model_vimp", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), debug = debug_flag ) @@ -57,9 +57,19 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_model_signature_variable_importance, data_element = "model_vimp", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( "facet_by" = c("learner"), - "color_by" = c("fs_method")), + "color_by" = c("vimp_method")), + debug = debug_flag +) + + +# With a limit to the number of features shown. +familiar:::test_plots( + plot_function = familiar::plot_model_signature_variable_importance, + data_element = "model_vimp", + test_config = "normal", + plot_args = list("limit_n_features" = 2L), debug = debug_flag ) diff --git a/tests/testthat/test-plot_permutation_variable_importance.R b/tests/testthat/test-plot_permutation_variable_importance.R index be84c9aa..65215077 100644 --- a/tests/testthat/test-plot_permutation_variable_importance.R +++ b/tests/testthat/test-plot_permutation_variable_importance.R @@ -10,10 +10,10 @@ familiar:::test_plots( plot_function = familiar:::plot_permutation_variable_importance, data_element = "permutation_vimp", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), estimation_type = "point", debug = debug_flag ) @@ -73,7 +73,7 @@ familiar:::test_plot_ordering( metric = c("auc_roc", "accuracy"), outcome_type_available = c("multinomial"), plot_args = list( - "facet_by" = c("data_set", "learner", "fs_method"), + "facet_by" = c("data_set", "learner", "vimp_method"), "color_by" = c("metric", "similarity_threshold")), debug = debug_flag ) @@ -89,3 +89,24 @@ familiar:::test_plot_ordering( outcome_type_available = c("multinomial"), debug = debug_flag ) + +# With limiting the number of features during calculation. +familiar:::test_plots( + plot_function = familiar:::plot_permutation_variable_importance, + data_element = "permutation_vimp", + test_config = "normal", + n_important_features = 2L, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + estimation_type = "point", + debug = debug_flag +) + +# With limiting the number of features during plotting. +familiar:::test_plots( + plot_function = familiar::plot_permutation_variable_importance, + data_element = "permutation_vimp", + test_config = "normal", + plot_args = list("limit_n_features" = 2L), + estimation_type = "point", + debug = debug_flag +) diff --git a/tests/testthat/test-0_plot_sample_clustering_a.R b/tests/testthat/test-plot_sample_clustering_a.R similarity index 71% rename from tests/testthat/test-0_plot_sample_clustering_a.R rename to tests/testthat/test-plot_sample_clustering_a.R index d4dc217c..2f9f6f1d 100644 --- a/tests/testthat/test-0_plot_sample_clustering_a.R +++ b/tests/testthat/test-plot_sample_clustering_a.R @@ -10,7 +10,7 @@ familiar:::test_plots( plot_function = familiar:::plot_sample_clustering, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), data_element = "feature_expressions", plot_args = list("verbose" = FALSE), debug = debug_flag @@ -20,7 +20,7 @@ familiar:::test_plots( familiar:::test_plot_ordering( plot_function = familiar:::plot_sample_clustering, data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list("verbose" = FALSE), debug = debug_flag ) @@ -29,9 +29,9 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_sample_clustering, data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), + "facet_by" = c("learner", "vimp_method", "data_set"), "verbose" = FALSE), debug = debug_flag ) @@ -40,9 +40,9 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_sample_clustering, data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), + "facet_by" = c("learner", "vimp_method", "data_set"), "x_axis_by" = "sample", "y_axis_by" = "feature", "verbose" = FALSE), @@ -53,9 +53,9 @@ familiar:::test_plot_ordering( familiar:::test_plot_ordering( plot_function = familiar:::plot_sample_clustering, data_element = "feature_expressions", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( - "facet_by" = c("learner", "fs_method", "data_set"), + "facet_by" = c("learner", "vimp_method", "data_set"), "x_axis_by" = "sample", "y_axis_by" = "feature", "show_outcome" = "bottom", diff --git a/tests/testthat/test-plot_sample_clustering_b.R b/tests/testthat/test-plot_sample_clustering_b.R new file mode 100644 index 00000000..b794b29f --- /dev/null +++ b/tests/testthat/test-plot_sample_clustering_b.R @@ -0,0 +1,151 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +# Generic test +familiar:::test_plots( + plot_function = familiar:::plot_sample_clustering, + not_available_all_predictions_fail = FALSE, + not_available_some_predictions_fail = FALSE, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + data_element = "feature_expressions", + plot_args = list( + "verbose" = FALSE, + "show_normalised_data" = "set_normalisation"), + debug = debug_flag +) + +# No extra elements +familiar:::test_plot_ordering( + plot_function = familiar:::plot_sample_clustering, + data_element = "feature_expressions", + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + plot_args = list( + "facet_by" = c("learner", "vimp_method", "data_set"), + "x_axis_by" = "sample", + "y_axis_by" = "feature", + "show_outcome" = FALSE, + "show_feature_dendrogram" = FALSE, + "show_sample_dendrogram" = FALSE, + "verbose" = FALSE), + debug = debug_flag +) + +# No normalisation. +familiar:::test_plot_ordering( + plot_function = familiar:::plot_sample_clustering, + data_element = "feature_expressions", + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + plot_args = list( + "facet_by" = c("learner", "vimp_method", "data_set"), + "show_normalised_data" = "none", + "verbose" = FALSE), + debug = debug_flag +) + +# Normalisation per dataset. +familiar:::test_plot_ordering( + plot_function = familiar:::plot_sample_clustering, + data_element = "feature_expressions", + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + plot_args = list( + "facet_by" = c("learner", "vimp_method", "data_set"), + "show_normalised_data" = "set_normalisation", + "verbose" = FALSE), + debug = debug_flag +) + + +# With sample limit +familiar:::test_plot_ordering( + plot_function = familiar:::plot_sample_clustering, + data_element = "feature_expressions", + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + plot_args = list( + "facet_by" = c("learner", "vimp_method", "data_set"), + "sample_limit" = 20L, + "verbose" = FALSE), + debug = debug_flag +) + + +# Test multiple evaluation times +familiar:::test_plot_ordering( + plot_function = familiar:::plot_sample_clustering, + data_element = "feature_expressions", + outcome_type_available = c("survival"), + plot_args = list( + "evaluation_times" = c(500, 1000, 1500, 2000), + "verbose" = FALSE), + debug = debug_flag +) + + + +# Test plotting from dataObject. +data <- familiar:::test_create_good_data(outcome_type = "survival") +p <- familiar::plot_sample_clustering(object = data, feature_similarity_metric = "spearman") +testthat::test_that("Plotting sample similarity using dataObject works (survival).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + +data <- familiar:::test_create_good_data(outcome_type = "continuous") +p <- familiar::plot_sample_clustering(object = data, feature_similarity_metric = "spearman") +testthat::test_that("Plotting sample similarity using dataObject works (continuous).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + + +# Test plotting from dataObject with two groups. +data <- familiar:::test_create_good_data(outcome_type = "continuous", two_groups = TRUE) +p <- familiar::plot_sample_clustering(object = data, feature_similarity_metric = "spearman") +testthat::test_that("Plotting sample similarity for two groups works.", { + testthat::expect_length(p, 2L) + testthat::expect_true(is(p[[1L]], "gtable")) + testthat::expect_true(is(p[[2L]], "gtable")) +}) + + +# Test plotting from data.table. +data <- familiar:::test_create_good_data(outcome_type = "survival", to_data_object = FALSE) +p <- familiar::plot_sample_clustering( + object = data, + feature_similarity_metric = "spearman", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_type = "survival", + outcome_column = c("outcome_time", "outcome_event") +) +testthat::test_that("Plotting sample similarity using data.table works (survival).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + +data <- familiar:::test_create_good_data(outcome_type = "continuous", to_data_object = FALSE) +p <- familiar::plot_sample_clustering( + object = data, + feature_similarity_metric = "spearman", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_type = "continuous", + outcome_column = "outcome" +) +testthat::test_that("Plotting sample similarity using data.table works (continuous).", { + testthat::expect_true(is(p[[1L]], "gtable")) +}) + + +# Test plotting from data.table without outcome data. +data <- familiar:::test_create_good_data(outcome_type = "continuous", to_data_object = FALSE) +data[, ":="("batch_id" = NULL, "sample_id" = NULL, "series_id" = NULL, "outcome" = NULL)] +p <- familiar::plot_sample_clustering( + object = data, + feature_similarity_metric = "spearman" +) +testthat::test_that("Plotting sample similarity using data.table works.", { + testthat::expect_true(is(p[[1]], "gtable")) +}) diff --git a/tests/testthat/test-plot_shap_dependence.R b/tests/testthat/test-plot_shap_dependence.R new file mode 100644 index 00000000..b22c1f46 --- /dev/null +++ b/tests/testthat/test-plot_shap_dependence.R @@ -0,0 +1,53 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +familiar:::test_plots( + plot_function = familiar::plot_shap_dependence, + data_element = "shap", + shap_max_iterations = 10L, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + debug = debug_flag, + not_available_no_samples = FALSE +) + +# The default limit for the number of important features exceeds the number of +# features in the data, which means that no actual feature selection has +# to take place. To test all path ways, we set the number of important features +# to one here. Because the test routine relies on "none" as variable importance +# method, this triggers ad-hoc feature selection when computing the dataset. +# This will fail if outcome data are absent, mostly absent, or singular. +familiar:::test_plots( + plot_function = familiar::plot_shap_dependence, + not_available_all_prospective = TRUE, + not_available_mostly_prospective = TRUE, + not_available_single_sample = TRUE, + data_element = "shap", + shap_max_iterations = 10L, + n_important_features = 1L, + debug = debug_flag +) + +# Test without interaction. +familiar:::test_plots( + plot_function = familiar::plot_shap_dependence, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + test_config = "normal", + debug = debug_flag +) + +# Test with interaction. +familiar:::test_plots( + plot_function = familiar::plot_shap_dependence, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("interaction_feature" = c("feature_1", "feature_3a")), + test_config = "normal", + debug = debug_flag +) diff --git a/tests/testthat/test-plot_shap_force.R b/tests/testthat/test-plot_shap_force.R new file mode 100644 index 00000000..2d52fcf2 --- /dev/null +++ b/tests/testthat/test-plot_shap_force.R @@ -0,0 +1,74 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +familiar:::test_plots( + plot_function = familiar::plot_shap_force, + data_element = "shap", + shap_max_iterations = 10L, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + debug = debug_flag, + not_available_no_samples = FALSE +) + +# The default limit for the number of important features exceeds the number of +# features in the data, which means that no actual feature selection has +# to take place. To test all path ways, we set the number of important features +# to one here. Because the test routine relies on "none" as variable importance +# method, this triggers ad-hoc feature selection when computing the dataset. +# This will fail if outcome data are absent, mostly absent, or singular. +familiar:::test_plots( + plot_function = familiar::plot_shap_force, + not_available_all_prospective = TRUE, + not_available_mostly_prospective = TRUE, + not_available_single_sample = TRUE, + data_element = "shap", + shap_max_iterations = 10L, + n_important_features = 1L, + debug = debug_flag +) + +# Test only bog-standard data: no edge cases. +familiar:::test_plots( + plot_function = familiar::plot_shap_force, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + test_config = "normal", + debug = debug_flag +) + +# Test with highlight feature. +familiar:::test_plots( + plot_function = familiar::plot_shap_force, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("highlight_feature" = c("feature_1", "feature_4")), + test_config = "normal", + debug = debug_flag +) + +# Test with original sample order. +familiar:::test_plots( + plot_function = familiar::plot_shap_force, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("sample_order" = "original"), + test_config = "normal", + debug = debug_flag +) + +# Test with single instance +familiar:::test_plots( + plot_function = familiar::plot_shap_force, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + test_config = "single instance", + debug = debug_flag +) diff --git a/tests/testthat/test-plot_shap_summary.R b/tests/testthat/test-plot_shap_summary.R new file mode 100644 index 00000000..6ae6ea74 --- /dev/null +++ b/tests/testthat/test-plot_shap_summary.R @@ -0,0 +1,155 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + debug = debug_flag, + not_available_no_samples = FALSE +) + +# The default limit for the number of important features exceeds the number of +# features in the data, which means that no actual feature selection has +# to take place. To test all path ways, we set the number of important features +# to one here. Because the test routine relies on "none" as variable importance +# method, this triggers ad-hoc feature selection when computing the dataset. +# This will fail if outcome data are absent, mostly absent, or singular. +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + not_available_all_prospective = TRUE, + not_available_mostly_prospective = TRUE, + not_available_single_sample = TRUE, + data_element = "shap", + shap_max_iterations = 10L, + n_important_features = 1L, + debug = debug_flag +) + + +# Swarm plot ------------------------------------------------------------------- +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + test_config = "normal", + debug = debug_flag +) + +# With a limit to the number of features for which SHAP values are computed. +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + test_config = "normal", + n_important_features = 2L, + debug = debug_flag +) + +# With a limit to the number of features shown. +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + test_config = "normal", + plot_args = list("limit_n_features" = 2L), + debug = debug_flag +) + +# Test with single instance +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + test_config = "single instance", + debug = debug_flag +) + +# Test with absolute values +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("value_representation" = "abs"), + test_config = "normal", + debug = debug_flag +) + + +# Bar plot --------------------------------------------------------------------- + +# By specifying barplot as plot type. +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("plot_type" = "barplot"), + test_config = "normal", + debug = debug_flag +) + +# By specifying value_representation as abs_mean. +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("value_representation" = "abs_mean"), + test_config = "normal", + debug = debug_flag +) + +# By specifying value_representation as abs_min. +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("value_representation" = "abs_min"), + test_config = "normal", + debug = debug_flag +) + +# By specifying value_representation as abs_max. +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("value_representation" = "abs_max"), + test_config = "normal", + debug = debug_flag +) + + +# Box plot --------------------------------------------------------------------- +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("plot_type" = "boxplot"), + test_config = "normal", + debug = debug_flag +) + + +# Violin plot ------------------------------------------------------------------ +familiar:::test_plots( + plot_function = familiar::plot_shap_summary, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + plot_args = list("plot_type" = "violinplot"), + test_config = "normal", + debug = debug_flag +) diff --git a/tests/testthat/test-plot_shap_waterfall.R b/tests/testthat/test-plot_shap_waterfall.R new file mode 100644 index 00000000..002079dc --- /dev/null +++ b/tests/testthat/test-plot_shap_waterfall.R @@ -0,0 +1,129 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE + +familiar:::test_plots( + plot_function = familiar::plot_shap_waterfall, + data_element = "shap", + shap_max_iterations = 10L, + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), + debug = debug_flag, + not_available_no_samples = FALSE +) + +# The default limit for the number of important features exceeds the number of +# features in the data, which means that no actual feature selection has +# to take place. To test all path ways, we set the number of important features +# to one here. Because the test routine relies on "none" as variable importance +# method, this triggers ad-hoc feature selection when computing the dataset. +# This will fail if outcome data are absent, mostly absent, or singular. +familiar:::test_plots( + plot_function = familiar::plot_shap_waterfall, + not_available_all_prospective = TRUE, + not_available_mostly_prospective = TRUE, + not_available_single_sample = TRUE, + data_element = "shap", + shap_max_iterations = 10L, + n_important_features = 1L, + debug = debug_flag +) + +# Test only bog-standard data: no edge cases. +familiar:::test_plots( + plot_function = familiar::plot_shap_waterfall, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + test_config = "normal", + debug = debug_flag +) + +# Test with single instance +familiar:::test_plots( + plot_function = familiar::plot_shap_waterfall, + data_element = "shap", + shap_max_iterations = 10L, + evaluation_time = c(1.0, 2.0, 3.5), + test_config = "single instance", + debug = debug_flag +) + +# Test with single instance and limit to the number of features. +familiar:::test_plots( + plot_function = familiar::plot_shap_waterfall, + data_element = "shap", + shap_max_iterations = 10L, + test_config = "single instance", + plot_args = list("limit_n_features" = 2L), + debug = debug_flag +) + +# Test plotting for specific samples. +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { + data <- familiar:::test_create_good_data(outcome_type = outcome_type) + + model <- familiar::train_familiar( + data = data, + learner = switch( + outcome_type, + "binomial" = "glm_logistic", + "multinomial" = "glm", + "continuous" = "glm_gaussian", + "survival" = "cox" + ), + vimp_method = "mim", + parallel = FALSE, + verbose = FALSE + ) + + plot <- familiar::plot_shap_waterfall( + object = model, + data = data@data[1L, ], + shap_phi_0 = switch( + outcome_type, + "binomial" = 0.5, + "multinomial" = c(0.4, 0.3, 0.3), + "continuous" = 0.25, + "survival" = c(0.2, 0.1) + ), + evaluation_times = switch( + outcome_type, + "survival" = c(2.0, 3.0), + NULL + ), + verbose = FALSE, + draw = debug_flag + ) + + testthat::test_that("Waterfall plot was correctly created.", { + testthat::expect_true(ggplot2::is_ggplot(plot[[1L]])) + }) + + # With only 2 features shown. + plot <- familiar::plot_shap_waterfall( + object = model, + data = data@data[1L, ], + shap_phi_0 = switch( + outcome_type, + "binomial" = 0.5, + "multinomial" = c(0.4, 0.3, 0.3), + "continuous" = 0.25, + "survival" = c(0.2, 0.1) + ), + evaluation_times = switch( + outcome_type, + "survival" = c(2.0, 3.0), + NULL + ), + limit_n_features = 2L, + verbose = FALSE, + draw = debug_flag + ) + + testthat::test_that("Waterfall plot was correctly created with a limited number of features shown.", { + testthat::expect_true(ggplot2::is_ggplot(plot[[1L]])) + }) +} diff --git a/tests/testthat/test-plot_univariate_importance.R b/tests/testthat/test-plot_univariate_importance.R index 558a33df..2cb1e94f 100644 --- a/tests/testthat/test-plot_univariate_importance.R +++ b/tests/testthat/test-plot_univariate_importance.R @@ -11,11 +11,11 @@ familiar:::test_plots( plot_function = familiar::plot_univariate_importance, data_element = "univariate_analysis", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list("verbose" = FALSE), debug = debug_flag ) @@ -25,11 +25,11 @@ familiar:::test_plots( plot_function = familiar::plot_univariate_importance, data_element = "univariate_analysis", not_available_all_prospective = TRUE, - not_available_any_prospective = TRUE, + not_available_mostly_prospective = TRUE, not_available_single_sample = TRUE, not_available_all_predictions_fail = FALSE, not_available_some_predictions_fail = FALSE, - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( "verbose" = FALSE, "p_adjustment_method" = "p_value"), @@ -39,22 +39,32 @@ familiar:::test_plots( familiar:::test_plot_ordering( plot_function = familiar::plot_univariate_importance, data_element = "univariate_analysis", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( "verbose" = FALSE, "p_adjustment_method" = "holm", - "facet_by" = c("data_set", "learner", "fs_method")), + "facet_by" = c("data_set", "learner", "vimp_method")), debug = debug_flag ) familiar:::test_plot_ordering( plot_function = familiar::plot_univariate_importance, data_element = "univariate_analysis", - outcome_type_available = c("count", "continuous", "binomial", "multinomial", "survival"), + outcome_type_available = c("continuous", "binomial", "multinomial", "survival"), plot_args = list( "verbose" = FALSE, "p_adjustment_method" = "BY", - "facet_by" = c("data_set", "fs_method"), + "facet_by" = c("data_set", "vimp_method"), "color_by" = "learner"), debug = debug_flag ) + + +# With a limit to the number of features shown. +familiar:::test_plots( + plot_function = familiar::plot_univariate_importance, + data_element = "univariate_analysis", + test_config = "normal", + plot_args = list("limit_n_features" = 2L), + debug = debug_flag +) diff --git a/tests/testthat/test-predict.R b/tests/testthat/test-predict_method.R similarity index 50% rename from tests/testthat/test-predict.R rename to tests/testthat/test-predict_method.R index d598da9f..d3f4ad0c 100644 --- a/tests/testthat/test-predict.R +++ b/tests/testthat/test-predict_method.R @@ -21,56 +21,89 @@ fam_model <- familiar:::test_train( # Default predictions using data object. predictions_1 <- familiar::predict( object = fam_model, - newdata = data) + newdata = data, + .as_prediction_table = TRUE +) # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, - newdata = familiar:::test_create_good_data("survival", to_data_object = FALSE)) + newdata = familiar:::test_create_good_data("survival", to_data_object = FALSE), + .as_prediction_table = TRUE +) # Survival probability. predictions_surv <- familiar::predict( object = fam_model, newdata = data, - type = "survival_probability") + type = "survival_probability", + .as_prediction_table = TRUE +) + +# Survival probability at a different time points. +predictions_surv_early <- familiar::predict( + object = fam_model, + newdata = data, + type = "survival_probability", + time = 1.0, + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, - newdata = familiar:::test_create_good_data("survival", to_data_object = FALSE)) + newdata = familiar:::test_create_good_data("survival", to_data_object = FALSE), + .as_prediction_table = TRUE +) + +# Novelty from list of novelty detectors. +predictions_novelty_3 <- familiar::predict( + object = list(fam_model@novelty_detector), + newdata = data, + .as_prediction_table = TRUE +) # Risk stratification. predictions_risk <- familiar::predict( object = fam_model, newdata = data, - type = "risk_stratification") + type = "risk_stratification", + .as_prediction_table = TRUE +) testthat::test_that("Survival models can predict using external data.", { # Check that predictions 1 and 2 are equal. testthat::expect_equal(predictions_1, predictions_2, ignore_attr = TRUE) testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) + testthat::expect_equal(predictions_novelty_1, predictions_novelty_3, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_surv), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_risk), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_surv@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_risk@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "survival"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "survival"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_surv, "survival"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_risk, "survival"), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_surv)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_risk)) + + # Test on survival probability: that + testthat::expect_gt(predictions_surv@time, predictions_surv_early@time) + testthat::expect_true(all(predictions_surv@data$predicted_outcome < predictions_surv_early@data$predicted_outcome)) }) # Survival data with one instance ---------------------------------------------- @@ -81,37 +114,51 @@ data <- familiar:::test_create_one_sample_data("survival") # Default predictions using data object. predictions_1 <- familiar::predict( object = fam_model, - newdata = data) + newdata = data, + .as_prediction_table = TRUE +) # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, newdata = familiar:::test_create_one_sample_data( - "survival", to_data_object = FALSE)) + "survival", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Survival probability. predictions_surv <- familiar::predict( object = fam_model, newdata = data, - type = "survival_probability") + type = "survival_probability", + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, newdata = familiar:::test_create_one_sample_data( - "survival", to_data_object = FALSE)) + "survival", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Risk stratification. predictions_risk <- familiar::predict( object = fam_model, newdata = data, - type = "risk_stratification") + type = "risk_stratification", + .as_prediction_table = TRUE +) testthat::test_that("Surival models can predict single instances using external data.", { # Check that predictions 1 and 2 are equal. @@ -119,20 +166,20 @@ testthat::test_that("Surival models can predict single instances using external testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_surv), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_risk), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_surv@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_risk@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "survival"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "survival"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_surv, "survival"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_risk, "survival"), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_surv)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_risk)) }) # Binomial data with multiple instances ---------------------------------------- @@ -153,25 +200,35 @@ fam_model <- familiar:::test_train( # Default predictions using data object. predictions_1 <- familiar::predict( object = fam_model, - newdata = data) + newdata = data, + .as_prediction_table = TRUE +) # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, newdata = familiar:::test_create_good_data( - "binomial", to_data_object = FALSE)) + "binomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, newdata = familiar:::test_create_good_data( - "binomial", to_data_object = FALSE)) + "binomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) testthat::test_that("Binomial models can predict using external data.", { # Check that predictions 1 and 2 are equal. @@ -179,16 +236,16 @@ testthat::test_that("Binomial models can predict using external data.", { testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "binomial"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "binomial"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) }) # Binomial data with one instance ---------------------------------------------- @@ -199,25 +256,35 @@ data <- familiar:::test_create_one_sample_data("binomial") # Default predictions using data object. predictions_1 <- familiar::predict( object = fam_model, - newdata = data) + newdata = data, + .as_prediction_table = TRUE +) # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, newdata = familiar:::test_create_one_sample_data( - "binomial", to_data_object = FALSE)) + "binomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, newdata = familiar:::test_create_one_sample_data( - "binomial", to_data_object = FALSE)) + "binomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) testthat::test_that("Binomial models can predict single instances using external data.", { # Check that predictions 1 and 2 are equal. @@ -225,16 +292,16 @@ testthat::test_that("Binomial models can predict single instances using external testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "binomial"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "binomial"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) }) # Multinomial data with multiple instances ------------------------------------- @@ -255,25 +322,35 @@ fam_model <- familiar:::test_train( # Default predictions using data object. predictions_1 <- familiar::predict( object = fam_model, - newdata = data) + newdata = data, + .as_prediction_table = TRUE +) # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, newdata = familiar:::test_create_good_data( - "multinomial", to_data_object = FALSE)) + "multinomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, newdata = familiar:::test_create_good_data( - "multinomial", to_data_object = FALSE)) + "multinomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) testthat::test_that("Multinomial models can predict using external data.", { # Check that predictions 1 and 2 are equal. @@ -281,16 +358,16 @@ testthat::test_that("Multinomial models can predict using external data.", { testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "multinomial"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "multinomial"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) }) # Multinomial data with one instance ------------------------------------------- @@ -300,146 +377,53 @@ data <- familiar:::test_create_one_sample_data("multinomial") # Default predictions using data object. predictions_1 <- familiar::predict( - object = fam_model, - newdata = data) - -# Default predictions using data.table. -predictions_2 <- familiar::predict( - object = fam_model, - newdata = familiar:::test_create_one_sample_data( - "multinomial", to_data_object = FALSE)) - -# Novelty. -predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") - -# Novelty predictions using data.table. -predictions_novelty_2 <- familiar::predict( - object = fam_model@novelty_detector, - newdata = familiar:::test_create_one_sample_data( - "multinomial", to_data_object = FALSE)) - -testthat::test_that("Multinomial models can predict single instances using external data.", { - # Check that predictions 1 and 2 are equal. - testthat::expect_equal(predictions_1, predictions_2, ignore_attr = TRUE) - testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) - - # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) - - # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "multinomial"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "multinomial"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) -}) - -# Count data with multiple instances ------------------------------------------- - -# Create a dataset using the good dataset. -data <- familiar:::test_create_good_data("count") - -# Train a simple linear GLM using the good dataset. -fam_model <- familiar:::test_train( - data = data, - cluster_method = "none", - imputation_method = "simple", - hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), - learner = "lasso_poisson", - create_novelty_detector = TRUE + .as_prediction_table = TRUE ) -# Default predictions using data object. -predictions_1 <- familiar::predict( - object = fam_model, - newdata = data) - -# Default predictions using data.table. -predictions_2 <- familiar::predict( - object = fam_model, - newdata = familiar:::test_create_good_data( - "count", to_data_object = FALSE)) - -# Novelty. -predictions_novelty_1 <- familiar::predict( - object = fam_model, - newdata = data, - type = "novelty") - -# Novelty predictions using data.table. -predictions_novelty_2 <- familiar::predict( - object = fam_model@novelty_detector, - newdata = familiar:::test_create_good_data( - "count", to_data_object = FALSE) -) - -testthat::test_that("Count models can predict using external data.", { - # Check that predictions 1 and 2 are equal. - testthat::expect_equal(predictions_1, predictions_2, ignore_attr = TRUE) - testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) - - # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) - - # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "count"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "count"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) -}) - -# Count data with one instance ------------------------------------------------- - -# Create one-sample dataset. -data <- familiar:::test_create_one_sample_data("count") - -# Default predictions using data object. -predictions_1 <- familiar::predict( - object = fam_model, - newdata = data) - # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, newdata = familiar:::test_create_one_sample_data( - "count", to_data_object = FALSE)) + "multinomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, newdata = familiar:::test_create_one_sample_data( - "count", to_data_object = FALSE)) + "multinomial", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) -testthat::test_that("Count models can predict single instances using external data.", { +testthat::test_that("Multinomial models can predict single instances using external data.", { # Check that predictions 1 and 2 are equal. testthat::expect_equal(predictions_1, predictions_2, ignore_attr = TRUE) testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "count"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "count"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) }) # Continuous data with multiple instances -------------------------------------- @@ -460,42 +444,53 @@ fam_model <- familiar:::test_train( # Default predictions using data object. predictions_1 <- familiar::predict( object = fam_model, - newdata = data) + newdata = data, + .as_prediction_table = TRUE +) # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, newdata = familiar:::test_create_good_data( - "continuous", to_data_object = FALSE)) + "continuous", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, newdata = familiar:::test_create_good_data( - "continuous", to_data_object = FALSE)) + "continuous", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) testthat::test_that("Continuous models can predict using external data.", { # Check that predictions 1 and 2 are equal. - testthat::expect_equal(predictions_1, predictions_2, ignore_attr = TRUE) + # testthat::expect_equal(predictions_1, predictions_2, ignore_attr = TRUE) + testthat::expect_equal(predictions_1@data, predictions_2@data, ignore_attr = TRUE) testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "continuous"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "continuous"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) }) # Continuous data with one instance -------------------------------------------- @@ -506,40 +501,49 @@ data <- familiar:::test_create_one_sample_data("continuous") # Default predictions using data object. predictions_1 <- familiar::predict( object = fam_model, - newdata = data) + newdata = data, + .as_prediction_table = TRUE +) # Default predictions using data.table. predictions_2 <- familiar::predict( object = fam_model, newdata = familiar:::test_create_one_sample_data( - "continuous", to_data_object = FALSE)) + "continuous", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) # Novelty. predictions_novelty_1 <- familiar::predict( object = fam_model, newdata = data, - type = "novelty") + type = "novelty", + .as_prediction_table = TRUE +) # Novelty predictions using data.table. predictions_novelty_2 <- familiar::predict( object = fam_model@novelty_detector, newdata = familiar:::test_create_one_sample_data( - "continuous", to_data_object = FALSE)) + "continuous", to_data_object = FALSE + ), + .as_prediction_table = TRUE +) testthat::test_that("Continuous models can predict single instances using external data.", { # Check that predictions 1 and 2 are equal. - testthat::expect_equal(predictions_1, predictions_2, ignore_attr = TRUE) testthat::expect_equal(predictions_novelty_1, predictions_novelty_2, ignore_attr = TRUE) # Check that the number of rows is equal to the input data. - testthat::expect_equal(nrow(predictions_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_2), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_1), nrow(data@data)) - testthat::expect_equal(nrow(predictions_novelty_2), nrow(data@data)) + testthat::expect_equal(nrow(predictions_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_2@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_1@data), nrow(data@data)) + testthat::expect_equal(nrow(predictions_novelty_2@data), nrow(data@data)) # Check that all predictions are valid. - testthat::expect_equal(familiar:::any_predictions_valid(predictions_1, "continuous"), TRUE) - testthat::expect_equal(familiar:::any_predictions_valid(predictions_2, "continuous"), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_1$novelty)), TRUE) - testthat::expect_equal(all(is.finite(predictions_novelty_2$novelty)), TRUE) + testthat::expect_true(familiar:::any_predictions_valid(predictions_1)) + testthat::expect_true(familiar:::any_predictions_valid(predictions_2)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_1)) + testthat::expect_true(familiar:::all_predictions_valid(predictions_novelty_2)) }) diff --git a/tests/testthat/test-predict_survival_probability.R b/tests/testthat/test-predict_survival_probability.R new file mode 100644 index 00000000..f876e66f --- /dev/null +++ b/tests/testthat/test-predict_survival_probability.R @@ -0,0 +1,186 @@ +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +results_fun <- function(t, x, model) { + predictions <- familiar::predict( + object = model, + newdata = x, + type = "survival_probability", + time = t + ) + + return(predictions$predicted_outcome) +} + +# Create test data set --------------------------------------------------------- + +# Create random stream object so that the same numbers are produced every +# time. +r <- familiar:::.start_random_number_stream(seed = 1963L) +n_series_instances <- 1000L + +# Draw random numbers for 1 feature. +feature_1 <- familiar:::fam_rnorm(n_series_instances, rstream_object = r) + +# Simulate event times using exponential function and lambda = 0.5 +outcome_time <- - log(familiar:::fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r)) / + (0.5 * exp(feature_1)) + +# Simulate censoring times using exponential function and lambda = 0.1 +censor_time <- - log(familiar:::fam_runif(n = n_series_instances, min = 0.0, max = 1.0, rstream_object = r)) / 0.1 +outcome_event <- rep_len(1L, length.out = n_series_instances) +outcome_event[censor_time < outcome_time] <- 0L +outcome_time[outcome_event == 0L] <- censor_time[outcome_event == 0L] + +# Create basic table. +data <- data.table::data.table( + "batch_id" = "basic", + "sample_id" = paste0("sample_", seq_len(n_series_instances)), + "series_id" = 1L, + "feature_1" = feature_1, + "outcome_time" = outcome_time, + "outcome_event" = outcome_event +) + +# Turn into a data object. +data <- familiar::as_data_object( + data = data, + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), + outcome_type = "survival" +) + +# Single test-dataset +test_data <- data.table::data.table( + "batch_id" = "basic", + "sample_id" = 1001L, + "series_id" = 1L, + "feature_1" = 0.0, + "outcome_time" = 1.386, + "outcome_event" = 1L +) + +test_data <- familiar::as_data_object( + data = test_data, + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + outcome_column = c("outcome_time", "outcome_event"), + outcome_type = "survival" +) + +# Train models ----------------------------------------------------------------- + +# Cox PH +cox_model <- familiar:::test_train( + data = data, + cluster_method = "none", + normalisation_method = "none", + transformation_method = "none", + imputation_method = "simple", + hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), + learner = "cox" +) + +# Random forest model (ranger) +rf_model <- familiar:::test_train( + data = data, + cluster_method = "none", + normalisation_method = "none", + transformation_method = "none", + imputation_method = "simple", + hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), + learner = "random_forest_ranger_default" +) + +# Survival regression model +surv_reg_model <- familiar:::test_train( + data = data, + cluster_method = "none", + normalisation_method = "none", + transformation_method = "none", + imputation_method = "simple", + hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), + learner = "survival_regr_weibull" +) + +# Evaluate predictions --------------------------------------------------------- + +time_points <- (seq_len(51L) - 1L) / 10.0 + +# Get Kaplan-Meier data. +km_fit <- survival::survfit( + Surv(outcome_time, outcome_event) ~ 1, + data = data@data +) + +km_fit_prob <- stats::approx( + x = km_fit$time, + y = km_fit$surv, + xout = time_points, + method = "linear", + rule = 2L, + yleft = 1.0 +)$y + + +# Cox PH +cox_predictions <- sapply( + time_points, + results_fun, + x = test_data, + model = cox_model +) + +testthat::test_that( + "Cox PH predictions are plausible.", + { + # For the current data, predictions should be very close to the KM-curve, + # since feature = 0 means a relative risk of approximately 0. + testthat::expect_true(all(abs(km_fit_prob - cox_predictions) < 0.01)) + } +) + + +# Weibull model +surv_reg_predictions <- sapply( + time_points, + results_fun, + x = test_data, + model = surv_reg_model +) + +testthat::test_that( + "Weibull regression predictions are plausible.", + { + # For the current data, predictions should be very close to the KM-curve, + # since feature = 0 means a relative risk of approximately 0. However, + # the Weibull model does not rely on the observed survival curve, and thus + # will deviate from the Kaplan-Meier curve somewhat. + testthat::expect_true(all(abs(km_fit_prob - surv_reg_predictions) < 0.10)) + } +) + + +# RF model (ranger) +rf_predictions <- sapply( + time_points, + results_fun, + x = test_data, + model = rf_model +) + +testthat::test_that( + "Random forest (ranger)-based predictions are plausible.", + { + # For the current data, predictions should be very close to the KM-curve, + # since feature = 0 means a relative risk of approximately 0. However, + # the RF model does not rely on the observed survival curve, and thus + # will deviate from the Kaplan-Meier curve somewhat. + testthat::expect_true(all(abs(km_fit_prob - rf_predictions) < 0.15)) + } +) diff --git a/tests/testthat/test-sample_weights.R b/tests/testthat/test-sample_weights.R index ef0f5578..135ca725 100644 --- a/tests/testthat/test-sample_weights.R +++ b/tests/testthat/test-sample_weights.R @@ -1,5 +1,3 @@ -if (!familiar:::test_data_package_installed("binomial")) testthat::skip() - # Create test dataset. data <- familiar:::test_create_good_data(outcome_type = "binomial") @@ -99,7 +97,7 @@ testthat::skip("Skip hyperparameter optimisation, unless manual.") # Check that variable importance functions correctly. model <- familiar::train_familiar( data = data, - fs_method = "mrmr", + vimp_method = "mrmr", learner = "glm_logistic", outcome_type = "binomial", outcome_column = "cell_malignancy", @@ -118,7 +116,7 @@ testthat::test_that("Default method is inverse_number_of_samples.", { # Check that effective_number_of_samples functions. model <- familiar::train_familiar( data = data, - fs_method = "mrmr", + vimp_method = "mrmr", learner = "glm_logistic", hyperparameter = list("sample_weighting" = "effective_number_of_samples"), outcome_type = "binomial", diff --git a/tests/testthat/test-stratification.R b/tests/testthat/test-stratification.R index 1033a306..1efdab6a 100644 --- a/tests/testthat/test-stratification.R +++ b/tests/testthat/test-stratification.R @@ -3,14 +3,13 @@ testthat::skip_on_cran() # Find available stratification methods. stratification_methods <- familiar:::.get_available_stratification_methods() -if (!familiar:::test_data_package_installed("survival")) testthat::skip() if (!rlang::is_installed("power.transform")) testthat::skip() # Test for good dataset. for (stratification_method in stratification_methods) { # Create a dataset using the good dataset. data <- familiar:::test_create_good_data("survival") - + # Train a simple linear GLM using the good dataset. fam_model <- familiar:::test_train( data = data, @@ -19,17 +18,19 @@ for (stratification_method in stratification_methods) { hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "cox", stratification_method = stratification_method, - create_novelty_detector = FALSE) - + create_novelty_detector = FALSE + ) + # Risk stratification. predictions_risk <- familiar::predict( object = fam_model, newdata = data, - type = "risk_stratification") - + type = "risk_stratification" + ) + testthat::test_that("Risk groups are formed.", { testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method) - testthat::expect_true(all(is.finite(predictions_risk$risk_group))) + testthat::expect_true(!any(is.na(predictions_risk$group))) }) } @@ -37,7 +38,7 @@ for (stratification_method in stratification_methods) { for (stratification_method in stratification_methods) { # Create a dataset using the single-feature dataset. data <- familiar:::test_create_single_feature_data("survival") - + # Train a simple linear GLM using the good dataset. fam_model <- familiar:::test_train( data = data, @@ -46,17 +47,19 @@ for (stratification_method in stratification_methods) { hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "cox", stratification_method = stratification_method, - create_novelty_detector = FALSE) - + create_novelty_detector = FALSE + ) + # Risk stratification. predictions_risk <- familiar::predict( object = fam_model, newdata = data, - type = "risk_stratification") - + type = "risk_stratification" + ) + testthat::test_that("Risk groups are formed.", { testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method) - testthat::expect_true(all(is.finite(predictions_risk$risk_group))) + testthat::expect_true(!any(is.na(predictions_risk$group))) }) } @@ -64,7 +67,7 @@ for (stratification_method in stratification_methods) { for (stratification_method in stratification_methods) { # Create a dataset with a feature that only has two values. data <- familiar:::test_create_single_feature_two_values_data("survival") - + # Train a simple linear GLM using the feature set that only has two values. fam_model <- familiar:::test_train( data = data, @@ -73,17 +76,19 @@ for (stratification_method in stratification_methods) { hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "cox", stratification_method = stratification_method, - create_novelty_detector = FALSE) - + create_novelty_detector = FALSE + ) + # Risk stratification. predictions_risk <- familiar::predict( object = fam_model, newdata = data, - type = "risk_stratification") - + type = "risk_stratification" + ) + testthat::test_that("Risk groups are formed.", { testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method) - testthat::expect_true(all(is.finite(predictions_risk$risk_group))) + testthat::expect_true(!any(is.na(predictions_risk$group))) }) } @@ -100,7 +105,8 @@ fam_model <- familiar:::test_train( hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "cox", stratification_method = stratification_methods, - create_novelty_detector = FALSE) + create_novelty_detector = FALSE +) for (stratification_method in stratification_methods) { # Risk stratification. @@ -108,10 +114,11 @@ for (stratification_method in stratification_methods) { object = fam_model, newdata = data, type = "risk_stratification", - stratification_method = stratification_method) - + stratification_method = stratification_method + ) + testthat::test_that("Risk groups are formed.", { - testthat::expect_true(all(is.finite(predictions_risk$risk_group))) + testthat::expect_true(!any(is.na(predictions_risk$group))) }) } @@ -119,7 +126,7 @@ for (stratification_method in stratification_methods) { for (stratification_method in stratification_methods) { # Create a dataset using the good dataset. data <- familiar:::test_create_good_data("survival") - + # Train a simple linear GLM using the good dataset. fam_model <- familiar:::test_train( data = data, @@ -128,17 +135,19 @@ for (stratification_method in stratification_methods) { hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "lasso_test_all_fail", stratification_method = stratification_method, - create_novelty_detector = FALSE) - + create_novelty_detector = FALSE + ) + # Risk stratification. predictions_risk <- familiar::predict( object = fam_model, newdata = data, - type = "risk_stratification") - + type = "risk_stratification" + ) + testthat::test_that("Risk groups are formed.", { testthat::expect_equal(fam_model@km_info$stratification_method, NULL) - testthat::expect_false(any(is.finite(predictions_risk$risk_group))) + testthat::expect_true(all(is.na(predictions_risk$group))) }) } @@ -146,7 +155,7 @@ for (stratification_method in stratification_methods) { for (stratification_method in stratification_methods) { # Create a dataset using the good dataset. data <- familiar:::test_create_good_data("survival") - + # Train a simple linear GLM using the good dataset. fam_model <- familiar:::test_train( data = data, @@ -155,17 +164,19 @@ for (stratification_method in stratification_methods) { hyperparameter_list = list("sign_size" = familiar:::get_n_features(data)), learner = "lasso_test_some_fail", stratification_method = stratification_method, - create_novelty_detector = FALSE) - + create_novelty_detector = FALSE + ) + # Risk stratification. predictions_risk <- familiar::predict( object = fam_model, newdata = data, - type = "risk_stratification") - + type = "risk_stratification" + ) + testthat::test_that("Risk groups are formed.", { testthat::expect_equal(fam_model@km_info$stratification_method, stratification_method) - testthat::expect_false(all(is.finite(predictions_risk$risk_group))) - testthat::expect_true(any(is.finite(predictions_risk$risk_group))) + testthat::expect_false(all(is.na(predictions_risk$group))) + testthat::expect_true(any(is.na(predictions_risk$group))) }) } diff --git a/tests/testthat/test-subsampling_functions.R b/tests/testthat/test-subsampling_functions.R index db81b738..dcb1b692 100644 --- a/tests/testthat/test-subsampling_functions.R +++ b/tests/testthat/test-subsampling_functions.R @@ -6,7 +6,7 @@ testthat::skip_on_ci() r <- familiar:::.start_random_number_stream(seed = 1863) # Subsampling ------------------------------------------------------------------ -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { data <- familiar:::test_create_synthetic_series_data( outcome_type = outcome_type, rare_outcome = TRUE, @@ -166,7 +166,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv } -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { # Create synthetic dataset with one outcome. if (outcome_type %in% c("binomial", "multinomial", "survival")) { @@ -609,7 +609,7 @@ for (outcome_type in c("binomial", "multinomial")) { } # Cross-validation ------------------------------------------------------------- -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { data <- familiar:::test_create_synthetic_series_data( outcome_type = outcome_type, rare_outcome = TRUE, @@ -776,7 +776,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv } } -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { # Create synthetic dataset with one outcome. if (outcome_type %in% c("binomial", "multinomial", "survival")) { @@ -827,7 +827,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv } # Repeated cross-validation ---------------------------------------------------- -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { data <- familiar:::test_create_synthetic_series_data( outcome_type = outcome_type, rare_outcome = TRUE, @@ -994,7 +994,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv } } -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { # Create synthetic dataset with one outcome. if (outcome_type %in% c("binomial", "multinomial", "survival")) { @@ -1049,7 +1049,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv # Leave-one-out cross-validation ----------------------------------------------- -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { data <- familiar:::test_create_synthetic_series_data( outcome_type = outcome_type, rare_outcome = TRUE, @@ -1180,7 +1180,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv }) } -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { testthat::test_that(paste0( "Repeated cross-validation for ", outcome_type, " with odd data functions correctly." @@ -1215,7 +1215,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv } # Bootstraps ------------------------------------------------------------------- -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { data <- familiar:::test_create_synthetic_series_data( outcome_type = outcome_type, rare_outcome = TRUE, @@ -1371,7 +1371,7 @@ for (outcome_type in c("binomial", "multinomial", "continuous", "count", "surviv } } -for (outcome_type in c("binomial", "multinomial", "continuous", "count", "survival")) { +for (outcome_type in c("binomial", "multinomial", "continuous", "survival")) { # Create synthetic dataset with one outcome. if (outcome_type %in% c("binomial", "multinomial", "survival")) { diff --git a/tests/testthat/test-task_based_workflow.R b/tests/testthat/test-task_based_workflow.R new file mode 100644 index 00000000..ea910f89 --- /dev/null +++ b/tests/testthat/test-task_based_workflow.R @@ -0,0 +1,320 @@ +# Don't perform any further tests on CRAN due to running time. +testthat::skip_on_cran() +testthat::skip_on_ci() + +verbose <- FALSE + +# Create data.table. +data <- familiar:::test_create_good_data( + outcome_type = "binomial", + to_data_object = FALSE +) + +# Create data assignment object. +experiment_data_assignment <- familiar::precompute_data_assignment( + data = data, + experimental_design = "bs(fs+mb,3)", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +# Create feature info object. +experiment_feature_info <- familiar::precompute_feature_info( + data = data, + experiment_data = experiment_data_assignment, + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("feature information is present", { + testthat::expect_false(familiar:::is_empty(experiment_feature_info@feature_info)) +}) + + +# Create variable importance +experiment_vimp <- familiar::precompute_vimp( + data = data, + experiment_data = experiment_feature_info, + vimp_method = "mim", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("variable importance data is present", { + testthat::expect_false(familiar:::is_empty(experiment_vimp@feature_info)) + testthat::expect_false(familiar:::is_empty(experiment_vimp@vimp_table_list)) +}) + + +# Train model +model <- familiar::train_familiar( + data = data, + experiment_data = experiment_vimp, + vimp_method = "mim", + learner = "glm_logistic", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("all models are present", { + testthat::expect_true(all(sapply(model, familiar:::model_is_trained))) + testthat::expect_false(any(sapply(model, function(x) (is.null(x@vimp_table))))) +}) + +# Check without explicit variable importance computation ----------------------- +# Create variable importance +experiment_vimp <- familiar::precompute_vimp( + data = data, + experimental_design = "bs(mb,3)", + vimp_method = "mim", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("variable importance data is absent", { + testthat::expect_null(experiment_vimp@feature_info) + testthat::expect_null(experiment_vimp@vimp_table_list) +}) + +# Train model +model <- familiar::train_familiar( + data = data, + experiment_data = experiment_vimp, + vimp_method = "mim", + learner = "glm_logistic", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("all models are present", { + testthat::expect_true(all(sapply(model, familiar:::model_is_trained))) + testthat::expect_false(any(sapply(model, function(x) (is.null(x@vimp_table))))) +}) + + +# Check using variable importance from feature selection ----------------------- +experiment_vimp <- familiar::precompute_vimp( + data = data, + experimental_design = "bs(fs,3)+bs(mb,3)", + vimp_method = "mim", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("variable importance data is present", { + testthat::expect_false(familiar:::is_empty(experiment_vimp@feature_info)) + testthat::expect_false(familiar:::is_empty(experiment_vimp@vimp_table_list)) +}) + +# Train model +model <- familiar::train_familiar( + data = data, + experiment_data = experiment_vimp, + optimisation_determine_vimp = FALSE, + vimp_method = "mim", + learner = "glm_logistic", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("all models are present", { + testthat::expect_true(all(sapply(model, familiar:::model_is_trained))) + testthat::expect_false(any(sapply(model, function(x) (is.null(x@vimp_table))))) +}) + + +# Including evaluation --------------------------------------------------------- + +# Defining an experiment directory ensures that models and other data are +# stored for inspection. +data <- familiar:::test_create_small_good_data("binomial") +exp_dir <- tempdir() + +familiar::summon_familiar( + data = data, + experiment_dir = exp_dir, + experimental_design = "bs(fs,3)+bs(mb, 3)", + evaluation_elements = "auc_data", + vimp_method = "mim", + learner = "glm_logistic", + evaluate_top_level_only = FALSE, + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("all output is present", { + # Models + model_files <- list.files( + file.path(exp_dir, "trained_models"), + pattern = "model.RDS" + ) + testthat::expect_length(model_files, 3L) + + # Evaluation data + data_files <- list.files( + file.path(exp_dir, "familiar_data"), + pattern = "data.RDS" + ) + testthat::expect_length(data_files, 8L) + + # Collections + collection_files <- list.files( + file.path(exp_dir, "familiar_collections"), + pattern = "collection.RDS" + ) + testthat::expect_length(collection_files, 4L) + + # Collection export + export_dirs <- list.dirs( + file.path(exp_dir, "results"), + recursive = FALSE + ) + testthat::expect_length(export_dirs, 4L) +}) + + + +# Train with special feature selection methods --------------------------------- + +data <- familiar:::test_create_good_data( + outcome_type = "binomial", + to_data_object = FALSE +) + +# Train baseline model +model <- familiar::train_familiar( + data = data, + experimental_design = "mb", + vimp_method = "mim", + learner = "glm_logistic", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) + +testthat::test_that("model is correctly formed", { + testthat::expect_true(familiar:::model_is_trained(model)) + testthat::expect_false(any(sapply(model@vimp_table, is.null))) +}) + +# Train model using none. +model <- familiar::train_familiar( + data = data, + experimental_design = "mb", + vimp_method = "none", + learner = "glm_logistic", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) +testthat::test_that("model is correctly formed", { + testthat::expect_true(familiar:::model_is_trained(model)) + testthat::expect_true(is.null(model@vimp_table)) +}) + +# Train model using random. +model <- familiar::train_familiar( + data = data, + experimental_design = "mb", + vimp_method = "random", + learner = "glm_logistic", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) +testthat::test_that("model is correctly formed", { + testthat::expect_true(familiar:::model_is_trained(model)) + testthat::expect_true(is.null(model@vimp_table)) +}) + +# Train model using random. +model <- familiar::train_familiar( + data = data, + signature = c("feature_1", "feature_2a"), + experimental_design = "mb", + vimp_method = "signature_only", + learner = "glm_logistic", + outcome_type = "binomial", + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = verbose, + parallel = FALSE +) +testthat::test_that("model is correctly formed", { + testthat::expect_true(familiar:::model_is_trained(model)) + testthat::expect_true(is.null(model@vimp_table)) + testthat::expect_equal(model@hyperparameters$sign_size, 2L) + testthat::expect_setequal(c("feature_1", "feature_2a"), model@model_features) +}) diff --git a/tests/testthat/test-train_familiar.R b/tests/testthat/test-train_familiar.R index 3efef864..e8a51199 100644 --- a/tests/testthat/test-train_familiar.R +++ b/tests/testthat/test-train_familiar.R @@ -5,78 +5,62 @@ testthat::skip_on_ci() # Create data.table. data <- familiar:::test_create_good_data( outcome_type = "binomial", - to_data_object = FALSE) + to_data_object = FALSE +) # Check that train_familiar functions correctly. model <- familiar::train_familiar( data = data, - fs_method = "mrmr", + vimp_method = "mrmr", learner = "glm_logistic", outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Logistic model can be trained using train_familiar", { testthat::expect_s4_class(model, "familiarGLM") - testthat::expect_equal(familiar:::model_is_trained(model), TRUE) + testthat::expect_true(familiar:::model_is_trained(model)) testthat::expect_s3_class(summary(model), "summary.glm") - testthat::expect_equal(is.null(familiar::coef(model)), FALSE) + testthat::expect_false(is.null(familiar::coef(model))) - # Assert that between 1 and 9 features are present, aside from the intercept. + # Assert that between 1 and 6 features are present, aside from the intercept. testthat::expect_gte(length(model@model_features), 1L) - testthat::expect_lte(length(model@model_features), 9L) - testthat::expect_equal(length(model@model_features) <= model@hyperparameters$sign_size, TRUE) + testthat::expect_lte(length(model@model_features), 6L) + testthat::expect_lte(length(model@model_features), model@hyperparameters$sign_size) }) # multinomial ------------------------------------------------------------------ # Create data.table. data <- familiar:::test_create_good_data( outcome_type = "multinomial", - to_data_object = FALSE) + to_data_object = FALSE +) # Check that train_familiar functions correctly. model <- familiar::train_familiar( data = data, - fs_method = "none", + vimp_method = "none", learner = "glm_multinomial", outcome_type = "multinomial", - outcome_column = "Species", + outcome_column = "outcome", + batch_id_column = "batch_id", sample_id_column = "sample_id", - class_levels = c("setosa", "versicolor", "virginica"), - verbose = FALSE) + series_id_column = "series_id", + class_levels = c("red", "green", "blue"), + verbose = FALSE +) testthat::test_that("Logistic model can be trained using train_familiar", { testthat::expect_s4_class(model, "familiarGLM") - testthat::expect_equal(familiar:::model_is_trained(model), TRUE) + testthat::expect_true(familiar:::model_is_trained(model)) testthat::expect_s3_class(summary(model), "summary.multinom") - testthat::expect_equal(is.null(familiar::coef(model)), FALSE) - testthat::expect_equal(is.null(familiar::vcov(model)), FALSE) -}) - -# count ------------------------------------------------------------------------ - -# Create data.table. -data <- familiar:::test_create_good_data( - outcome_type = "count", - to_data_object = FALSE) - -# Check that train_familiar functions correctly. -model <- familiar::train_familiar( - data = data, - fs_method = "mrmr", - learner = "glm_poisson", - outcome_type = "count", - outcome_column = "median_house_value", - sample_id_column = "sample_id", - verbose = FALSE) - -testthat::test_that("Poisson model can be trained using train_familiar", { - testthat::expect_s4_class(model, "familiarGLM") - testthat::expect_equal(familiar:::model_is_trained(model), TRUE) - testthat::expect_s3_class(summary(model), "summary.glm") - testthat::expect_equal(is.null(familiar::coef(model)), FALSE) + testthat::expect_false(is.null(familiar::coef(model))) + testthat::expect_false(is.null(familiar::vcov(model))) }) # continuous ------------------------------------------------------------------- @@ -89,18 +73,21 @@ data <- familiar:::test_create_good_data( # Check that train_familiar functions correctly. model <- familiar::train_familiar( data = data, - fs_method = "mrmr", + vimp_method = "mrmr", learner = "glm_gaussian", outcome_type = "continuous", - outcome_column = "testscr", + outcome_column = "outcome", + batch_id_column = "batch_id", sample_id_column = "sample_id", - verbose = FALSE) + series_id_column = "series_id", + verbose = FALSE +) testthat::test_that("Gaussian model can be trained using train_familiar", { testthat::expect_s4_class(model, "familiarGLM") - testthat::expect_equal(familiar:::model_is_trained(model), TRUE) + testthat::expect_true(familiar:::model_is_trained(model)) testthat::expect_s3_class(summary(model), "summary.glm") - testthat::expect_equal(is.null(familiar::coef(model)), FALSE) + testthat::expect_false(is.null(familiar::coef(model))) }) # survival --------------------------------------------------------------------- @@ -113,19 +100,22 @@ data <- familiar:::test_create_good_data( # Check that train_familiar functions correctly. model <- familiar::train_familiar( data = data, - fs_method = "none", + vimp_method = "none", learner = "cox", outcome_type = "survival", - outcome_column = c("time", "status"), - sample_id_column = "id", - verbose = FALSE) + outcome_column = c("outcome_time", "outcome_event"), + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + verbose = FALSE +) testthat::test_that("Cox proportional hazards model can be trained using train_familiar", { testthat::expect_s4_class(model, "familiarCoxPH") - testthat::expect_equal(familiar:::model_is_trained(model), TRUE) + testthat::expect_true(familiar:::model_is_trained(model)) testthat::expect_s3_class(summary(model), "summary.coxph") - testthat::expect_equal(is.null(familiar::coef(model)), FALSE) - testthat::expect_equal(is.null(familiar::vcov(model)), FALSE) + testthat::expect_false(is.null(familiar::coef(model))) + testthat::expect_false(is.null(familiar::vcov(model))) }) # Use experiment data ---------------------------------------------------------- @@ -138,23 +128,28 @@ data <- familiar:::test_create_good_data( experiment_data <- familiar::precompute_data_assignment( data = data, experimental_design = "bt(fs+mb,5)", - outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) # Check that train_familiar functions correctly. model <- familiar::train_familiar( data = data, experiment_data = experiment_data, - fs_method = "mrmr", + vimp_method = "mrmr", learner = "glm_logistic", outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Logistic model can be trained using train_familiar", { # Assert that 5 models are trained. @@ -175,17 +170,20 @@ data <- familiar:::test_create_good_data( model <- familiar::train_familiar( data = data, cluster_method = "none", - fs_method = "none", + vimp_method = "none", learner = "glm_logistic", outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Assert that all features are used for \"none\" variable importance method.", { # Assert that all features are included in the model. - testthat::expect_equal(length(model@model_features), 9L) + testthat::expect_equal(length(model@model_features), 6L) }) # Check "signature_only" variable importance method ---------------------------- @@ -198,21 +196,25 @@ data <- familiar:::test_create_good_data( # Check that train_familiar functions correctly. model <- familiar::train_familiar( data = data, - signature = c("cell_size_uniformity", "clump_thickness"), - fs_method = "signature_only", + signature = c("feature_1", "feature_2a"), + vimp_method = "signature_only", learner = "glm_logistic", outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Assert that all features are used for \"signature_only\" variable importance method.", { # Assert that only signature features are included in the model. testthat::expect_equal(length(model@model_features), 2L) testthat::expect_setequal( - c("cell_size_uniformity", "clump_thickness"), - model@model_features) + c("feature_1", "feature_2a"), + model@model_features + ) }) # Check interaction between signature and other features ----------------------- @@ -220,24 +222,28 @@ testthat::test_that("Assert that all features are used for \"signature_only\" va # Create data.table. data <- familiar:::test_create_good_data( outcome_type = "binomial", - to_data_object = FALSE) + to_data_object = FALSE +) # Check that train_familiar functions correctly. model <- familiar::train_familiar( data = data, - signature = c("marginal_adhesion", "bland_chromatin"), - fs_method = "mrmr", + signature = c("feature_1", "feature_2a"), + vimp_method = "mrmr", learner = "glm_logistic", outcome_type = "binomial", - outcome_column = "cell_malignancy", - sample_id_column = "id", - class_levels = c("benign", "malignant"), - verbose = FALSE) + outcome_column = "outcome", + batch_id_column = "batch_id", + sample_id_column = "sample_id", + series_id_column = "series_id", + class_levels = c("red", "green"), + verbose = FALSE +) testthat::test_that("Assert that signature features are used in the model.", { # Assert that only signature features are included in the model. testthat::expect_gte(length(model@model_features), 2L) - testthat::expect_lte(length(model@model_features), 9L) - testthat::expect_equal(all(c("marginal_adhesion", "bland_chromatin") %in% model@model_features), TRUE) - testthat::expect_equal(length(model@model_features) <= model@hyperparameters$sign_size, TRUE) + testthat::expect_lte(length(model@model_features), 6L) + testthat::expect_true(all(c("feature_1", "feature_2a") %in% model@model_features)) + testthat::expect_lte(length(model@model_features), model@hyperparameters$sign_size) }) diff --git a/tests/testthat/test-transformation.R b/tests/testthat/test-transformation.R index a8448f21..512e2e98 100644 --- a/tests/testthat/test-transformation.R +++ b/tests/testthat/test-transformation.R @@ -19,12 +19,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_transformation_parameter_skeleton( @@ -135,12 +130,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_transformation_parameter_skeleton( @@ -200,12 +190,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_transformation_parameter_skeleton( @@ -272,12 +257,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_transformation_parameter_skeleton( @@ -338,12 +318,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_transformation_parameter_skeleton( @@ -410,12 +385,7 @@ for (n_numeric_features in c(4, 3, 2, 1, 0)) { data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons. feature_info_list <- familiar:::create_transformation_parameter_skeleton( @@ -471,12 +441,7 @@ testthat::test_that( data_copy <- data.table::copy(data) # Create a list of featureInfo objects. - feature_info_list <- familiar:::.get_feature_info_data( - data = data_copy@data, - file_paths = NULL, - project_id = character(), - outcome_type = outcome_type - )[[1]] + feature_info_list <- test_create_generic_info(data = data_copy) # Add skeletons for features 1 and 2. feature_info_list <- familiar:::create_transformation_parameter_skeleton( diff --git a/tests/testthat/test-update_object.R b/tests/testthat/test-update_object.R index dd71173b..8df9a4b5 100644 --- a/tests/testthat/test-update_object.R +++ b/tests/testthat/test-update_object.R @@ -23,7 +23,7 @@ test_generate_experiment_parameters <- coro::generator(function(outcome_type) { coro::yield(list( "experimental_design" = "bs(fs+mb,3)", "outcome_type" = current_outcome_type, - "fs_method" = c("mim", "concordance"), + "vimp_method" = c("mim", "concordance"), "learner" = learner)) } }) diff --git a/tests/testthat/test-vignette_introduction.R b/tests/testthat/test-vignette_introduction.R new file mode 100644 index 00000000..b149b62b --- /dev/null +++ b/tests/testthat/test-vignette_introduction.R @@ -0,0 +1,98 @@ +# Don't perform any further tests on CRAN due to running time. +testthat::skip_on_cran() +testthat::skip_on_ci() + +debug_flag <- FALSE +exp_dir <- file.path(tempdir(), "familiar_intro_test") + +testthat::test_that( + "Basic example works", + { + if (!debug_flag) on.exit(unlink(exp_dir, recursive = TRUE), add = TRUE) + + testthat::expect_no_error( + suppressWarnings( + familiar::summon_familiar( + data = datasets::iris, + experiment_dir = exp_dir, + outcome_type = "multinomial", + outcome_column = "Species", + experimental_design = "fs+mb", + vimp_method = "mrmr", + learner = "glm", + parallel = FALSE, + verbose = debug_flag + ) + ) + ) + } +) + +unlink(exp_dir, recursive = TRUE) + +testthat::test_that( + "Basic example with formula interface", + { + if (!debug_flag) on.exit(unlink(exp_dir, recursive = TRUE), add = TRUE) + + testthat::expect_no_error( + suppressWarnings( + familiar::summon_familiar( + Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width, + data = datasets::iris, + experiment_dir = exp_dir, + outcome_type = "multinomial", + experimental_design = "fs+mb", + vimp_method = "mrmr", + learner = "glm", + parallel = FALSE, + verbose = debug_flag + ) + ) + ) + } +) + +unlink(exp_dir, recursive = TRUE) + + + +testthat::test_that( + "Example with warm start", + { + if (!debug_flag) on.exit(unlink(exp_dir, recursive = TRUE), add = TRUE) + + testthat::expect_no_error( + suppressWarnings( + experiment_data <- familiar::precompute_feature_info( + data = iris, + experiment_dir = exp_dir, + outcome_type = "multinomial", + outcome_column = "Species", + experimental_design = "bs(fs+mb,5)", + parallel = FALSE, + verbose = debug_flag + ) + ) + ) + unlink(exp_dir, recursive = TRUE) + + testthat::expect_no_error( + suppressWarnings( + familiar::summon_familiar( + data = iris, + experiment_data = experiment_data, + experiment_dir = exp_dir, + outcome_type = "multinomial", + outcome_column = "Species", + vimp_method = "mrmr", + learner = "glm", + parallel = FALSE, + verbose = debug_flag + ) + ) + ) + } +) + +unlink(exp_dir, recursive = TRUE) diff --git a/tests/testthat/test-vimp_concordance_S4.R b/tests/testthat/test-vimp_concordance_S4.R index 4864b976..8a1acf02 100644 --- a/tests/testthat/test-vimp_concordance_S4.R +++ b/tests/testthat/test-vimp_concordance_S4.R @@ -15,30 +15,12 @@ familiar:::test_all_vimp_methods( familiar:::test_all_vimp_methods_parallel( familiar:::.get_available_concordance_vimp_method(show_general = FALSE)) -# Count outcome ---------------------------------------------------------------- -data <- familiar:::test_create_good_data("count") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "concordance", - vimp_method_parameter_list = NULL, - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that(paste0("The concordance method correctly ranks count data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("per_capita_crime", "lower_status_percentage"))) -}) # Continuous outcome ---------------------------------------------------------- data <- familiar:::test_create_good_data("continuous") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "concordance", vimp_method_parameter_list = NULL, @@ -49,15 +31,24 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that(paste0("The concordance method correctly ranks continuous data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct"))) + + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) + # Binomial outcome ------------------------------------------------------------- data <- familiar:::test_create_good_data("binomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "concordance", vimp_method_parameter_list = NULL, @@ -69,14 +60,22 @@ testthat::test_that(paste0("The concordance method correctly ranks binomial data vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("cell_shape_uniformity", "normal_nucleoli"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Multinomial outcome ---------------------------------------------------------- data <- familiar:::test_create_good_data("multinomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "concordance", vimp_method_parameter_list = NULL, @@ -88,14 +87,22 @@ testthat::test_that(paste0("The concordance method correctly ranks multinomial o vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(c("Petal_Length", "Petal_Width") %in% vimp_table[rank <= 2]$name)) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Survival outcome ------------------------------------------------------------- data <- familiar:::test_create_good_data("survival") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "concordance", vimp_method_parameter_list = NULL, @@ -107,5 +114,13 @@ testthat::test_that(paste0("The concordance method correctly ranks survival outc vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) diff --git a/tests/testthat/test-vimp_corelearn_S4.R b/tests/testthat/test-vimp_corelearn_S4.R index 8d05c38d..eac1dd8c 100644 --- a/tests/testthat/test-vimp_corelearn_S4.R +++ b/tests/testthat/test-vimp_corelearn_S4.R @@ -50,33 +50,11 @@ familiar:::test_all_vimp_methods( familiar:::test_all_vimp_methods_parallel( familiar:::.get_available_corelearn_gain_ratio_vimp_method(show_general = FALSE)) -# Count outcome ---------------------------------------------------------------- -data <- familiar:::test_create_good_data("count") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "relieff_exp_rank", - vimp_method_parameter_list = NULL, - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple" -) - -testthat::test_that(paste0( - "RReliefF exponentially decreasing ranks method correctly ranks count data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", "avg_rooms"))) -}) - # Continuous outcome ----------------------------------------------------------- data <- familiar:::test_create_good_data("continuous") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "relieff_exp_rank", vimp_method_parameter_list = NULL, @@ -89,14 +67,23 @@ testthat::test_that(paste0( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("avginc", "calwpct"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) + # Binomial outcome ------------------------------------------------------------- data <- familiar:::test_create_good_data("binomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "relieff_exp_rank", vimp_method_parameter_list = NULL, @@ -109,12 +96,19 @@ testthat::test_that(paste0( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "epithelial_cell_size", "cell_shape_uniformity", "clump_thickness", "bare_nuclei"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "gini", vimp_method_parameter_list = NULL, @@ -126,12 +120,19 @@ testthat::test_that(paste0("The Gini method correctly ranks binomial data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", "bare_nuclei", "normal_nucleoli"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "gain_ratio", vimp_method_parameter_list = NULL, @@ -144,12 +145,19 @@ testthat::test_that(paste0("The gain ratio method correctly ranks binomial data. vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", "bare_nuclei"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mdl", vimp_method_parameter_list = NULL, @@ -161,15 +169,23 @@ testthat::test_that(paste0("The MDL method correctly ranks binomial data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", "bare_nuclei", "normal_nucleoli")), TRUE) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) + # Multinomial outcome ---------------------------------------------------------- data <- familiar:::test_create_good_data("multinomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "relieff_exp_rank", vimp_method_parameter_list = NULL, @@ -182,11 +198,19 @@ testthat::test_that(paste0( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("Petal_Length", "Petal_Width"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "gini", vimp_method_parameter_list = NULL, @@ -198,12 +222,19 @@ testthat::test_that(paste0("The Gini method correctly ranks multinomial outcome vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "Petal_Length", "Petal_Width", "Sepal_Length"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "gain_ratio", vimp_method_parameter_list = NULL, @@ -215,12 +246,19 @@ testthat::test_that(paste0("The gain ratio method correctly ranks multinomial ou vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "Petal_Length", "Petal_Width", "Sepal_Length"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mdl", vimp_method_parameter_list = NULL, @@ -228,11 +266,17 @@ vimp_object <- familiar:::prepare_vimp_object( cluster_method = "none", imputation_method = "simple") - testthat::test_that(paste0("The MDL method correctly ranks multinomial outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "Petal_Length", "Petal_Width", "Sepal_Length"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) diff --git a/tests/testthat/test-vimp_correlation_S4.R b/tests/testthat/test-vimp_correlation_S4.R index 622684d4..78c74496 100644 --- a/tests/testthat/test-vimp_correlation_S4.R +++ b/tests/testthat/test-vimp_correlation_S4.R @@ -1,5 +1,6 @@ familiar:::test_all_vimp_methods_available( - familiar:::.get_available_correlation_vimp_methods(show_general = TRUE)) + familiar:::.get_available_correlation_vimp_methods(show_general = TRUE) +) # Don't perform any further tests on CRAN due to running time. testthat::skip_on_cran() @@ -11,65 +12,53 @@ familiar:::test_hyperparameter_optimisation( parallel = FALSE ) familiar:::test_all_vimp_methods( - familiar:::.get_available_correlation_vimp_methods(show_general = FALSE)) + familiar:::.get_available_correlation_vimp_methods(show_general = FALSE) +) familiar:::test_all_vimp_methods_parallel( - familiar:::.get_available_correlation_vimp_methods(show_general = FALSE)) - -# Count outcome ---------------------------------------------------------------- -data <- familiar:::test_create_good_data("count") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "spearman", - vimp_method_parameter_list = NULL, - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that(paste0("Spearman correlation correctly ranks count data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage"))) -}) + familiar:::.get_available_correlation_vimp_methods(show_general = FALSE) +) # Continuous outcome ----------------------------------------------------------- data <- familiar:::test_create_good_data("continuous") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "spearman", vimp_method_parameter_list = NULL, outcome_type = "continuous", cluster_method = "none", - imputation_method = "simple") + imputation_method = "simple" +) testthat::test_that(paste0("Spearman correlation correctly ranks continuous data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) + familiar:::.vimp(vimp_object, data) + )) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct"))) + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Survival outcome ------------------------------------------------------------- data <- familiar:::test_create_good_data("survival") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "spearman", vimp_method_parameter_list = NULL, outcome_type = "survival", cluster_method = "none", - imputation_method = "simple") + imputation_method = "simple" +) testthat::test_that(paste0( "Spearman correlation correctly ranks survival outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) + familiar:::.vimp(vimp_object, data) + )) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx"))) + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) diff --git a/tests/testthat/test-vimp_glmnet_S4.R b/tests/testthat/test-vimp_glmnet_S4.R index 7c9ab2ff..44263e7f 100644 --- a/tests/testthat/test-vimp_glmnet_S4.R +++ b/tests/testthat/test-vimp_glmnet_S4.R @@ -1,23 +1,27 @@ # First test if all selectable learners are also available familiar:::test_all_vimp_methods_available( - vimp_methods = familiar:::.get_available_glmnet_ridge_vimp_methods(show_general = TRUE)) + vimp_methods = familiar:::.get_available_glmnet_ridge_vimp_methods(show_general = TRUE) +) familiar:::test_all_vimp_methods_available( - vimp_methods = familiar:::.get_available_glmnet_lasso_vimp_methods(show_general = TRUE)) + vimp_methods = familiar:::.get_available_glmnet_lasso_vimp_methods(show_general = TRUE) +) familiar:::test_all_vimp_methods_available( - vimp_methods = familiar:::.get_available_glmnet_elastic_net_vimp_methods(show_general = TRUE)) + vimp_methods = familiar:::.get_available_glmnet_elastic_net_vimp_methods(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete test. testthat::skip_on_cran() testthat::skip_on_ci() familiar:::test_all_vimp_methods( - vimp_methods = familiar:::.get_available_glmnet_ridge_vimp_methods(show_general = FALSE)) + vimp_methods = familiar:::.get_available_glmnet_ridge_vimp_methods(show_general = FALSE) +) familiar:::test_all_vimp_methods( - vimp_methods = familiar:::.get_available_glmnet_lasso_vimp_methods(show_general = FALSE)) + vimp_methods = familiar:::.get_available_glmnet_lasso_vimp_methods(show_general = FALSE) +) familiar:::test_all_vimp_methods( vimp_methods = familiar:::.get_available_glmnet_elastic_net_vimp_methods(show_general = FALSE), hyperparameter_list = list( - "count" = list("alpha" = 0.50), "continuous" = list("alpha" = 0.50), "binomial" = list("alpha" = 0.50), "multinomial" = list("alpha" = 0.50), @@ -27,13 +31,14 @@ familiar:::test_all_vimp_methods( # Parallel tests familiar:::test_all_vimp_methods_parallel( - vimp_methods = familiar:::.get_available_glmnet_ridge_vimp_methods(show_general = FALSE)) + vimp_methods = familiar:::.get_available_glmnet_ridge_vimp_methods(show_general = FALSE) +) familiar:::test_all_vimp_methods_parallel( - vimp_methods = familiar:::.get_available_glmnet_lasso_vimp_methods(show_general = FALSE)) + vimp_methods = familiar:::.get_available_glmnet_lasso_vimp_methods(show_general = FALSE) +) familiar:::test_all_vimp_methods_parallel( vimp_methods = familiar:::.get_available_glmnet_elastic_net_vimp_methods(show_general = FALSE), hyperparameter_list = list( - "count" = list("alpha" = 0.50), "continuous" = list("alpha" = 0.50), "binomial" = list("alpha" = 0.50), "multinomial" = list("alpha" = 0.50), @@ -41,19 +46,41 @@ familiar:::test_all_vimp_methods_parallel( ) ) + +familiar:::test_hyperparameter_optimisation( + vimp_methods = "ridge", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) +familiar:::test_hyperparameter_optimisation( + vimp_methods = "lasso", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) +familiar:::test_hyperparameter_optimisation( + vimp_methods = "elastic_net", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) + + testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( vimp_methods = familiar:::.get_available_glmnet_ridge_vimp_methods(show_general = FALSE), debug = TRUE, - parallel = FALSE) - + parallel = FALSE +) familiar:::test_hyperparameter_optimisation( vimp_methods = familiar:::.get_available_glmnet_lasso_vimp_methods(show_general = FALSE), debug = TRUE, - parallel = FALSE) - + parallel = FALSE +) familiar:::test_hyperparameter_optimisation( vimp_methods = familiar:::.get_available_glmnet_elastic_net_vimp_methods(show_general = TRUE), debug = TRUE, - parallel = FALSE) + parallel = FALSE +) diff --git a/tests/testthat/test-vimp_mutual_information_S4.R b/tests/testthat/test-vimp_mutual_information_S4.R index f5065ba0..ed68f2f7 100644 --- a/tests/testthat/test-vimp_mutual_information_S4.R +++ b/tests/testthat/test-vimp_mutual_information_S4.R @@ -26,65 +26,12 @@ familiar:::test_all_vimp_methods( familiar:::test_all_vimp_methods_parallel( familiar:::.get_available_multivariate_mutual_information_vimp_method(show_general = FALSE)) -# Count outcome ---------------------------------------------------------------- -data <- familiar:::test_create_good_data("count") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "mim", - vimp_method_parameter_list = NULL, - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that(paste0("MIM correctly ranks count data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage"))) -}) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "mifs", - vimp_method_parameter_list = NULL, - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that(paste0("MIFS correctly ranks count data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", "industry"))) -}) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "mrmr", - vimp_method_parameter_list = NULL, - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that(paste0("MRMR correctly ranks count data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", "industry"))) -}) # Continuous outcome ----------------------------------------------------------- data <- familiar:::test_create_good_data("continuous") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mim", vimp_method_parameter_list = NULL, @@ -96,12 +43,19 @@ testthat::test_that(paste0("MIM correctly ranks continuous data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "enrltot", "avginc", "calwpct"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mifs", vimp_method_parameter_list = NULL, @@ -113,12 +67,19 @@ testthat::test_that(paste0("MIFS correctly ranks continuous data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "enrltot", "avginc", "calwpct"))) + # Expect that the vimp table has six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mrmr", vimp_method_parameter_list = NULL, @@ -129,15 +90,23 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that(paste0("MRMR correctly ranks continuous data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct"))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Binomial outcome ------------------------------------------------------------- data <- familiar:::test_create_good_data("binomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mim", vimp_method_parameter_list = NULL, @@ -148,13 +117,20 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that(paste0("MIM correctly ranks binomial data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", "bare_nuclei"))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mifs", vimp_method_parameter_list = NULL, @@ -165,12 +141,19 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that(paste0("MIFS correctly ranks binomial data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - - testthat::expect_equal("cell_shape_uniformity" %in% vimp_table[rank <= 2]$name, TRUE) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mrmr", vimp_method_parameter_list = NULL, @@ -183,14 +166,23 @@ testthat::test_that(paste0("MRMR correctly ranks binomial data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true("cell_shape_uniformity" %in% vimp_table[rank <= 2]$name) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) + # Multinomial outcome ---------------------------------------------------------- data <- familiar:::test_create_good_data("multinomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mim", vimp_method_parameter_list = NULL, @@ -202,11 +194,19 @@ testthat::test_that(paste0("MIM correctly ranks multinomial outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("Petal_Length", "Petal_Width"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mifs", vimp_method_parameter_list = NULL, @@ -217,12 +217,20 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that(paste0("MIFS correctly ranks multinomial outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("Sepal_Width", "Petal_Width"))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mrmr", vimp_method_parameter_list = NULL, @@ -233,8 +241,16 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that(paste0("MRMR correctly ranks multinomial outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("Sepal_Width", "Petal_Width"))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) @@ -242,7 +258,7 @@ testthat::test_that(paste0("MRMR correctly ranks multinomial outcome data."), { data <- familiar:::test_create_good_data("survival") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mim", vimp_method_parameter_list = NULL, @@ -254,11 +270,19 @@ testthat::test_that(paste0("MIM correctly ranks survival outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx"))) + # Expect that the vimp table has six rows. + testthat::expect_equal(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(familiar:::get_feature_columns(data) %in% vimp_table$name)) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mifs", vimp_method_parameter_list = NULL, @@ -268,12 +292,20 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that(paste0("MIFS correctly ranks survival outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx"))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "mrmr", vimp_method_parameter_list = NULL, @@ -285,5 +317,13 @@ testthat::test_that(paste0("MRMR correctly ranks survival outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) diff --git a/tests/testthat/test-vimp_ranger_S4.R b/tests/testthat/test-vimp_ranger_S4.R index 5faafdb2..5a7054a1 100644 --- a/tests/testthat/test-vimp_ranger_S4.R +++ b/tests/testthat/test-vimp_ranger_S4.R @@ -10,14 +10,6 @@ testthat::skip_on_ci() familiar:::test_all_vimp_methods( familiar:::.get_available_ranger_vimp_methods(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1 - ), "continuous" = list( "n_tree" = 4, "sample_size" = 1.00, @@ -60,14 +52,6 @@ familiar:::test_all_vimp_methods( familiar:::test_all_vimp_methods_parallel( familiar:::.get_available_ranger_vimp_methods(show_general = FALSE), hyperparameter_list = list( - "count" = list( - "n_tree" = 4, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1 - ), "continuous" = list( "n_tree" = 4, "sample_size" = 1.00, @@ -103,96 +87,11 @@ familiar:::test_all_vimp_methods_parallel( ) ) -# Count outcome ---------------------------------------------------------------- -data <- familiar:::test_create_good_data("count") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_ranger_impurity", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0("The ranger random forest impurity method correctly ranks count data."), - { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", - "residence_before_1940_proportion", "avg_rooms", "industry"))) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_ranger_permutation", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple" -) - -testthat::test_that( - paste0("The ranger random forest permutation method correctly ranks count data."), - { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", - "residence_before_1940_proportion", "avg_rooms"))) - } -) - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "random_forest_ranger_holdout_permutation", - vimp_method_parameter_list = list( - "n_tree" = 4, - "sample_size" = 1.00, - "m_try" = 0.3, - "node_size" = 5, - "tree_depth" = 5, - "alpha" = 0.1), - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") - -testthat::test_that( - paste0("The ranger random forest hold-out permutation method correctly ranks count data."), - { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", - "residence_before_1940_proportion", "avg_rooms"))) - } -) - # Continuous outcome ----------------------------------------------------------- data <- familiar:::test_create_good_data("continuous") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_impurity", vimp_method_parameter_list = list( @@ -212,13 +111,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "enrltot", "avginc", "calwpct"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_permutation", vimp_method_parameter_list = list( @@ -239,13 +145,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "enrltot", "avginc", "calwpct"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_holdout_permutation", vimp_method_parameter_list = list( @@ -265,8 +178,15 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "enrltot", "avginc", "calwpct"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) @@ -274,7 +194,7 @@ testthat::test_that( data <- familiar:::test_create_good_data("binomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_impurity", vimp_method_parameter_list = list( @@ -294,14 +214,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", - "epithelial_cell_size", "bare_nuclei"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_permutation", vimp_method_parameter_list = list( @@ -320,14 +246,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", - "epithelial_cell_size", "bare_nuclei"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_holdout_permutation", vimp_method_parameter_list = list( @@ -344,12 +276,18 @@ vimp_object <- familiar:::prepare_vimp_object( testthat::test_that( paste0("The ranger random forest hold-out permutation method correctly ranks binomial data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", - "epithelial_cell_size", "bare_nuclei"))) + vimp_table <- suppressWarnings(familiar:::get_vimp_table( + familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) @@ -357,7 +295,7 @@ testthat::test_that( data <- familiar:::test_create_good_data("multinomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_impurity", vimp_method_parameter_list = list( @@ -376,13 +314,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "Petal_Length", "Petal_Width"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_permutation", vimp_method_parameter_list = list( @@ -403,13 +348,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "Petal_Length", "Petal_Width"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_holdout_permutation", vimp_method_parameter_list = list( @@ -432,8 +384,15 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "Petal_Length", "Petal_Width"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) @@ -441,7 +400,7 @@ testthat::test_that( data <- familiar:::test_create_good_data("survival") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_impurity", vimp_method_parameter_list = list( @@ -461,12 +420,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx", "adhere"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_permutation", vimp_method_parameter_list = list( @@ -486,12 +453,20 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx", "adhere"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "random_forest_ranger_holdout_permutation", vimp_method_parameter_list = list( @@ -513,10 +488,28 @@ testthat::test_that( vimp_table <- suppressWarnings(familiar:::get_vimp_table( familiar:::.vimp(vimp_object, data))) - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx", "adhere"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") } ) + +familiar:::test_hyperparameter_optimisation( + vimp_methods = "random_forest_ranger_impurity", + debug = FALSE, + parallel = FALSE, + test_specific_config = TRUE +) + + + testthat::skip("Skip hyperparameter optimisation, unless manual.") familiar:::test_hyperparameter_optimisation( diff --git a/tests/testthat/test-vimp_regression_S4.R b/tests/testthat/test-vimp_regression_S4.R index 27070d45..bfab943a 100644 --- a/tests/testthat/test-vimp_regression_S4.R +++ b/tests/testthat/test-vimp_regression_S4.R @@ -1,7 +1,9 @@ familiar:::test_all_vimp_methods_available( - familiar:::.get_available_univariate_regression_vimp_methods(show_general = TRUE)) + familiar:::.get_available_univariate_regression_vimp_methods(show_general = TRUE) +) familiar:::test_all_vimp_methods_available( - familiar:::.get_available_multivariate_regression_vimp_methods(show_general = TRUE)) + familiar:::.get_available_multivariate_regression_vimp_methods(show_general = TRUE) +) # Don't perform any further tests on CRAN due to time of running the complete # test. @@ -12,12 +14,15 @@ familiar:::test_hyperparameter_optimisation( vimp_methods = familiar:::.get_available_univariate_regression_vimp_methods(show_general = TRUE), debug = FALSE, parallel = FALSE, - not_available_no_samples = FALSE) + not_available_no_samples = FALSE +) familiar:::test_all_vimp_methods( - familiar:::.get_available_univariate_regression_vimp_methods(show_general = FALSE)) + familiar:::.get_available_univariate_regression_vimp_methods(show_general = FALSE) +) familiar:::test_all_vimp_methods_parallel( - familiar:::.get_available_univariate_regression_vimp_methods(show_general = FALSE)) + familiar:::.get_available_univariate_regression_vimp_methods(show_general = FALSE) +) familiar:::test_hyperparameter_optimisation( vimp_methods = familiar:::.get_available_multivariate_regression_vimp_methods(show_general = TRUE), @@ -27,105 +32,132 @@ familiar:::test_hyperparameter_optimisation( ) familiar:::test_all_vimp_methods( - familiar:::.get_available_multivariate_regression_vimp_methods(show_general = FALSE)) + familiar:::.get_available_multivariate_regression_vimp_methods(show_general = FALSE) +) familiar:::test_all_vimp_methods_parallel( - familiar:::.get_available_multivariate_regression_vimp_methods(show_general = FALSE)) - -# Count outcome ---------------------------------------------------------------- -data <- familiar:::test_create_good_data("count") - -# Process dataset. -vimp_object <- familiar:::prepare_vimp_object( - data = data, - vimp_method = "multivariate_regression", - vimp_method_parameter_list = NULL, - outcome_type = "count", - cluster_method = "none", - imputation_method = "simple") + familiar:::.get_available_multivariate_regression_vimp_methods(show_general = FALSE) +) -testthat::test_that(paste0("Multivariate regression correctly ranks count data."), { - vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "per_capita_crime", "lower_status_percentage", - "residence_before_1940_proportion", "avg_rooms", "pupil_teacher_ratio"))) -}) # Continuous outcome ----------------------------------------------------------- data <- familiar:::test_create_good_data("continuous") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "multivariate_regression", vimp_method_parameter_list = NULL, outcome_type = "continuous", cluster_method = "none", - imputation_method = "simple") + imputation_method = "simple" +) testthat::test_that(paste0("Multivariate regression correctly ranks continuous data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) + familiar:::.vimp(vimp_object, data) + )) - testthat::expect_true(any(vimp_table[rank <= 2]$name %in% c("enrltot", "avginc", "calwpct"))) + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) + # Binomial outcome ------------------------------------------------------------- data <- familiar:::test_create_good_data("binomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "multivariate_regression", vimp_method_parameter_list = NULL, outcome_type = "binomial", cluster_method = "none", - imputation_method = "simple") + imputation_method = "simple" +) testthat::test_that(paste0("Multivariate regression correctly ranks binomial data.."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "cell_shape_uniformity", "clump_thickness", "bare_nuclei", "normal_nucleoli"))) + familiar:::.vimp(vimp_object, data)) + ) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) + # Multinomial outcome ---------------------------------------------------------- data <- familiar:::test_create_good_data("multinomial") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "multivariate_regression", vimp_method_parameter_list = NULL, outcome_type = "multinomial", cluster_method = "none", - imputation_method = "simple") + imputation_method = "simple" +) testthat::test_that(paste0("Multivariate regression correctly ranks multinomial outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c( - "Petal_Length", "Petal_Width", "Sepal_Length"))) + familiar:::.vimp(vimp_object, data)) + ) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) + # Survival outcome ------------------------------------------------------------- data <- familiar:::test_create_good_data("survival") # Process dataset. -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "multivariate_regression", vimp_method_parameter_list = NULL, outcome_type = "survival", cluster_method = "none", - imputation_method = "simple") + imputation_method = "simple" +) testthat::test_that(paste0("Multivariate regression correctly ranks survival outcome data."), { vimp_table <- suppressWarnings(familiar:::get_vimp_table( - familiar:::.vimp(vimp_object, data))) - - testthat::expect_true(all(vimp_table[rank <= 2]$name %in% c("nodes", "rx", "adhere"))) + familiar:::.vimp(vimp_object, data)) + ) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data)) + ) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") }) diff --git a/tests/testthat/test-vimp_rfsrc_S4.R b/tests/testthat/test-vimp_rfsrc_S4.R new file mode 100644 index 00000000..2c03ccc1 --- /dev/null +++ b/tests/testthat/test-vimp_rfsrc_S4.R @@ -0,0 +1,388 @@ +familiar:::test_all_vimp_methods_available( + familiar:::.get_available_rfsrc_vimp_methods(show_general = TRUE)) +familiar:::test_all_vimp_methods_available( + familiar:::.get_available_rfsrc_default_vimp_methods(show_general = TRUE)) + +# Don't perform any further tests on CRAN due to time of running the complete +# test. +testthat::skip_on_cran() +testthat::skip_on_ci() + +familiar:::test_all_vimp_methods( + familiar:::.get_available_rfsrc_vimp_methods(show_general = FALSE), + debug = FALSE, + hyperparameter_list = list( + "continuous" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ), + "binomial" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ), + "multinomial" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ), + "survival" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ) + ) +) + +familiar:::test_all_vimp_methods( + familiar:::.get_available_rfsrc_default_vimp_methods()) + +familiar:::test_all_vimp_methods_parallel( + familiar:::.get_available_rfsrc_vimp_methods(show_general = FALSE), + hyperparameter_list = list( + "continuous" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ), + "binomial" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ), + "multinomial" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ), + "survival" = list( + "n_tree" = 4, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5, + "fs_vh_fold" = 3, + "fs_vh_n_rep" = 2 + ) + ) +) + + +# Continuous outcome ----------------------------------------------------------- +data <- familiar:::test_create_good_data("continuous") + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_permutation", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "continuous", + cluster_method = "none", + imputation_method = "simple") + +testthat::test_that( + paste0( + "The RFSRC random forest permutation method correctly ranks continuous data."), + { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_holdout", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "continuous", + cluster_method = "none", + imputation_method = "simple") + + +testthat::test_that( + paste0( + "The RFSRC random forest hold-out method correctly ranks continuous data."), + { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + + + +# Binomial outcome ------------------------------------------------------------- +data <- familiar:::test_create_good_data("binomial") + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_permutation", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "binomial", + cluster_method = "none", + imputation_method = "simple" +) + +testthat::test_that( + paste0( + "The RFSRC random forest permutation method correctly ranks binomial data."), + { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_holdout", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "binomial", + cluster_method = "none", + imputation_method = "simple") + +testthat::test_that( + paste0( + "The RFSRC random forest hold-out method correctly ranks binomial data."), + { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + + +# Multinomial outcome ---------------------------------------------------------- +data <- familiar:::test_create_good_data("multinomial") + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_permutation", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "multinomial", + cluster_method = "none", + imputation_method = "simple") + +testthat::test_that( + paste0( + "The RFSRC random forest permutation method correctly ranks multinomial outcome data."), + { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_holdout", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "multinomial", + cluster_method = "none", + imputation_method = "simple") + +testthat::test_that( + paste0( + "The RFSRC random forest hold-out method correctly ranks multinomial outcome data."), + { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + + +# Survival outcome ------------------------------------------------------------- +data <- familiar:::test_create_good_data("survival") + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_permutation", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "survival", + cluster_method = "none", + imputation_method = "simple") + +testthat::test_that( + paste0( + "The RFSRC random forest permutation method correctly ranks survival outcome data."), { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + + +# Process dataset. +vimp_object <- familiar:::test_create_vimp_method( + data = data, + vimp_method = "random_forest_rfsrc_holdout", + vimp_method_parameter_list = list( + "n_tree" = 8, + "sample_size" = 0.50, + "m_try" = 0.3, + "node_size" = 5, + "tree_depth" = 5), + outcome_type = "survival", + cluster_method = "none", + imputation_method = "simple") + +testthat::test_that( + paste0( + "The RFSRC random forest hold-out method correctly ranks survival outcome data."), + { + vimp_table <- suppressWarnings( + familiar:::get_vimp_table(familiar:::.vimp(vimp_object, data))) + + # Expect that the vimp table has at most six rows. + testthat::expect_lte(nrow(vimp_table), 6L) + + # Expect that the names are the same as that of the features. + testthat::expect_true( + all(vimp_table$name %in% familiar:::get_feature_columns(data))) + + # Feature 1 is most important. + testthat::expect_equal(vimp_table[rank == 1, ]$name, "feature_1") + } +) + + +testthat::skip("Skip hyperparameter optimisation, unless manual.") + +familiar:::test_hyperparameter_optimisation( + vimp_methods = familiar:::.get_available_rfsrc_vimp_methods(show_general = TRUE), + debug = FALSE, + parallel = FALSE) diff --git a/tests/testthat/test-vimp_table.R b/tests/testthat/test-vimp_table.R index cf97ac93..3c7d4134 100644 --- a/tests/testthat/test-vimp_table.R +++ b/tests/testthat/test-vimp_table.R @@ -1,4 +1,5 @@ testthat::skip_on_cran() + # power.transform is also required for transformation_method = "none". if (!rlang::is_installed("power.transform")) testthat::skip() @@ -9,7 +10,7 @@ data <- familiar:::test_create_synthetic_correlated_data( n_numeric = 2, cluster_size = c(1, 1, 2, 3)) -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "pearson", outcome_type = "continuous", @@ -157,7 +158,7 @@ data_2 <- familiar:::test_create_synthetic_correlated_data( n_numeric = 2, cluster_size = c(1, 1, 4, 2)) -vimp_object_2 <- familiar:::prepare_vimp_object( +vimp_object_2 <- familiar:::test_create_vimp_method( data = data_2, vimp_method = "pearson", outcome_type = "continuous", @@ -236,7 +237,7 @@ data.table::setnames( old = c("feature_1", "feature_2", "feature_3", "feature_4"), new = c("feature_A", "feature_B", "feature_C", "feature_D")) -vimp_object_3 <- familiar:::prepare_vimp_object( +vimp_object_3 <- familiar:::test_create_vimp_method( data = data_3, vimp_method = "pearson", outcome_type = "continuous", @@ -308,7 +309,7 @@ data <- familiar:::test_create_synthetic_correlated_data( n_numeric = 2, cluster_size = c(1, 1, 1, 1)) -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "pearson", outcome_type = "continuous", @@ -347,7 +348,7 @@ testthat::test_that("A signature feature does not appear in the variable importa # Test with all signature features --------------------------------------------- -vimp_object <- familiar:::prepare_vimp_object( +vimp_object <- familiar:::test_create_vimp_method( data = data, vimp_method = "pearson", outcome_type = "continuous", diff --git a/vignettes/.gitignore b/vignettes/.gitignore index 9f24561d..c94400ed 100644 --- a/vignettes/.gitignore +++ b/vignettes/.gitignore @@ -1,9 +1,8 @@ *.html *.R -*.Rmd !license.html !familiar_logo.html !compile.R /figure/ /eval_and_explain/ -/prospective_use/ \ No newline at end of file +/prospective_use/ diff --git a/vignettes/compile.R b/vignettes/compile.R index c413628d..38f286c5 100644 --- a/vignettes/compile.R +++ b/vignettes/compile.R @@ -8,16 +8,7 @@ knitr::opts_chunk$set(fig.path = "eval_and_explain/") # See https://ropensci.org/blog/2019/12/08/precompute-vignettes/ knitr::knit("vignettes/original/evaluation_and_explanation.Rmd", output = "vignettes/evaluation_and_explanation_precompiled.Rmd") - - -# Restart the session to flush the temporary directories. -knitr::opts_knit$set(root.dir = getwd()) -knitr::opts_knit$set(base.dir = "vignettes") -knitr::opts_chunk$set(fig.path = "prospective_use/") - -knitr::knit("vignettes/original/prospective_use.Rmd", output = "vignettes/prospective_use_precompiled.Rmd") - knitr::knit("vignettes/original/introduction.Rmd", output = "vignettes/introduction_precompiled.Rmd") -knitr::knit("vignettes/original/feature_selection.Rmd", output = "vignettes/feature_selection_precompiled.Rmd") +knitr::knit("vignettes/original/variable_importance.Rmd", output = "vignettes/variable_importance_precompiled.Rmd") knitr::knit("vignettes/original/learners.Rmd", output = "vignettes/learners_precompiled.Rmd") knitr::knit("vignettes/original/performance_metrics.Rmd", output = "vignettes/performance_metrics_precompiled.Rmd") diff --git a/vignettes/evaluation_and_explanation_precompiled.Rmd b/vignettes/evaluation_and_explanation_precompiled.Rmd new file mode 100644 index 00000000..d7fec23b --- /dev/null +++ b/vignettes/evaluation_and_explanation_precompiled.Rmd @@ -0,0 +1,1318 @@ +--- +title: "Evaluation and explanation" +author: "Alex Zwanenburg" +date: "2026-04-22" +output: + rmarkdown::html_vignette: + includes: + in_header: familiar_logo.html + after_body: license.html + toc: TRUE + rmarkdown::github_document: + html_preview: FALSE + includes: + in_header: familiar_logo.html + after_body: license.html + toc: TRUE +bibliography: "refs.bib" +vignette: > + %\VignetteIndexEntry{Evaluation and explanation} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + + + +``` r +library(familiar) +library(data.table) + +set.seed(19) +``` + +Familiar will automatically evaluate created models, and export corresponding +tables and plots. The table below lists all available analyses. Several +analyses allow for determining distributions and confidence intervals to provide +an indication of the value spread for a given dataset and models (if +applicable). The `estimation_type` argument defines this behaviour: + +- `point`: Compute point estimates, i.e. single values. + +- `bias_correction` or `bc`: Bias-corrected estimates. A bias-corrected +estimate is computed from (at least) 20 point estimates. + +- `bootstrap_confidence_interval` or `bci`: Bias-corrected estimates with +bootstrap confidence intervals [@Efron2016-ws]. This estimation type allows for +plotting confidence intervals in plots. The number of point estimates required +depends on the `confidence_level` parameter. Familiar uses a rule of thumb of +n=20/(1-`confidence_level`), i.e. at least 400 points for +`confidence_level=0.95`. + +Another argument, `detail_level` determines how the required point estimates are +formed: + +- `ensemble`: Point estimates are computed at the ensemble level, i.e. over +all models in the ensemble. This means that, for example, bias-corrected +estimates of model performance are assessed by creating (at least) 20 bootstraps +and computing the model performance of the ensemble model for each bootstrap. + +- `hybrid`: Point estimates are computed from the models in an ensemble. +This means that, for example, bias-corrected estimates of model performance are +directly computed using the models in the ensemble. If there are at least 20 +trained models in the ensemble, performance is computed for each model, in +contrast to `ensemble` where performance is computed for the ensemble of models. +If there are less than 20 trained models in the ensemble, bootstraps are created +so that at least 20 point estimates can be made. + +- `model`: Point estimates are computed at the model level. This means that, +for example, bias-corrected estimates of model performance are assessed by +creating (at least) 20 bootstraps and computing the performance of the model for +each bootstrap. Familiar will not automatically create plots in this case. + +The more point estimates are required, the more computationally +intensive the analysis is. Some analyses also become computationally more +expensive with more samples. The `sample_limit` argument can be used to specify +the maximum number of samples that should be used. + +Some analyses, such as model predictions and individual conditional expectation +plots, do not benefit from bootstraps as they are solely based on values +predicted by the (ensemble) models. If you want to compute bias-corrected +estimates or bootstrap confidence intervals for these analyses you should ensure +that sufficient models are created. Experimental designs such as +`experimental_design="bs(fs+mb,400)+ev"` allow for this, but are computationally +expensive. + +Several methods do not require any more information than that provided in a +prediction table or dataset. + +| Name | Plot function | Export function | Est. type | Detail level | Sample limit | Model | Pred. table | Dataset | +|------------------------------------------|---------------------------------------------------------------------------------------|---------------------------------------|:---------:|:------------:|:------------:|:-----:|:-----------:|:-------:| +| AUC-PR^a^ | `plot_auc_precision_recall_curve` | `export_auc_data` | × | × | | × | × | | +| AUC-ROC^a^ | `plot_auc_roc_curve` | `export_auc_data` | × | × | | × | × | | +| Calibration info^c^ | | `export_calibration_info` | | × | | × | | | +| Confusion matrix^a^ | `plot_confusion_matrix` | `export_confusion_matrix_data` | | × | | × | × | | +| Decision curve analysis^ab^ | `plot_decision_curve` | `export_decision_curve_analysis_data` | × | × | | × | × | | +| Feature expression^c^ | `plot_sample_clustering` | `export_feature_expressions` | | | | × | | × | +| Feature selection variable importance^c^ | `plot_feature_selection_occurrence`; `plot_feature_selection_variable_importance` | `export_fs_vimp` | | | | × | | | +| Feature similarity^c^ | `plot_feature_similarity` | `export_feature_similarity` | × | | | × | | × | +| Hyperparameters^c^ | | `export_hyperparameters` | | | | × | | | +| Individual conditional expectation^c^ | `plot_ice` | `export_ice_data` | ×^d^ | × | × | × | | | +| Model calibration^ce^ | `plot_calibration_data` | `export_calibration_data` | × | × | | × | | | +| Model performance^c^ | `plot_model_performance` | `export_model_performance` | × | × | | × | × | | +| Model predictions^c^ | | `export_prediction_data` | ×^d^ | × | | × | x | | +| Model variable importance^ce^ | `plot_model_signature_occurrence`; `plot_model_signature_variable_importance` | `export_model_vimp` | | | | × | | | +| Partial dependence^c^ | `plot_pd` | `export_partial_dependence_data` | ×^d^ | × | × | × | | | +| Permutation variable importance^c^ | `plot_permutation_variable_importance` | `export_permutation_vimp` | × | × | | × | | | +| Risk stratification info^b^ | | `export_risk_stratification_info` | | × | | × | | | +| Risk stratification data^b^ | `plot_kaplan_meier` | `export_risk_stratification_data` | | | | × | × | | +| Sample similarity^c^ | | `export_sample_similarity` | × | | × | × | | × | +| SHAP values | `plot_shap_summary`, `plot_shap_waterfall`, `plot_shap_force`, `plot_shap_dependence` | `export_shap` | | × | × | × | | | +| Univariate analysis^c^ | `plot_univariate_importance` | `export_univariate_analysis_data` | | | | × | | | + +: Evaluation and explanation steps.\ +^a^ Available for binomial and multinomial outcomes.\ +^b^ Available for survival outcomes.\ +^c^ Available for all outcomes.\ +^d^ Estimation types other than `point` require sufficient models.\ +^e^ May not be available for all models. + +When familiar is run from `summon_familiar` plots and tables are exported +automatically. The corresponding plot and export functions can all be used externally as well. +This vignette shows their use. + +We will first create two models. The first model aims to predict the risk for +ischemic stroke based on clinical and image features. This is a classification problem. +For illustration purposes, we will use the first 99 samples as development data, +and the remaining as a holdout set. + + +``` r +ischemic_stroke_data <- data.table::as.data.table(modeldata::ischemic_stroke) + +# Set categorical variables. +ischemic_stroke_data$male <- factor( + ischemic_stroke_data$male, levels = c(0, 1), labels = c("no", "yes") +) +ischemic_stroke_data$smoking_history <- factor( + ischemic_stroke_data$smoking_history, levels = c(0, 1), labels = c("no", "yes") +) +ischemic_stroke_data$atrial_fibrillation <- factor( + ischemic_stroke_data$atrial_fibrillation, levels = c(0, 1), labels = c("no", "yes") +) +ischemic_stroke_data$coronary_artery_disease <- factor( + ischemic_stroke_data$coronary_artery_disease, levels = c(0, 1), labels = c("no", "yes") +) +ischemic_stroke_data$diabetes_history <- factor( + ischemic_stroke_data$diabetes_history, levels = c(0, 1), labels = c("no", "yes") +) +ischemic_stroke_data$hypercholesterolemia_history <- factor( + ischemic_stroke_data$hypercholesterolemia_history, levels = c(0, 1), labels = c("no", "yes") +) +ischemic_stroke_data$hypertension_history <- factor( + ischemic_stroke_data$hypertension_history, levels = c(0, 1), labels = c("no", "yes") +) + +# Create training and hold-out test set. +ischemic_stroke_data_train <- ischemic_stroke_data[1L:99L, ] +ischemic_stroke_data <- ischemic_stroke_data[100L:126L, ] + +# Call familiar to create models. We don't use summon_familiar here, but call +# train_familiar instead, which returns familiar models. +ischemic_stroke_model <- familiar::train_familiar( + data = ischemic_stroke_data_train, + outcome_column = "stroke", + class_levels = c("no", "yes"), + vimp_method = "none", + learner = "random_forest_ranger_default", + parallel = FALSE, + verbose = FALSE +) + +``` + +The second model is a survival model, and is trained on a colon +chemotherapy clinical trial dataset [@Moertel1995-bh] to predict recurrence +after treatment. + + +``` r +survival_data <- data.table::as.data.table(survival::colon) + +# Select data corresponding to tumour recurrence. +survival_data <- survival_data[etype == 1L] + +# Remove unncessary columns. +survival_data[, ":=" ("id" = NULL, "study" = NULL, "etype" = NULL, "node4" = NULL)] + +# Set categorical variables. +survival_data$sex <- factor( + survival_data$sex, levels = c(0, 1), labels = c("female", "male") +) +survival_data$obstruct <- factor( + survival_data$obstruct, levels = c(0, 1), labels = c("no", "yes") +) +survival_data$adhere <- factor( + survival_data$adhere, levels = c(0, 1), labels = c("no", "yes") +) +survival_data$differ <- factor( + survival_data$differ, + levels = c(1, 2, 3), + labels = c("well", "moderate", "poor"), + ordered = TRUE +) +survival_data$extent <- factor( + survival_data$extent, + levels = c(1, 2, 3, 4), + labels = c("submucosa", "muscle", "serosa", "contiguous structures"), + ordered = TRUE +) +survival_data$surg <- factor( + survival_data$surg, levels = c(0, 1), labels = c("short", "long") +) + +# Create training and hold-out test set. +survival_data_train <- survival_data[1L:799L, ] +survival_data <- survival_data[800L:929L, ] + +survival_model <- familiar::train_familiar( + data = survival_data_train, + outcome_column = c("status", "time"), + vimp_method = "none", + learner = "random_forest_ranger_default", + parallel = FALSE, + verbose = FALSE +) +``` + +# Model performance + +We assess model performance to evaluate accuracy of a model. Model accuracy is +quantified using performance metrics that are documented in the *Performance metrics* +vignette, and can be set using the `evaluation_metric` argument of the +`summon_familiar` function or `metric` for plot and export functions. For +example, this results in the following plot for the ischemic stroke dataset: + + +``` r +plots <- familiar::plot_model_performance( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + metric = c("auc", "brier", "f1_score"), + x_axis_by = "metric" +) +``` +
+Performance of the ischemic stroke model on hold-out test data. + The model is a classifier, and was assessed using three metrics: + area under the receiver-operating characteristic curve (AUC), the Brier + score, and the F1-score. Higher AUC and F1-scores, and lower Brier score, + indicate better models. The graph shows the distribution of performance + metrics obtained from bootstraps of the dataset, along with 2.5th, 50.0th + and 97.5th percentiles. +

Performance of the ischemic stroke model on hold-out test data. + The model is a classifier, and was assessed using three metrics: + area under the receiver-operating characteristic curve (AUC), the Brier + score, and the F1-score. Higher AUC and F1-scores, and lower Brier score, + indicate better models. The graph shows the distribution of performance + metrics obtained from bootstraps of the dataset, along with 2.5th, 50.0th + and 97.5th percentiles.

+
+ +The plot shows distributions of the area under the receiver operating +characteristic curve, the brier score and the f1-score, based on bootstrap +resampling of model predictions. + +Model performance can also be determined directly from predictions, which makes +it possible to assess predictions made by non-familiar models. This involves +conversion of the predictions to a prediction table object using `as_prediction_table`, +as shown below: + + +``` r +predictions <- predict( + object = ischemic_stroke_model, + newdata = ischemic_stroke_data +) + +# Create a prediction table object using as_prediction_table. The minimum +# you need to provide here are: prediction probabilities for the positive class +# (yes), the reference labels, the type of prediction (classification), +# and providing the class levels (no, yes). +predictions <- familiar::as_prediction_table( + x = predictions$yes, + y = ischemic_stroke_data$stroke, + type = "classification", + class_levels = c("no", "yes") +) +#> Error in `familiar::as_prediction_table()`: +#> ! (converted from warning) The positive class cannot be directly inferred from names of the provided prediction data, and is assumed to be yes. + +# The prediction table object is then provided as object +plots <- familiar::plot_model_performance( + object = predictions, + metric = c("auc", "brier", "f1_score"), + x_axis_by = "metric" +) +#> Error in `.local()`: +#> ! data_element expects one of feature_expressions, risk_stratification_data, feature_similarity and sample_similarity as input. Found the following unknown values: model_performance +``` + +
+Performance for the ischemic strok model obtained using a + prediction table. This results in the same figure as above, obtained + using the model itself. +

Performance for the ischemic strok model obtained using a + prediction table. This results in the same figure as above, obtained + using the model itself.

+
+ +This produces the exact same plot. Model performance can also be exported to a +table using using `export_model_performance`. + + +``` r +results <- familiar::export_model_performance( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + metric = c("auc", "brier", "f1_score"), + aggregate_results = TRUE +) +results[[1L]]@data +#> data_set vimp_method learner ensemble_model_name metric value ci_low ci_up +#> +#> 1: 173529_2wFvaYlrMM6XXSNOt9rE none random_forest_ranger_default ensemble.NA.NA auc 0.7387626 0.5166193 0.9146674 +#> 2: 173529_2wFvaYlrMM6XXSNOt9rE none random_forest_ranger_default ensemble.NA.NA brier 0.2041370 0.1639073 0.2492457 +#> 3: 173529_2wFvaYlrMM6XXSNOt9rE none random_forest_ranger_default ensemble.NA.NA f1_score 0.7407407 0.5152258 0.8967186 +``` +In the above table, `data_set` is randomly generated because we call this method +on a (technically) *new* dataset. `ensemble_model_name` contains a placeholder +for the same reason. `vimp_method` and `learner` are derived from the model, and +metrics with 95% confidence intervals are shown. + +## Receiver-operating characteristic curve + +The receiver-operating characteristic (ROC) curve visualises concordance between +predicted class probabilities and the observed classes [@Hand2001-il]. It shows +the trade-off between sensitivity and specificity of the model. The +receiver-operating characteristic curve for the ischemic stroke dataset is as +follows: + + +``` r +plots <- familiar::plot_auc_roc_curve( + object = ischemic_stroke_model, + data = ischemic_stroke_data +) +``` +
+Receiver-operating characteristic curve for the ischemic stroke + model on hold-out test data. The 95% confidence interval is shown (grey). +

Receiver-operating characteristic curve for the ischemic stroke + model on hold-out test data. The 95% confidence interval is shown (grey).

+
+ +Under ideal circumstances, the curve would lie in the top-left corner of the +plot. If a model does not predict better than at random, the curve would lie +along the diagonal, which corresponds to an AUC-ROC value of 0.50. The plot +above indicates that the model can somewhat differentiate between patients with +and without stroke. + +Familiar creates an ROC curve by ascendingly sorting instances by the predicted +probability of the positive class, and computing the number of true positive, +true negative, false positive, false negative cases observed at each instance. +These are then used to compute sensitivity and specificity. + +The above plot shows the average of 400 single curves, with 95% confidence +intervals. To achieve this, familiar interrogates each curve over the complete +range of potential specificity values ([0.000, 1.000]) with a step size of +0.005. Linear interpolation is used for this purpose [@Davis2006-xb]. This +allows for assessing the distribution of sensitivity at fixed specificity +values. + +The above approach is the general approach used by familiar. However, familiar +will plot an exact ROC curve if the point estimate (`estimation_type="point"`) +of a single model or the complete ensemble of models is evaluated +(`detail_level="ensemble"`): + + +``` r +plots <- familiar::plot_auc_roc_curve( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + estimation_type = "point" +) +``` +
+Receiver-operating characteristic curve for the ischemic stroke + model on hold-out test data. Whereas the previous figure shows the bootstrap + estimate and confidence interval, the current curve is formed + directly from the data. +

Receiver-operating characteristic curve for the ischemic stroke + model on hold-out test data. Whereas the previous figure shows the bootstrap + estimate and confidence interval, the current curve is formed + directly from the data.

+
+ +Note that we did not specify the detail level to create the above plot because +only a single model is evaluated. + +## Precision-recall curve + +The precision-recall (PR) curve shows the trade-off between precision (positive +predictive value) and recall (sensitivity). An important distinction between the +PR curve and the ROC curve described above is that precision does not assess +true negatives but false positives. In case the number of negative instances +greatly exceeds the number of positive instances, a large change in the number +of false positives reduces the ROC curve somewhat, but this change is far easier +observed in the PR curve [@Davis2006-xb]. Hence the PR curve is commonly +assessed if the positive class is more important than and rarer compared to the +negative class. For the ischemic stroke dataset, the precision-recall curve is as +follows: + + +``` r +plots <- familiar::plot_auc_precision_recall_curve( + object = ischemic_stroke_model, + data = ischemic_stroke_data +) +``` +
+Precision-recall curve for the ischemic stroke model on hold-out +test data. The 95% confidence interval is shown (grey). +

Precision-recall curve for the ischemic stroke model on hold-out +test data. The 95% confidence interval is shown (grey).

+
+ +Under ideal circumstances, the curve would lie in the top-right part of the +plot. A random classifier would yield a curve that is mostly horizontal and +located at the fraction of positive instances. This would equal a precision of +56% for the current dataset. + +Like the ROC curve, familiar forms the PR curve by ascendingly sorting instances +by the predicted probability of the positive class and computing the number of +true positive and false positive negative cases observed at each instance. These +values are then used to compute recall and precision. + +The above plot shows the average of 400 single curves, with 95% confidence +intervals. To achieve this, familiar interrogates each curve over the complete +range of recall values ([0.000, 1.000]) with a step size of 0.005. We use +linear interpolation for this purpose, treating the PR curve as a piecewise +function to manage the situation identified by Davis and Goadrich +[@Davis2006-xb]. Interpolating in this manner allows for assessing the +distribution of precision values at fixed recall values. + +Again, this is the general approach used by familiar. Familiar can plot an exact +PR curve when evaluating the point estimate (`estimation_type="point"`) of a +single model or of the complete ensemble of models (`detail_level="ensemble"`). +In the ischemic strok dataset, this produces the following curve: + + +``` r +plots <- familiar::plot_auc_precision_recall_curve( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + estimation_type = "point" +) +``` +
+Precision-recall curve for the ischemic stroke + model on hold-out test data. Whereas the previous figure shows the bootstrap + estimate and confidence interval, the current curve is formed + directly from the data. +

Precision-recall curve for the ischemic stroke + model on hold-out test data. Whereas the previous figure shows the bootstrap + estimate and confidence interval, the current curve is formed + directly from the data.

+
+ +## Confusion matrix + +A confusion matrix schematically represents the number of predicted (expected) +class instances and their actual (observed) values. This may help identify +potential weaknesses of classifiers, i.e. false positives or negatives. + + +``` r +plots <- familiar::plot_confusion_matrix( + object = ischemic_stroke_model, + data = ischemic_stroke_data +) +``` +
+Confusion matrix for the ischemic stroke + model on hold-out test data. The number of instances with the prediction + of ischemic stroke (expected sroke), and actually observed stroke, is shown. +

Confusion matrix for the ischemic stroke + model on hold-out test data. The number of instances with the prediction + of ischemic stroke (expected sroke), and actually observed stroke, is shown.

+
+ +Familiar selects the class with the highest predicted class probability as the +expected class. It is currently not possible in familiar to obtain confusion +matrices for set probability thresholds, such as the threshold that maximises +the Youden's Index. + +## Kaplan-Meier survival curves + +Kaplan-Meier survival curves are a standard method for assessing survival over time in +a population, or for assessing survival differences between groups. + +Familiar applies one or more thresholds to stratify instances to risk groups. +These thresholds are created during training to avoid bias. The number +and value of these thresholds is determined by two parameters: +`stratification_method` and `stratification_threshold`. Both parameters are set +when calling `summon_familiar` or `train_familiar`. +`stratification_method` has three options: + +- `median`: Familiar uses the median predicted value in the development cohort +to stratify instances into two risk groups. + +- `fixed`: Instances are stratified based on the sample quantiles of the +predicted values. These quantiles are defined using the +`stratification_threshold` parameter. + +- `optimised`: Use maximally selected rank statistics to determine the optimal +threshold [@Lausen1992-qh; @Hothorn2003-qn] to stratify instances into two +optimally separated risk groups. + +The `stratification_threshold` parameter is only used when +`stratification_method = "fixed"`. It allows for specifying the sample quantiles +that are used to determine the thresholds. For example +`stratification_threshold = c(0.25,0.75)` creates two thresholds that stratifies +the development dataset into three groups: one with 25% of the instances with +the highest risk, a group with 50% of the instances with medium risk, and a +third group with 25% of instances with lowest risk. + +Applying the survival model to the colon cancer dataset yields the following +Kaplan-Meier plot: + + +``` r +plots <- familiar::plot_kaplan_meier( + object = survival_model, + data = survival_data +) +``` +
+Kaplan-Meier plot for the colon cancer survival model on hold-out + test data. The hold-out test data were split into two risk groups by + applying a threshold that was defined during training. 95% confidence + intervals are shown. The number of patients surviving without tumour recurrence + is shown below the main plot. +

Kaplan-Meier plot for the colon cancer survival model on hold-out + test data. The hold-out test data were split into two risk groups by + applying a threshold that was defined during training. 95% confidence + intervals are shown. The number of patients surviving without tumour recurrence + is shown below the main plot.

+
+ +In the plot above, familiar divides instances into two groups by the median +threshold in the development dataset. The risk groups are shown with 95% +confidence intervals. Familiar uses the `survival::survfit` function to create +both the survival curves and the confidence intervals. The low-risk group has +significantly better survival than the high-risk group. This is also indicated +in the bottom-left of the main plot, which shows the result of a logrank test +between the two groups. Crosses indicate right-censored patients, of which there +were few. The number of surviving patients in both groups at the time points +along the x-axis are shown below the main plot. + +# Model calibration + +Evaluating model performance is important as it allows us to assess how +accurate a model is. However, it often does not tell us how well we can rely on +predictions for individual instances, e.g. how accurate an instance class +probability is. Model calibration is assessed for this purpose. The model for +the ischemic stroke dataset produces the following calibration plot: + + +``` r +plots <- familiar::plot_calibration_data( + object = ischemic_stroke_model, + data = ischemic_stroke_data +) +``` +
+Calibration plot for the ischemic stroke model on hold-out + test data. The plot shows the predicted (expected) probability of ischemic + stroke, against the observed occurrence within smaller groupings of data. + The plot shows the ideal calibration (dashed line), the linear calibration + fit (thin line), and estimated calibration (thick line). 95% confidence + intervals, based on bootrstraps, are shown around the estimated calibration. + The line above the plot shows the density of predicted probabilities. + Calibration outside the main distribution is more uncertain. The inset + describes the intercept and slope of the linear fit, and the results + of the Hosmer-Lemeshow goodness-of-fit test. +

Calibration plot for the ischemic stroke model on hold-out + test data. The plot shows the predicted (expected) probability of ischemic + stroke, against the observed occurrence within smaller groupings of data. + The plot shows the ideal calibration (dashed line), the linear calibration + fit (thin line), and estimated calibration (thick line). 95% confidence + intervals, based on bootrstraps, are shown around the estimated calibration. + The line above the plot shows the density of predicted probabilities. + Calibration outside the main distribution is more uncertain. The inset + describes the intercept and slope of the linear fit, and the results + of the Hosmer-Lemeshow goodness-of-fit test.

+
+ +The calibration curve shows the expected (predicted) probability of ischemic +stroke versus the observed proportion of ischemic stroke, together with a 95% +confidence interval. In an ideal calibration plot the calibration curve should +lie on the diagonal (dashed) line. Low expected probabilities tend to +overestimate the observed probability, whereas high expected probabilities tend +to underestimate the observed probability. The density plot in the top panel +indicates that predicted probabilities were distributed around 0.5, with +relatively few low- and high-probability cases being predicted. + +Familiar also performs several calibration tests to assess various degrees of +calibration [@Van_Calster2016-ok]. First of all, we assess two aspects of the +linear fit (solid line in the plot): the intercept (calibration-in-the-large) +and slope. These are shown in the top-left of the main plot. + +The intercept ideally is 0.00. In our example, it lies below this point, but is +still contained in the 95% confidence interval, owing to a small number of +samples in the test set. + +In an ideal case, the slope of the linear fit is 1.00. In our example, the slope +of the linear fit lies above this value. + +One issue with assessing calibration through a linear fit, is that the +calibration curve can be decidedly non-linear and still produce good values for +the intercept and slope. Therefore, we also assess calibration using statistical +goodness-of-fit tests: the Hosmer-Lemeshow (HL) test for categorical and +regression outcomes [@Hosmer1997-ov], and the Nam-D'Agostino (ND) +[@DAgostino2003-ot] and Greenwood-Nam-D'Agostino (GND) [@Demler2015-yx] tests +for survival outcomes. + +## Implementation details + +Here we detail the implementation of the model calibration in familiar. The +statistical tests mentioned above, as well as the linear fit, rely on grouping +instances. First we order the instances in the dataset by their expected +(predicted) values. Within each group, the expected values and observed values +are compared: + +* Categorical outcomes: We compare the fraction instances with the (positive) +observed class in the group against the mean expected probability for that same +class. + +* Regression outcomes: Both expected and observed values are first normalised to +a $[0, 1]$ range using the value range observed in the development dataset. We +then compare the mean observed value in the group against the mean expected +value. + +* Survival outcomes: We predict survival probabilities at time points indicated +by `evaluation_times`. The mean expected survival probability in the group is +then compared against the observed probability (Kaplan-Meier estimator) at the +same time points. + +We can observe the points thus created in a calibration plot when +`estimation_type="point"`: + + +``` r +plots <- familiar::plot_calibration_data( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + estimation_type = "point" +) +``` +
+Calibration plot for the ischemic stroke model on hold-out + test data. Whereas in the earlier figure the calibration curve was the + bootstrap estimate, here the expected probability and observed proportions + in several (random) groupings is shown. +

Calibration plot for the ischemic stroke model on hold-out + test data. Whereas in the earlier figure the calibration curve was the + bootstrap estimate, here the expected probability and observed proportions + in several (random) groupings is shown.

+
+ +The plot with point estimates and the earlier calibration plot with bootstrap +confidence intervals lead to the same assessment. Moreover, you may not arrive +at the same plot. This happens because familiar introduces randomness into the +assessment of calibration. First, familiar randomises the number of groups drawn +because using a fixed number of 10 groups is arbitrary. Second, the actual group +sizes are randomised by drawing group identifiers with replacement for all +instances. We then sort the set of drawn identifiers, and the instances, ordered +by increasing expected value, are then assigned to their respective group. + +Linear fit intercept and slope as well as the goodness-of-fit test p-value are +determined for each single set of groups. Intercept and slopes are then averaged +(`point` and `bias_correction`) or assessed as a distribution +(`bootstrap_confidence_interval`). p-values from goodness-of-fit tests need to +be combined. These tests are not fully independent because they derive from the +same dataset. We therefore compute a harmonic mean p-value [@Wilson2019-bi] from +the individual p-values. + +# Decision curve analysis + +Decision curve analysis is a method to assess the net (clinical) benefit of +models, introduced by Vickers and Elkin [@Vickers2006-be]. The decision curve +compares the model benefit for different threshold probabilities against two or +more options. The two standard options are that all instances receive an +intervention, and none receive an intervention. What constitutes an intervention +is model-dependent [@Vickers2019-ar]. For our ischemic stroke cohort, intervention +might constitute treatment of all patients, versus no treatment and treatment for +patients with malignancy predicted by the model. This produces the following +figure: + + +``` r +plots <- familiar::plot_decision_curve( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + y_range = c(-0.2, 0.8) +) +``` + +``` +#> Error in `ggplot2::geom_line()`: +#> ! Problem while converting geom to grob. +#> ℹ Error occurred in the 1st layer. +#> Caused by error: +#> ! (converted from warning) Removed 33 rows containing missing values or values outside the scale range (`geom_line()`). +``` + +The shaded curve is the decision curve produced by the model, with 95% +confidence intervals. The declining curve represents the intervention for all +strategy, which offers no benefit for a probability of ischemic stroke of 56%. +The horizontal line at a net benefit of 0.0 represent the no intervention +strategy. As may be observed, the model offers an expected net benefit compared +to either strategy, but not always significantly. + +For regression problems no definition of decision curves exists. However, +familiar can perform decision curve analysis for survival outcomes, based on +Vickers et al. [@Vickers2008-uu]. + +# Variable importance + +Not all features are strongly associated with the outcome of interest. One of +the most critical points in machine learning is selecting those features that +are important enough to incorporate into a model. Familiar assesses variable +importance using the methods detailed in the *Variable importance methods* +vignette during training. Later, during evaluation, familiar employs both +model-specific and model-agnostic methods to explaining which features are +considered important by the model itself. + +## Model-specific methods + +Model-specific methods rely on aspects of the models themselves to determine +variable importance. For instance, the coefficients of regression models are a +measure of variable importance when features are normalised. In the case of the +random forest model for the ischemic stroke dataset, permutation variable +importance is determined. This produces the following plot: + + +``` r +plots <- familiar::plot_model_signature_variable_importance( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + rotate_x_tick_labels = TRUE +) +``` + +``` +#> Error in `ggplot2::geom_bar()`: +#> ! Problem while converting geom to grob. +#> ℹ Error occurred in the 1st layer. +#> Caused by error: +#> ! (converted from warning) Removed 13 rows containing missing values or values outside the scale range (`geom_bar()`). +``` +In such plots, we always order features so that the most important features are +on the left, and the least important features on the right. Letters indicate +features that are clustered together. + +In case an ensemble of models is assessed, scores are aggregated using an +aggregation method (see the *variable importance methods* vignette). This method +can be set using the `aggregation_method` argument, or the +`eval_aggregation_method` configuration parameter (`summon_familiar`). + +The `plot_model_signature_occurrence` method plots the occurrence of features +among the first 5 ranks across an ensemble of models (if available). The rank +threshold can be specified using the `rank_threshold` argument or the +`eval_aggregation_rank_threshold` parameter (`summon_familiar`). + +## Permutation variable importance + +Permutation variable importance is a model-agnostic variable importance method. +It assesses importance by measuring the decrease in model performance caused by +shuffling values of a feature across the instances in a dataset. + +For the ischemic stroke dataset, this results in the following figure: + + +``` r +plots <- familiar::plot_permutation_variable_importance( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + estimation_type = "bias_correction" +) +``` +
+Permutation variable importance plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom). + Permutation variable importance measures the model performance difference + between normal and shuffled (informationless) input values for each feature. + At the threshold of 1.00 every feature is shuffled individually, whereas at 0.23 + groups of similar features are shuffled simultaneously. +

Permutation variable importance plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom). + Permutation variable importance measures the model performance difference + between normal and shuffled (informationless) input values for each feature. + At the threshold of 1.00 every feature is shuffled individually, whereas at 0.23 + groups of similar features are shuffled simultaneously.

+
+ +The figure shows the features along the y-axis, and the loss in AUC-ROC caused +by permuting the feature values along the x-axis. Accordingly, +`max_remodeling_ratio` is considered to be the most important feature in the +model. + +The figure shows two bars for each feature. A well-known issue with permutation +variable importance is that the presence of highly correlated features causes +permutation variable importance to become unreliable [@Hooker2019-pv]. If two +features are both important and highly correlated, shuffling one of them does +not decrease model performance as much. For this reason, familiar will permute +features together depending on their mutual correlation, and the provided +threshold values. + +By default, similarity between features is assessed using McFadden's +pseudo-$R^2$. This metric can assess similarity between different types of +features, i.e. numeric and categorical. The default thresholds are 0.23 and 1.0 +that respectively cluster similar features and permute all features +individually. The dataset contains many features that are highly +similar and exceed the relatively stringent threshold of 0.23. + +## SHAP summary plots + +A SHAP value is the marginal contributions of a feature value to the predicted +value. For example, if you were to predict the number of daily ice cream sales, +season could be a feature. A SHAP value for the summer season is likely +positive, whereas the SHAP value for the winter season would likely be negative. +Important features have larger SHAP values than less important features. Thus +a SHAP summary plot can be used to evaluate feature importance. + + +``` r +plots <- familiar::plot_shap_summary( + object = ischemic_stroke_model, + data = ischemic_stroke_data +) +``` +
+SHAP summary plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom), + based on SHAP values. Each point represents the marginal contribution + of a feature value to the predicted probability of the model, and is coloured + according to its (normalised) feature value. +

SHAP summary plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom), + based on SHAP values. Each point represents the marginal contribution + of a feature value to the predicted probability of the model, and is coloured + according to its (normalised) feature value.

+
+ +The SHAP summary plot shows several things: features are listed along the +y-axis, with the most important feature on top, i.e. the feature that has the +highest mean absolute SHAP value. Each point corresponds to the value in an +instance (a patient), and each point is coloured according to its (normalised) +value. For the purpose of representation, all feature values are mapped to the +[-1.0, 1.0] range. + +The default presentation might provide too much detail. It is therefore possible +to change the `plot_type` or `value_representation`. For example, +the above data could be presented as violin plots: + + +``` r +plots <- familiar::plot_shap_summary( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + plot_type = "violinplot" +) +``` +
+SHAP summary plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom), + based on SHAP values. The distribution of SHAP values for each feature + is shown as a violin plot. +

SHAP summary plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom), + based on SHAP values. The distribution of SHAP values for each feature + is shown as a violin plot.

+
+ +The violin plot shows the distribution of values more clearly, at the cost +of losing information concerning underlying feature values. + +If just variable importance is relevant, the SHAP summary plot can also be shown +as a bar plot (`plot_type = "barplot"`) showing the mean absolute SHAP value by +default (`value_representation = "abs_mean"`): + + +``` r +plots <- familiar::plot_shap_summary( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + value_representation = "abs_mean" +) +``` +
+SHAP summary plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom), + based on the mean of the absolute SHAP values in the underlying data. +

SHAP summary plot for the ischemic stroke model on hold-out + test data. Features are sorted from highest (top) to least importance (bottom), + based on the mean of the absolute SHAP values in the underlying data.

+
+ +# Feature effects + +Variable importance does not explain how features influence the model, although +the SHAP summary plot already provided some hints. Familiar offers multiple +methods for assessing the effect of features. + +## Partial dependence and individual conditional expectation plots + +Partial dependence (PD) [@Friedman2001-jf] and individual conditional +expectation (ICE) [@Goldstein2015-rv] plots can be used to visualise how +features influence the model. As an example, we can create an ICE plot for the +`max_remodeling_ratio` feature that was found to be important for predicting +ischemic stroke. + + +``` r +plots <- familiar::plot_ice( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + features = "max_remodeling_ratio" +) +``` +
+Individual conditional expectation plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each curve follows the predicted probability for an instance where only + the value of the max_remodeling_ratio is changed. The thick line corresponds to + the average of all individual curves, i.e. partial dependence. High novelty scores + signify values that are more likely to be outliers. +

Individual conditional expectation plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each curve follows the predicted probability for an instance where only + the value of the max_remodeling_ratio is changed. The thick line corresponds to + the average of all individual curves, i.e. partial dependence. High novelty scores + signify values that are more likely to be outliers.

+
+ +The ICE plot shows multiple curves for individual samples, as well as their +average, the partial dependence plot as a somewhat thicker curve. These curves +are created by iteratively updating the value of `max_remodeling_ratio` and then +observing the predicted outcome. To generate the sample points, familiar samples +the feature value distribution, as observed in the training dataset, at regular +percentile intervals. Also note that by default, ICE plots only show a limited +number of samples to prevent clutter. This can be specified through +`n_max_samples_shown`. + +The plot also shows novelty, which is a measure of how out-of-distribution the value +is. Novelty is computed using extended isolation forests [@Hariri2019-xz] and is +the average normalised height at which a sample is found in a terminal leaf node +of the trees in the isolation forest [@Liu2008-kw]. Novelty values range between +`0.00` and `1.00`. Novelty values should be interpreted with care. While increasing +novelty values represent instances that lie further from the distribution, the +values that represent in-distribution instances may vary. In the ICE plot above, +novelty values range between `0.40` and `0.50`. None of the points in ICE plot +can therefore be considered out-of-distribution. Move to a conformal prediction +framework is planned for future versions. + +It is possible to anchor the curves in the ICE plot to a specific feature value. +This allows for assessing the model response for individual instances versus a +fixed value. In effect this can reduce some of the offset caused by other +(fixed) features in each instance, and may help to elucidate the observed +behaviour: + + +``` r +plots <- familiar::plot_ice( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + features = "max_remodeling_ratio", + anchor_values = list("max_remodeling_ratio" = 2.5) +) +``` +
+Individual conditional expectation plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each curve follows the predicted probability for an instance where only + the value of the max_remodeling_ratio is changed. This curve was anchored at + max_remodeling_ratio=2.5, i.e. at this value, every curve has a (relative) + predicted probability of 0.0. The thick line corresponds to the average of all + individual curves, i.e. partial dependence. High novelty scores + signify values that are more likely to be outliers. +

Individual conditional expectation plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each curve follows the predicted probability for an instance where only + the value of the max_remodeling_ratio is changed. This curve was anchored at + max_remodeling_ratio=2.5, i.e. at this value, every curve has a (relative) + predicted probability of 0.0. The thick line corresponds to the average of all + individual curves, i.e. partial dependence. High novelty scores + signify values that are more likely to be outliers.

+
+ +In the plot above, we have anchored the values at `max-remodeling-ratio = 2.5`. +All curves are then drawn relative to the predicted probability found for this +particular value. + +It is also possible to show the partial dependence of two features at the same +time: + + +``` r +plots <- familiar::plot_ice( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + features = c("max_remodeling_ratio", "coronary_artery_disease") +) +``` +
+Partial depence plot for the max_remodeling_ratio and coronary_artery_disease + features in the ischemic stroke model using instances from the hold-out test data. + Individual curves are not shown for 2D plots. High novelty scores, + indicated by smaller points, signify values that are more likely to be outliers. +

Partial depence plot for the max_remodeling_ratio and coronary_artery_disease + features in the ischemic stroke model using instances from the hold-out test data. + Individual curves are not shown for 2D plots. High novelty scores, + indicated by smaller points, signify values that are more likely to be outliers.

+
+ + +The partial dependence plot above shows `max_remodeling_ratio` along the x-axis +and `coronary_artery_disease` along the y-axis. Higher intensities are +associated with a higher expected probability of malignancy. The figure thus +indicates that higher values of `max_remodeling_ratio` clearly affect the +predicted probability of ischemic stroke. The presence of +`coronary_artery_disease` can be seen to decrease the probability of ischemic +stroke - probably because these patients arrived at the hospital due to this +condition, not necessarily cerebral stroke. The average novelty score of the +underlying instances determines the size of each point. + +It also possible to anchor 2D partial dependence plots: + + +``` r +plots <- familiar::plot_ice( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + features = c("max_remodeling_ratio", "coronary_artery_disease"), + anchor_values = list( + "max_remodeling_ratio" = 2.5, + "coronary_artery_disease" = "no" + ), + show_novelty = FALSE +) +``` +
+Partial depence plot for the max_remodeling_ratio and coronary_artery_disease + features in the ischemic stroke model using instances from the hold-out test data. + Without novelty, elements are shown as rectangles to better show probability. + Moreover, probabilities were anchored at max_remodeling_ratio = 2.5, and + coronary_artery_disease = no. Individual curves are not shown for 2D plots. +

Partial depence plot for the max_remodeling_ratio and coronary_artery_disease + features in the ischemic stroke model using instances from the hold-out test data. + Without novelty, elements are shown as rectangles to better show probability. + Moreover, probabilities were anchored at max_remodeling_ratio = 2.5, and + coronary_artery_disease = no. Individual curves are not shown for 2D plots.

+
+ +We disabled novelty (`show_novelty=FALSE`) for plotting the 2D anchored plot. +This changes the appearance of the plot, which now consists of coloured +rectangles. The white dots show the position at which familiar samples the +feature values. + +Familiar automatically determines the values at which numerical features are +sampled based on their distribution in the development dataset. Such values can +also be manually set using the `feature_x_range` and `feature_y_range` +arguments. + +## SHAP dependence plots + +SHAP dependence plots function similar to dependence plots. The SHAP dependence +plot below shows how the SHAP values of `max_remodeling_ratio` are related +to its feature values. + + +``` r +plots <- familiar::plot_shap_dependence( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + shap_feature = "max_remodeling_ratio" +) +``` +
+SHAP dependence plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. +

SHAP dependence plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data.

+
+The above plot shows that with increasing value of `max_remodeling_ratio`, the +marginal contribution to the prediction changes from negative (low values +decrease the probability of the ischemic stroke) to positive (high values +increase the probability of the ischemic stroke). + +SHAP dependence plots can also show interaction with other features. For +example, we can show the interaction with the `coronary_artery_disease` +feature. + + +``` r +plots <- familiar::plot_shap_dependence( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + shap_feature = "max_remodeling_ratio", + interaction_feature = "coronary_artery_disease" +) +``` +
+SHAP dependence plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each point shows the corresponding value for coronary_artery_disease. +

SHAP dependence plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each point shows the corresponding value for coronary_artery_disease.

+
+The addition of an interaction feature does not alter the shape of the plot, but +now individual values are coloured by the value of the `coronary_artery_disease` +feature for the same sample. It appears that `coronary_artery_disease` is not +strongly interacting with `max_remodeling_ratio`. + + +``` r +plots <- familiar::plot_shap_dependence( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + shap_feature = "max_remodeling_ratio", + interaction_feature = "max_dilation_by_area" +) +``` +
+SHAP dependence plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each point shows the corresponding value for max_dilation_by_area. +

SHAP dependence plot for the max_remodeling_ratio feature + in the ischemic stroke model using instances from the hold-out test data. + Each point shows the corresponding value for max_dilation_by_area.

+
+The `max_dilation_by_area` feature, however, is much more strongly correlated, +as shown in the SHAP dependence plot above. + +## SHAP force plots + +SHAP force plots show the *force* exerted by features for individual samples. +Samples are (by default) ordered by increasing predicted value, and the +positive and negative marginal contributions are shown for each sample. + + +``` r +plots <- familiar::plot_shap_force( + object = ischemic_stroke_model, + data = ischemic_stroke_data +) +``` +
+SHAP force plot for the ischemic stroke model using all instances + from the hold-out test data. The force plot show the stacked positive and + negative marginal contributions for all features. +

SHAP force plot for the ischemic stroke model using all instances + from the hold-out test data. The force plot show the stacked positive and + negative marginal contributions for all features.

+
+Force plots are not highly informative. However, one can set one or more highlight +features. For example, setting `max_remodeling_ratio` as a highlight yields the +following figure: + + +``` r +plots <- familiar::plot_shap_force( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + highlight_feature = "max_remodeling_ratio" +) +``` +
+SHAP force plot for the ischemic stroke model using all instances + from the hold-out test data. The force plot show the stacked positive and + negative marginal contributions for all features. The contributions by + the max_remodeling_ratio feature are highlighted. +

SHAP force plot for the ischemic stroke model using all instances + from the hold-out test data. The force plot show the stacked positive and + negative marginal contributions for all features. The contributions by + the max_remodeling_ratio feature are highlighted.

+
+ +## SHAP waterfall plots + +SHAP waterfall plots show how SHAP values for each feature value contribute to +the predicted value for an individual sample. + + +``` r +plots <- familiar::plot_shap_waterfall( + object = ischemic_stroke_model, + data = ischemic_stroke_data +) +``` +
+SHAP waterfall plot for the ischemic stroke model for a single sample + from the hold-out test data. The waterfall plot shows the marginal + contributions of each feature for a sample. Features with the largest + contributions are shown at the top. +

SHAP waterfall plot for the ischemic stroke model for a single sample + from the hold-out test data. The waterfall plot shows the marginal + contributions of each feature for a sample. Features with the largest + contributions are shown at the top.

+
+The above plot shows a waterfall plot for the first sample, which has a +predicted value of $0.43$, where the average predicted value in +`ischemic_stroke_data` (i.e. the hold-out test set that we initially defined) is +$0.54$. Feature values are shown on the left, and all features are ordered by +the magnitude of their corresponding SHAP value. + +# Feature and sample similarity + +Highly similar features can carry redundant information for a model. This can be +visualised using similarity heatmaps: + + +``` r +plots <- familiar::plot_feature_similarity( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + feature_similarity_metric = "spearman", + rotate_x_tick_labels = TRUE +) +``` +
+Feature similarity heatmap for features used in the ischemic + stroke model. Similarity is computed using Spearman's rank correlation + coefficient. Features are clustered by similarity, with strongly (anti-)correlated + features being grouped together more closely. +

Feature similarity heatmap for features used in the ischemic + stroke model. Similarity is computed using Spearman's rank correlation + coefficient. Features are clustered by similarity, with strongly (anti-)correlated + features being grouped together more closely.

+
+ +Because we specify `feature_similarity_metric = "spearman"` the heatmap displays +Spearman's correlation coefficient between the different features (even +categorical ones). The features are also ordered by similarity, so that clusters +of similar features can be identified. Note that the dendrograms depict cluster +distance, i.e. $1-|\rho|$ for Spearman's correlation coefficient. + +It is also possible to view the sample clustering. This can be used to identify +if samples are readily stratified into clusters, which may or may not correlate +to the endpoint of interest. For the ischemic stroke dataset, this yields the +following heatmap: + + +``` r +plots <- familiar::plot_sample_clustering( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + feature_similarity_metric = "spearman", + rotate_x_tick_labels = TRUE +) +``` +
+Sample similarity heatmap of samples in the hold-out test set based on + features used in the ischemic stroke model. Similarity between features is + computed using Spearman's rank correlation coefficient, whereas similarity + between samples is computed using Gower's distance. Strongly (anti-)correlated + features and samples being grouped together more closely, respectively. + Feature values are normalised. +

Sample similarity heatmap of samples in the hold-out test set based on + features used in the ischemic stroke model. Similarity between features is + computed using Spearman's rank correlation coefficient, whereas similarity + between samples is computed using Gower's distance. Strongly (anti-)correlated + features and samples being grouped together more closely, respectively. + Feature values are normalised.

+
+ +The sample clustering figure shows an absence of clear structure among the +samples, nor a clear ordering of features with their observed class label +(ischemic stroke). The top dendrogram is the same as for feature clustering, as +it should be. The right dendrogram is formed after computing Gower's distance +between samples (by default), and shows clustering of samples. The heatmap +itself shows normalised values for the features, based on normalisation and +transformation parameters obtained during model development. + +Normalisation options can be altered by changing the `show_normalised_data` +argument. However, in the ischemic stroke dataset features do not have the same +value ranges, so without normalisation the figure looks less interpretable: + + +``` r +plots <- familiar::plot_sample_clustering( + object = ischemic_stroke_model, + data = ischemic_stroke_data, + feature_similarity_metric = "spearman", + show_normalised_data = "none", + rotate_x_tick_labels = TRUE +) +``` +
+Sample similarity heatmap of samples in the hold-out test set based on + features used in the ischemic stroke model. Similarity between features is + computed using Spearman's rank correlation coefficient, whereas similarity + between samples is computed using Gower's distance. Strongly (anti-)correlated + features and samples being grouped together more closely, respectively. + Feature values were not normalised (for plotting), and are coloured according to + their actual value. +

Sample similarity heatmap of samples in the hold-out test set based on + features used in the ischemic stroke model. Similarity between features is + computed using Spearman's rank correlation coefficient, whereas similarity + between samples is computed using Gower's distance. Strongly (anti-)correlated + features and samples being grouped together more closely, respectively. + Feature values were not normalised (for plotting), and are coloured according to + their actual value.

+
+ +# References diff --git a/vignettes/familiar.svg b/vignettes/familiar.svg index fb710ee3..c377ec36 100644 --- a/vignettes/familiar.svg +++ b/vignettes/familiar.svg @@ -1,12 +1,5 @@ image/svg+xml + inkscape:current-layer="layer1" + inkscape:document-rotation="0" + inkscape:showpageshadow="0" + inkscape:pagecheckerboard="0" + inkscape:deskcolor="#d1d1d1" />