diff --git a/fuseMLR-report.html b/fuseMLR-report.html new file mode 100644 index 0000000..c287c7d --- /dev/null +++ b/fuseMLR-report.html @@ -0,0 +1,25065 @@ + + +
+ + + + + + + + + + + + + + + + + + + + + + + +1 | ++ |
+ #' @title NewData Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements [NewData] object to be predicted.+ |
+
5 | ++ |
+ #' A [NewData] object can only exist as a component of a [NewLayer] or a [NewMetaLayer] object.+ |
+
6 | ++ |
+ #' @export+ |
+
7 | ++ |
+ #' @importFrom R6 R6Class+ |
+
8 | ++ |
+ #' @seealso [TrainData]+ |
+
9 | ++ |
+ NewData <- R6Class("NewData",+ |
+
10 | ++ |
+ inherit = Data,+ |
+
11 | ++ |
+ public = list(+ |
+
12 | ++ |
+ #' @description+ |
+
13 | ++ |
+ #' Initialize a new object from the current class.+ |
+
14 | ++ |
+ #'+ |
+
15 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
16 | ++ |
+ #' Object ID.+ |
+
17 | ++ |
+ #' @param ind_col (`character(1)`)\cr+ |
+
18 | ++ |
+ #' Column name containing individual IDs.+ |
+
19 | ++ |
+ #' @param data_frame (`data.frame(1)`)\cr+ |
+
20 | ++ |
+ #' \code{data.frame} containing data.+ |
+
21 | ++ |
+ #' @param new_layer (`NewLayer(1)`) \cr+ |
+
22 | ++ |
+ #' Layer where to store the current object.+ |
+
23 | ++ |
+ initialize = function (id,+ |
+
24 | ++ |
+ data_frame,+ |
+
25 | ++ |
+ new_layer) {+ |
+
26 | +! | +
+ ind_col = new_layer$getNewStudy()$getIndCol()+ |
+
27 | +! | +
+ if (!(ind_col %in% colnames(data_frame))) {+ |
+
28 | +! | +
+ stop("Individual column IDS not found in the provided data.frame.")+ |
+
29 | ++ |
+ }+ |
+
30 | +! | +
+ if (!any(c("NewLayer", "NewMetaLayer") %in% class(new_layer))) {+ |
+
31 | +! | +
+ stop("A Newdata can be stored only on a NewLayer or a NewMetaLayer object.")+ |
+
32 | ++ |
+ }+ |
+
33 | +! | +
+ super$initialize(id = id,+ |
+
34 | +! | +
+ ind_col = ind_col,+ |
+
35 | +! | +
+ data_frame = data_frame)+ |
+
36 | +! | +
+ if (new_layer$checkNewDataExist()) {+ |
+
37 | +! | +
+ stop(sprintf("Only one new data is allowed per new layer.\n The new data %s already exists on the new layer %s.\n",+ |
+
38 | +! | +
+ private$id,+ |
+
39 | +! | +
+ new_layer$getId()))+ |
+
40 | ++ |
+ }+ |
+
41 | +! | +
+ private$new_layer = new_layer+ |
+
42 | ++ |
+ # Add to object to ht+ |
+
43 | +! | +
+ if ("NewMetaLayer" %in% class(new_layer)) {+ |
+
44 | +! | +
+ if (new_layer$getAccess()) {+ |
+
45 | +! | +
+ new_layer$add2HashTable(key = private$id,+ |
+
46 | +! | +
+ value = self,+ |
+
47 | +! | +
+ .class = "NewData")+ |
+
48 | ++ |
+ } else {+ |
+
49 | +! | +
+ stop("New data cannot not be added manually to a meta layer.")+ |
+
50 | ++ |
+ }+ |
+
51 | ++ |
+ } else {+ |
+
52 | +! | +
+ new_layer$add2HashTable(key = private$id,+ |
+
53 | +! | +
+ value = self,+ |
+
54 | +! | +
+ .class = "NewData")+ |
+
55 | ++ |
+ }+ |
+
56 | ++ |
+ },+ |
+
57 | ++ |
+ #' @description+ |
+
58 | ++ |
+ #' Printer+ |
+
59 | ++ |
+ #' @param ... (any) \cr+ |
+
60 | ++ |
+ #'+ |
+
61 | ++ |
+ print = function (...) {+ |
+
62 | +! | +
+ cat("Class : NewData\n")+ |
+
63 | +! | +
+ cat(sprintf("Layer : %s\n", private$new_layer$id))+ |
+
64 | +! | +
+ cat(sprintf("name : %s\n", private$id))+ |
+
65 | +! | +
+ cat(sprintf("ind. id. : %s\n", private$ind_col))+ |
+
66 | +! | +
+ cat(sprintf("n : %s\n", nrow(private$data_frame)))+ |
+
67 | +! | +
+ cat(sprintf("p : %s\n", ncol(private$data_frame)))+ |
+
68 | ++ |
+ },+ |
+
69 | ++ |
+ #' @description+ |
+
70 | ++ |
+ #' Getter of the current \code{data.frame} wihtout individual+ |
+
71 | ++ |
+ #' ID variable.+ |
+
72 | ++ |
+ #'+ |
+
73 | ++ |
+ #' @return+ |
+
74 | ++ |
+ #' The \code{data.frame} without individual ID nor target variables is returned.+ |
+
75 | ++ |
+ #' @export+ |
+
76 | ++ |
+ #'+ |
+
77 | ++ |
+ getData = function () {+ |
+
78 | +! | +
+ tmp_data <- private$data_frame+ |
+
79 | +! | +
+ tmp_data[[private$ind_col]] <- NULL+ |
+
80 | +! | +
+ return(tmp_data)+ |
+
81 | ++ |
+ },+ |
+
82 | ++ |
+ #' @description+ |
+
83 | ++ |
+ #' Getter of the current layer.+ |
+
84 | ++ |
+ #'+ |
+
85 | ++ |
+ #' @return+ |
+
86 | ++ |
+ #' The layer (from class [NewLayer]) on which the current train data are stored+ |
+
87 | ++ |
+ #' is returned.+ |
+
88 | ++ |
+ #' @export+ |
+
89 | ++ |
+ #'+ |
+
90 | ++ |
+ getNewLayer = function () {+ |
+
91 | +! | +
+ return(private$new_layer)+ |
+
92 | ++ |
+ }+ |
+
93 | ++ |
+ ),+ |
+
94 | ++ |
+ private = list(+ |
+
95 | ++ |
+ # Current layer.+ |
+
96 | ++ |
+ new_layer = NULL+ |
+
97 | ++ |
+ ),+ |
+
98 | ++ |
+ cloneable = TRUE+ |
+
99 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Lrner Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements a learner. A [Lrner] object can only exist as a component of a+ |
+
5 | ++ |
+ #' [TrainLayer] or a [TrainMetaLayer] object.+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' @export+ |
+
8 | ++ |
+ #'+ |
+
9 | ++ |
+ #' @importFrom R6 R6Class+ |
+
10 | ++ |
+ Lrner <- R6Class("Lrner",+ |
+
11 | ++ |
+ public = list(+ |
+
12 | ++ |
+ #' @description+ |
+
13 | ++ |
+ #' Initialize a default parameters list.+ |
+
14 | ++ |
+ #'+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' Learner ID.+ |
+
17 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
18 | ++ |
+ #' Package that implements the learn function. If NULL, the+ |
+
19 | ++ |
+ #' learn function is called from the current environment.+ |
+
20 | ++ |
+ #' @param package (`character(1)`) \cr+ |
+
21 | ++ |
+ #' Learn function name.+ |
+
22 | ++ |
+ #' @param lrn_fct (`character(1)`) \cr+ |
+
23 | ++ |
+ #' Learn parameters.+ |
+
24 | ++ |
+ #' @param param (`ParamLrner(1)`) \cr+ |
+
25 | ++ |
+ #' Layer on which the learner is stored.+ |
+
26 | ++ |
+ #' @param train_layer (`TrainLayer(1)`) \cr+ |
+
27 | ++ |
+ #' The training layer where to store the learner.+ |
+
28 | ++ |
+ initialize = function (id,+ |
+
29 | ++ |
+ package = NULL,+ |
+
30 | ++ |
+ lrn_fct,+ |
+
31 | ++ |
+ param,+ |
+
32 | ++ |
+ train_layer) {+ |
+
33 | +1x | +
+ private$id = id+ |
+
34 | +1x | +
+ private$package = package+ |
+
35 | +1x | +
+ private$lrn_fct = lrn_fct+ |
+
36 | +1x | +
+ private$param = param+ |
+
37 | +1x | +
+ if (!any(c("TrainLayer", "TrainMetaLayer") %in% class(train_layer))) {+ |
+
38 | +! | +
+ stop("A Lrner can only belong to a TrainLayer or a TrainMetaLayer object.")+ |
+
39 | ++ |
+ }+ |
+
40 | +1x | +
+ if (train_layer$checkLrnerExist()) {+ |
+
41 | +! | +
+ stop(sprintf("Only one learner is allowed per training layer.\n The learner %s already exists on the training layer %s.\n",+ |
+
42 | +! | +
+ self$getId(),+ |
+
43 | +! | +
+ train_layer$getId()))+ |
+
44 | ++ |
+ }+ |
+
45 | +1x | +
+ private$train_layer = train_layer+ |
+
46 | ++ |
+ # Add to object to ht+ |
+
47 | +1x | +
+ train_layer$add2HashTable(key = private$id,+ |
+
48 | +1x | +
+ value = self,+ |
+
49 | +1x | +
+ .class = "Lrner")+ |
+
50 | ++ |
+ },+ |
+
51 | ++ |
+ #' @description+ |
+
52 | ++ |
+ #' Printer+ |
+
53 | ++ |
+ #' @param ... (any) \cr+ |
+
54 | ++ |
+ #'+ |
+
55 | ++ |
+ print = function (...) {+ |
+
56 | +! | +
+ cat(sprintf("Learner : %s\n", private$id))+ |
+
57 | +! | +
+ cat(sprintf("TrainLayer : %s\n", private$train_layer$getId()))+ |
+
58 | +! | +
+ cat(sprintf("Package : %s\n", private$package))+ |
+
59 | +! | +
+ cat(sprintf("Learn function : %s\n", private$lrn_fct))+ |
+
60 | +! | +
+ cat(sprintf("Param id : %s\n", private$param$id))+ |
+
61 | ++ |
+ },+ |
+
62 | ++ |
+ #' @description+ |
+
63 | ++ |
+ #' Printer+ |
+
64 | ++ |
+ #' @param ... (any) \cr+ |
+
65 | ++ |
+ #'+ |
+
66 | ++ |
+ summary = function (...) {+ |
+
67 | +! | +
+ cat(sprintf(" Learner : %s\n", private$id))+ |
+
68 | +! | +
+ cat(sprintf(" TrainLayer : %s\n", private$train_layer$getId()))+ |
+
69 | +! | +
+ cat(sprintf(" Package : %s\n", private$package))+ |
+
70 | +! | +
+ cat(sprintf(" Learn function : %s\n", private$lrn_fct))+ |
+
71 | +! | +
+ cat(sprintf(" Param id : %s\n", private$param$id))+ |
+
72 | ++ |
+ },+ |
+
73 | ++ |
+ #' @description+ |
+
74 | ++ |
+ #' Tains the current learner (from class [Lrner]) on the current training data (from class [TrainData]).+ |
+
75 | ++ |
+ #'+ |
+
76 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
77 | ++ |
+ #' Individual ID subset on which the training will be performed.+ |
+
78 | ++ |
+ #' @param use_var_sel `boolean(1)` \cr+ |
+
79 | ++ |
+ #' If TRUE, variable selection is performed before training.+ |
+
80 | ++ |
+ #'+ |
+
81 | ++ |
+ #' @return+ |
+
82 | ++ |
+ #' The resulting model, from class [Model], is returned.+ |
+
83 | ++ |
+ #' @export+ |
+
84 | ++ |
+ #'+ |
+
85 | ++ |
+ train = function (ind_subset = NULL, use_var_sel = FALSE) {+ |
+
86 | +1x | +
+ train_data = private$train_layer$getTrainData()+ |
+
87 | +! | +
+ if(private$train_layer$getId() != train_data$getTrainLayer()$getId()) {+ |
+
88 | +! | +
+ stop("Learner and data must belong to the same layer.")+ |
+
89 | ++ |
+ }+ |
+
90 | ++ |
+ # Train only on complete data+ |
+
91 | +! | +
+ train_data = train_data$clone(deep = FALSE)+ |
+
92 | +! | +
+ complete_data = train_data$getCompleteData()+ |
+
93 | +! | +
+ train_data$setDataFrame(data_frame = complete_data)+ |
+
94 | +! | +
+ if (is.null(private$package)) {+ |
+
95 | +! | +
+ lrn = private$lrn_fct+ |
+
96 | ++ |
+ } else {+ |
+
97 | +! | +
+ lrn = sprintf('%s::%s', private$package, private$lrn_fct)+ |
+
98 | ++ |
+ }+ |
+
99 | +! | +
+ lrn_param = private$param$getParamLrner()[1L, ]+ |
+
100 | +! | +
+ lrn_param = as.list(lrn_param)+ |
+
101 | ++ |
+ # Prepare training dataset: extract individual subset+ |
+
102 | +! | +
+ if (!is.null(ind_subset)) {+ |
+
103 | +! | +
+ train_data = train_data$getIndSubset(+ |
+
104 | +! | +
+ var_name = train_data$getIndCol(),+ |
+
105 | +! | +
+ value = ind_subset)+ |
+
106 | +! | +
+ private$ind_subset = ind_subset+ |
+
107 | ++ |
+ } else {+ |
+
108 | +! | +
+ private$ind_subset = "ALL"+ |
+
109 | ++ |
+ }+ |
+
110 | ++ |
+ # Prepare training dataset: extract variable subset+ |
+
111 | +! | +
+ if (use_var_sel) {+ |
+
112 | +! | +
+ var_sel_obj = private$train_layer$getVarSel()+ |
+
113 | +! | +
+ selected_var = var_sel_obj$getVarSubSet()+ |
+
114 | ++ |
+ # Reduce features if at least one variable has been selected.+ |
+
115 | +! | +
+ if (!is.null(selected_var)) {+ |
+
116 | +! | +
+ var_list = c(selected_var, train_data$getTargetName())+ |
+
117 | +! | +
+ train_data = train_data$getVarSubset(var_name = var_list)+ |
+
118 | +! | +
+ private$var_subset = selected_var+ |
+
119 | ++ |
+ } else {+ |
+
120 | +! | +
+ warning("No selected variable found, so all variables have been used for training.\n")+ |
+
121 | +! | +
+ private$var_subset = "ALL"+ |
+
122 | ++ |
+ }+ |
+
123 | ++ |
+ } else {+ |
+
124 | +! | +
+ private$var_subset = "ALL"+ |
+
125 | ++ |
+ }+ |
+
126 | +! | +
+ lrn_param$x = train_data$getData()+ |
+
127 | +! | +
+ lrn_param$y = train_data$getTargetValues()+ |
+
128 | +! | +
+ base_model = do.call(eval(parse(text = lrn)), lrn_param)+ |
+
129 | +! | +
+ model = Model$new(lrner = self,+ |
+
130 | +! | +
+ train_data = train_data,+ |
+
131 | +! | +
+ base_model = base_model,+ |
+
132 | +! | +
+ train_layer = private$train_layer)+ |
+
133 | +! | +
+ private$ind_subset = ind_subset+ |
+
134 | ++ |
+ # Update learner into the hash table+ |
+
135 | ++ |
+ # TODO: Maybe not needed bacause addressing by reference+ |
+
136 | +! | +
+ private$train_layer$add2HashTable(key = private$id,+ |
+
137 | +! | +
+ value = self,+ |
+
138 | +! | +
+ .class = "Lrner")+ |
+
139 | +! | +
+ return(model)+ |
+
140 | ++ |
+ },+ |
+
141 | ++ |
+ #' @description+ |
+
142 | ++ |
+ #' The current layer is returned.+ |
+
143 | ++ |
+ #'+ |
+
144 | ++ |
+ #' @return+ |
+
145 | ++ |
+ #' [TrainLayer] object.+ |
+
146 | ++ |
+ #' @export+ |
+
147 | ++ |
+ #'+ |
+
148 | ++ |
+ getTrainLayer = function () {+ |
+
149 | +! | +
+ return(private$train_layer)+ |
+
150 | ++ |
+ },+ |
+
151 | ++ |
+ #' @description+ |
+
152 | ++ |
+ #' Getter of the current learner ID.+ |
+
153 | ++ |
+ #'+ |
+
154 | ++ |
+ #' @return+ |
+
155 | ++ |
+ #' The current learner ID.+ |
+
156 | ++ |
+ #' @export+ |
+
157 | ++ |
+ #'+ |
+
158 | ++ |
+ getId = function () {+ |
+
159 | +! | +
+ return(private$id)+ |
+
160 | ++ |
+ },+ |
+
161 | ++ |
+ #' @description+ |
+
162 | ++ |
+ #' Getter of the learner package implementing the learn function.+ |
+
163 | ++ |
+ #'+ |
+
164 | ++ |
+ #' @return+ |
+
165 | ++ |
+ #' The name of the package implementing the learn function.+ |
+
166 | ++ |
+ #'+ |
+
167 | ++ |
+ #' @export+ |
+
168 | ++ |
+ #'+ |
+
169 | ++ |
+ getPackage = function () {+ |
+
170 | +! | +
+ return(private$package)+ |
+
171 | ++ |
+ },+ |
+
172 | ++ |
+ #' @description+ |
+
173 | ++ |
+ #' Getter of the learner package implementing the learn function.+ |
+
174 | ++ |
+ #'+ |
+
175 | ++ |
+ #' @return+ |
+
176 | ++ |
+ #' The name of the package implementing the learn function.+ |
+
177 | ++ |
+ #'+ |
+
178 | ++ |
+ getIndSubset = function () {+ |
+
179 | +! | +
+ return(private$ind_subset)+ |
+
180 | ++ |
+ },+ |
+
181 | ++ |
+ #' @description+ |
+
182 | ++ |
+ #' Getter of the learner package implementing the learn function.+ |
+
183 | ++ |
+ #'+ |
+
184 | ++ |
+ #' @return+ |
+
185 | ++ |
+ #' The name of the package implementing the learn function.+ |
+
186 | ++ |
+ #'+ |
+
187 | ++ |
+ getVarSubset = function () {+ |
+
188 | +! | +
+ return(private$ind_subset)+ |
+
189 | ++ |
+ }+ |
+
190 | ++ |
+ ),+ |
+
191 | ++ |
+ private = list(+ |
+
192 | ++ |
+ # ID field.+ |
+
193 | ++ |
+ id = character(0L),+ |
+
194 | ++ |
+ # Package defining the learner (like \code{ranger}).+ |
+
195 | ++ |
+ package = NULL,+ |
+
196 | ++ |
+ # Learn function name (like \code{ranger}).+ |
+
197 | ++ |
+ lrn_fct = NULL,+ |
+
198 | ++ |
+ # Parameters (from class [Param]) of the learn function.+ |
+
199 | ++ |
+ param = NULL,+ |
+
200 | ++ |
+ # Training layer (from class [TainLayer] or [TrainMetaLayer]) of the current learner.+ |
+
201 | ++ |
+ train_layer = NULL,+ |
+
202 | ++ |
+ # Individuals subset IDs.+ |
+
203 | ++ |
+ ind_subset = NULL,+ |
+
204 | ++ |
+ # Variable subset IDs.+ |
+
205 | ++ |
+ var_subset = NULL+ |
+
206 | ++ |
+ ),+ |
+
207 | ++ |
+ cloneable = FALSE+ |
+
208 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title TrainStudy Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class is the basic class of the present package. An object from this class+ |
+
5 | ++ |
+ #' is designed to contain multiple training layers, but only one meta training layer.+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' The Trainstudy class is structured as followed:+ |
+
8 | ++ |
+ #' * [TrainLayer]: Specific layer containing:+ |
+
9 | ++ |
+ #' - [Lrner]: Specific learner. This must be set by the user.+ |
+
10 | ++ |
+ #' - [TrainData]: Specific training dataset. This must be set up by the user.+ |
+
11 | ++ |
+ #' - [Model]: Specific model. This is set up by training the learner on the training data.+ |
+
12 | ++ |
+ #' * [TrainMetaLayer]: Basically a [TrainLayer], but with some specific properties.+ |
+
13 | ++ |
+ #' - [Lrner]: This is the meta learner, it must be set up by the user.+ |
+
14 | ++ |
+ #' - [TrainData]: Specific meta data. This is set up internally after cross-validation.+ |
+
15 | ++ |
+ #' - [Model]: Specific meta model. This is set up by training the learner on the training data.+ |
+
16 | ++ |
+ #'+ |
+
17 | ++ |
+ #' Use the function \code{train} to train a study and \code{predict} to predict+ |
+
18 | ++ |
+ #' a new study.+ |
+
19 | ++ |
+ #'+ |
+
20 | ++ |
+ #' @export+ |
+
21 | ++ |
+ #'+ |
+
22 | ++ |
+ #' @importFrom R6 R6Class+ |
+
23 | ++ |
+ #'+ |
+
24 | ++ |
+ #' @seealso [TrainLayer]+ |
+
25 | ++ |
+ TrainStudy <- R6Class("TrainStudy",+ |
+
26 | ++ |
+ inherit = HashTable,+ |
+
27 | ++ |
+ public = list(+ |
+
28 | ++ |
+ #' @description+ |
+
29 | ++ |
+ #' constructor+ |
+
30 | ++ |
+ #'+ |
+
31 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
32 | ++ |
+ #' @param ind_col (`character(1)`)+ |
+
33 | ++ |
+ #' Name of column of individuals IDS+ |
+
34 | ++ |
+ #' @param target (`character(1)`)+ |
+
35 | ++ |
+ #' Name of the target variable+ |
+
36 | ++ |
+ #' @seealso [NewStudy] and [PredictStudy]+ |
+
37 | ++ |
+ initialize = function (id, ind_col, target) {+ |
+
38 | +1x | +
+ super$initialize(id = id)+ |
+
39 | +1x | +
+ private$ind_col = ind_col+ |
+
40 | +1x | +
+ private$target = target+ |
+
41 | +1x | +
+ private$status = FALSE+ |
+
42 | ++ |
+ },+ |
+
43 | ++ |
+ #' @description+ |
+
44 | ++ |
+ #' Printer+ |
+
45 | ++ |
+ #'+ |
+
46 | ++ |
+ #' @param ... (any) \cr+ |
+
47 | ++ |
+ #'+ |
+
48 | ++ |
+ print = function (...) {+ |
+
49 | +! | +
+ nb_layers = length(private$hash_table)+ |
+
50 | +! | +
+ if (!private$status) {+ |
+
51 | +! | +
+ status = "Not trained"+ |
+
52 | ++ |
+ } else {+ |
+
53 | +! | +
+ status = "Trained"+ |
+
54 | ++ |
+ }+ |
+
55 | +! | +
+ cat(sprintf("TrainStudy : %s\n", private$id))+ |
+
56 | +! | +
+ cat(sprintf("Status : %s\n", status))+ |
+
57 | +! | +
+ cat(sprintf("Number of layers: %s\n", nb_layers))+ |
+
58 | +! | +
+ cat(sprintf("Layers trained : %s\n", private$nb_trained_layer))+ |
+
59 | ++ |
+ },+ |
+
60 | ++ |
+ #' @description+ |
+
61 | ++ |
+ #' Train each layer of the current Trainstudy.+ |
+
62 | ++ |
+ #'+ |
+
63 | ++ |
+ #' @param ind_subset (`character(1)`)\cr+ |
+
64 | ++ |
+ #' Subset of individuals IDs to be used for training.+ |
+
65 | ++ |
+ #' @param use_var_sel `boolean(1)` \cr+ |
+
66 | ++ |
+ #' If TRUE, selected variables available at each layer are used.+ |
+
67 | ++ |
+ #'+ |
+
68 | ++ |
+ #' @return+ |
+
69 | ++ |
+ #' Returns the object itself, with a model for each layer.+ |
+
70 | ++ |
+ #' @export+ |
+
71 | ++ |
+ #'+ |
+
72 | ++ |
+ #'+ |
+
73 | ++ |
+ trainLayer = function (ind_subset = NULL, use_var_sel = FALSE) {+ |
+
74 | +! | +
+ layers = self$getKeyClass()+ |
+
75 | +! | +
+ if (nrow(layers)) {+ |
+
76 | ++ | + + | +
77 | ++ |
+ # This code accesses each layer (except MetaLayer) level and trains the corres-+ |
+
78 | ++ |
+ # ponding learner.+ |
+
79 | +! | +
+ layers = layers[layers$class %in% "TrainLayer", ]+ |
+
80 | +! | +
+ for (k in layers$key) {+ |
+
81 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
82 | +! | +
+ layer$train(ind_subset = ind_subset,+ |
+
83 | +! | +
+ use_var_sel = use_var_sel)+ |
+
84 | ++ |
+ }+ |
+
85 | ++ |
+ } else {+ |
+
86 | +! | +
+ stop("No existing layer in the current training study.")+ |
+
87 | ++ |
+ }+ |
+
88 | +! | +
+ invisible(self)+ |
+
89 | ++ |
+ },+ |
+
90 | ++ |
+ #' @description+ |
+
91 | ++ |
+ #' Predicts values given new data.+ |
+
92 | ++ |
+ #'+ |
+
93 | ++ |
+ #' @param new_study (`NewData(1)`) \cr+ |
+
94 | ++ |
+ #' Object of class [NewData].+ |
+
95 | ++ |
+ #' @param ind_subset (`vector(1)`) \cr+ |
+
96 | ++ |
+ #' Subset of individuals IDs to be used for training.+ |
+
97 | ++ |
+ #'+ |
+
98 | ++ |
+ #' @return+ |
+
99 | ++ |
+ #' A new [TrainStudy] with predicted values for each layer.+ |
+
100 | ++ |
+ #' @export+ |
+
101 | ++ |
+ #'+ |
+
102 | ++ |
+ predictLayer = function (new_study,+ |
+
103 | ++ |
+ ind_subset = NULL) {+ |
+
104 | ++ |
+ # Initialize a Trainstudy to store predictions+ |
+
105 | +! | +
+ pred_study = PredictStudy$new(id = new_study$getId(),+ |
+
106 | +! | +
+ ind_col = new_study$getIndCol())+ |
+
107 | +! | +
+ layers = new_study$getKeyClass()+ |
+
108 | ++ |
+ # This code accesses each layer (except MetaLayer) level+ |
+
109 | ++ |
+ # and make predictions for the new layer in input.+ |
+
110 | ++ |
+ # TODO: A TrainLayer can be predicted as a NewLayer.+ |
+
111 | +! | +
+ layers = layers[layers$class %in% c("NewLayer", "TrainLayer"), ]+ |
+
112 | +! | +
+ for (k in layers$key) {+ |
+
113 | +! | +
+ new_layer = new_study$getFromHashTable(key = k)+ |
+
114 | +! | +
+ new_layer_kc = new_layer$getKeyClass()+ |
+
115 | +! | +
+ m_layer = self$getFromHashTable(key = k)+ |
+
116 | +! | +
+ pred_layer = m_layer$predict(new_layer = new_layer,+ |
+
117 | +! | +
+ ind_subset = ind_subset)+ |
+
118 | ++ |
+ # Add a new predicted layer to the predicted study+ |
+
119 | +! | +
+ pred_layer$setPredictStudy(pred_study)+ |
+
120 | ++ |
+ }+ |
+
121 | +! | +
+ return(pred_study)+ |
+
122 | ++ |
+ },+ |
+
123 | ++ |
+ #' @description+ |
+
124 | ++ |
+ #' Creates a meta training dataset and assigns it to the meta layer.+ |
+
125 | ++ |
+ #'+ |
+
126 | ++ |
+ #'+ |
+
127 | ++ |
+ #' @param resampling_method (`function(1)`) \cr+ |
+
128 | ++ |
+ #' Function for internal validation.+ |
+
129 | ++ |
+ #' @param resampling_arg (`list(1)`) \cr+ |
+
130 | ++ |
+ #' List of arguments to be passed to the function.+ |
+
131 | ++ |
+ #' @param use_var_sel `boolean(1)` \cr+ |
+
132 | ++ |
+ #' If TRUE, selected variables available at each layer are used.+ |
+
133 | ++ |
+ #'+ |
+
134 | ++ |
+ #' @return+ |
+
135 | ++ |
+ #' The current object is returned, with a meta training dataset assigned to the meta layer.+ |
+
136 | ++ |
+ #' @export+ |
+
137 | ++ |
+ #'+ |
+
138 | ++ |
+ createMetaTrainData = function (resampling_method,+ |
+
139 | ++ |
+ resampling_arg,+ |
+
140 | ++ |
+ use_var_sel) {+ |
+
141 | +! | +
+ layers = self$getKeyClass()+ |
+
142 | +! | +
+ if (!("TrainMetaLayer" %in% layers$class)) {+ |
+
143 | +! | +
+ stop("No existing meta layer. I cannot create meta training data.")+ |
+
144 | ++ |
+ }+ |
+
145 | +! | +
+ resampling = do.call(eval(parse(text = resampling_method)),+ |
+
146 | +! | +
+ resampling_arg)+ |
+
147 | +! | +
+ if (!is.list(resampling)) {+ |
+
148 | +! | +
+ stop("The resampling method must return a list of folds, with each fold containing a vector of training IDs.\n See example for details.")+ |
+
149 | ++ |
+ } else {+ |
+
150 | +! | +
+ train_layer_res_list = lapply(X = 1:length(resampling),+ |
+
151 | +! | +
+ function (fold) {+ |
+
152 | +! | +
+ test_index = resampling[[fold]]+ |
+
153 | +! | +
+ train_index = setdiff(unlist(resampling), test_index)+ |
+
154 | +! | +
+ train_ids = self$getTargetValues()[train_index, 1L]+ |
+
155 | +! | +
+ self$trainLayer(ind_subset = train_ids,+ |
+
156 | +! | +
+ use_var_sel = use_var_sel)+ |
+
157 | +! | +
+ test_ids = self$getTargetValues()[test_index, 1L]+ |
+
158 | ++ |
+ # TODO: Note: The current object is not a NewStudy, but a TrainStudy object.+ |
+
159 | +! | +
+ pred_study = self$predictLayer(new_study = self,+ |
+
160 | +! | +
+ ind_subset = test_ids)+ |
+
161 | +! | +
+ pred_study_kc = pred_study$getKeyClass()+ |
+
162 | ++ |
+ ## Assess each layer and extract model+ |
+
163 | +! | +
+ current_pred = NULL+ |
+
164 | +! | +
+ for (k in pred_study_kc$key) {+ |
+
165 | +! | +
+ pred_layer = pred_study$getFromHashTable(key = k)+ |
+
166 | ++ |
+ # pred_layer = layer$getFromHashTable(key = "PredictLayer")+ |
+
167 | +! | +
+ pred_data = pred_layer$getPredictData()+ |
+
168 | +! | +
+ pred_values = pred_data$getPredictData()+ |
+
169 | +! | +
+ current_pred = rbind(current_pred, pred_values)+ |
+
170 | ++ |
+ }+ |
+
171 | +! | +
+ return(current_pred)+ |
+
172 | ++ |
+ })+ |
+
173 | +! | +
+ predicted_values = data.frame(do.call(what = "rbind",+ |
+
174 | +! | +
+ args = train_layer_res_list))+ |
+
175 | ++ |
+ # Will transform meta data.frame into wide format+ |
+
176 | +! | +
+ predicted_values_wide = reshape(predicted_values,+ |
+
177 | +! | +
+ idvar = colnames(predicted_values)[2],+ |
+
178 | +! | +
+ timevar = colnames(predicted_values)[1],+ |
+
179 | +! | +
+ direction = "wide")+ |
+
180 | +! | +
+ colname_vector = gsub(pattern = "Prediction.",+ |
+
181 | +! | +
+ replacement = "",+ |
+
182 | +! | +
+ x = names(predicted_values_wide))+ |
+
183 | +! | +
+ names(predicted_values_wide) = colname_vector+ |
+
184 | +! | +
+ target_df = self$getTargetValues()+ |
+
185 | +! | +
+ predicted_values_wide = merge(x = target_df,+ |
+
186 | +! | +
+ y = predicted_values_wide,+ |
+
187 | +! | +
+ by = colnames(target_df)[1],+ |
+
188 | +! | +
+ all.y = TRUE)+ |
+
189 | ++ |
+ # Add layer specific predictions to meta layer+ |
+
190 | +! | +
+ layers = self$getKeyClass()+ |
+
191 | +! | +
+ meta_layer_key = layers[layers$class == "TrainMetaLayer" , "key"]+ |
+
192 | +! | +
+ meta_layer = self$getFromHashTable(key = meta_layer_key)+ |
+
193 | ++ |
+ # TODO: Test and remove comment.+ |
+
194 | +! | +
+ meta_layer$openAccess()+ |
+
195 | ++ |
+ # predicted20242806 this word just serves as temporary key+ |
+
196 | ++ |
+ # TODO: Maybe remove this object from the training meta layer after crossvalidation.+ |
+
197 | +! | +
+ meta_layer$setTrainData(id = "predicted20242806",+ |
+
198 | +! | +
+ ind_col = names(predicted_values_wide)[1L],+ |
+
199 | +! | +
+ data_frame = predicted_values_wide,+ |
+
200 | +! | +
+ meta_layer = meta_layer,+ |
+
201 | +! | +
+ target = colnames(target_df)[2L])+ |
+
202 | +! | +
+ meta_layer$set2NotTrained()+ |
+
203 | +! | +
+ meta_layer$closeAccess()+ |
+
204 | +! | +
+ return(predicted_values_wide)+ |
+
205 | ++ |
+ }+ |
+
206 | ++ |
+ },+ |
+
207 | ++ |
+ #' @description+ |
+
208 | ++ |
+ #' Trains the current study. All leaners and the meta learner are trained.+ |
+
209 | ++ |
+ #'+ |
+
210 | ++ |
+ #' @param ind_subset (`vector(1)`) \cr+ |
+
211 | ++ |
+ #' ID subset to be used for training.+ |
+
212 | ++ |
+ #' @param use_var_sel `boolean(1)` \cr+ |
+
213 | ++ |
+ #' If TRUE, variable selection is performed before training.+ |
+
214 | ++ |
+ #' @param resampling_method (`function(1)`) \cr+ |
+
215 | ++ |
+ #' Function for internal validation.+ |
+
216 | ++ |
+ #' @param resampling_arg (`list(1)`) \cr+ |
+
217 | ++ |
+ #' List of arguments to be passed to the function.+ |
+
218 | ++ |
+ #'+ |
+
219 | ++ |
+ #' @return+ |
+
220 | ++ |
+ #' The current object is returned, with each learner trained on each layer.+ |
+
221 | ++ |
+ #' @export+ |
+
222 | ++ |
+ #'+ |
+
223 | ++ |
+ train = function (ind_subset = NULL,+ |
+
224 | ++ |
+ use_var_sel = FALSE,+ |
+
225 | ++ |
+ resampling_method,+ |
+
226 | ++ |
+ resampling_arg) {+ |
+
227 | ++ |
+ # Test that the study contains ovelapping individuals+ |
+
228 | +! | +
+ if (!self$test_overlap()) {+ |
+
229 | +! | +
+ stop("This study does not contain overlapping individuals.")+ |
+
230 | ++ |
+ }+ |
+
231 | ++ |
+ # 1) Train each layer+ |
+
232 | +! | +
+ self$trainLayer(ind_subset = ind_subset,+ |
+
233 | +! | +
+ use_var_sel = use_var_sel)+ |
+
234 | ++ |
+ # 2) Create meta training data+ |
+
235 | +! | +
+ self$createMetaTrainData(resampling_method,+ |
+
236 | +! | +
+ resampling_arg,+ |
+
237 | +! | +
+ use_var_sel = use_var_sel)+ |
+
238 | ++ |
+ # 3) Train the meta layer+ |
+
239 | ++ |
+ # Add layer specific predictions to meta training layer+ |
+
240 | +! | +
+ layers = self$getKeyClass()+ |
+
241 | +! | +
+ meta_layer_key = layers[layers$class == "TrainMetaLayer" , "key"]+ |
+
242 | +! | +
+ meta_layer = self$getFromHashTable(key = meta_layer_key)+ |
+
243 | +! | +
+ meta_layer$train(ind_subset = ind_subset)+ |
+
244 | +! | +
+ return(self)+ |
+
245 | ++ |
+ },+ |
+
246 | ++ |
+ #' @description+ |
+
247 | ++ |
+ #' Predicts a new study.+ |
+
248 | ++ |
+ #'+ |
+
249 | ++ |
+ #' @param new_study (`TrainStudy(1)`) \cr+ |
+
250 | ++ |
+ #' A new study to be predicted.+ |
+
251 | ++ |
+ #' @param ind_subset (`vector(1)`) \cr+ |
+
252 | ++ |
+ #' Vector of IDs to be predicted.+ |
+
253 | ++ |
+ #'+ |
+
254 | ++ |
+ #' @return+ |
+
255 | ++ |
+ #' The predicted object. All layers and the meta layer are predicted. This is the final predicted object.+ |
+
256 | ++ |
+ #' @export+ |
+
257 | ++ |
+ #'+ |
+
258 | ++ |
+ predict = function (new_study,+ |
+
259 | ++ |
+ ind_subset = NULL) {+ |
+
260 | ++ |
+ # 1) Layer predictions+ |
+
261 | +! | +
+ predicted_study = self$predictLayer(new_study = new_study,+ |
+
262 | +! | +
+ ind_subset = ind_subset)+ |
+
263 | ++ |
+ # 2) Meta layer predicted new data; resume layer specific+ |
+
264 | ++ |
+ # predictions and create a new data.+ |
+
265 | +! | +
+ meta_layer_id = self$getTrainMetaLayer()$getId()+ |
+
266 | +! | +
+ new_meta_data = predicted_study$createMetaNewData(+ |
+
267 | +! | +
+ meta_layer_id = meta_layer_id)+ |
+
268 | ++ |
+ # 3) Predict new meta layer by the trained meta layer+ |
+
269 | +! | +
+ layers = self$getKeyClass()+ |
+
270 | +! | +
+ meta_layer_key = layers[layers$class == "TrainMetaLayer", "key"]+ |
+
271 | +! | +
+ meta_layer = self$getFromHashTable(key = meta_layer_key)+ |
+
272 | ++ |
+ # TODO: getNewLayer maybe rename it getLayer?+ |
+
273 | +! | +
+ predicted_layer = meta_layer$predict(new_layer = new_meta_data$getNewLayer(),+ |
+
274 | +! | +
+ ind_subset = ind_subset)+ |
+
275 | ++ |
+ # Store final meta predicted values on meta layer+ |
+
276 | +! | +
+ predicted_study$removeFromHashTable(key = predicted_layer$getId())+ |
+
277 | +! | +
+ predicted_study$add2HashTable(key = predicted_layer$getId(),+ |
+
278 | +! | +
+ value = predicted_layer,+ |
+
279 | +! | +
+ .class = "PredictData")+ |
+
280 | ++ |
+ # Updating the predicted meta layer+ |
+
281 | ++ |
+ # TODO: This is already done by predicting the meta layer. If no error, remove me.+ |
+
282 | ++ |
+ # predicted_study$add2HashTable(key = meta_layer_key,+ |
+
283 | ++ |
+ # value = predicted_layer,+ |
+
284 | ++ |
+ # .class = "Predict")+ |
+
285 | ++ |
+ # Resume predictions+ |
+
286 | +! | +
+ key_class_study = predicted_study$getKeyClass()+ |
+
287 | +! | +
+ predicted_values = NULL+ |
+
288 | +! | +
+ for (k in key_class_study[ , "key"]) {+ |
+
289 | ++ |
+ # TODO: Please ensure the difference between [PredictData] and+ |
+
290 | ++ |
+ # predicted values (predicted data.frame) when writting the paper.+ |
+
291 | +! | +
+ pred_layer = predicted_study$getFromHashTable(key = k)+ |
+
292 | +! | +
+ pred_data = pred_layer$getPredictData()+ |
+
293 | +! | +
+ pred_values = pred_data$getPredictData()+ |
+
294 | +! | +
+ predicted_values = data.frame(rbind(predicted_values,+ |
+
295 | +! | +
+ pred_values))+ |
+
296 | ++ |
+ }+ |
+
297 | ++ |
+ # Will transform meta data.frame into wide format+ |
+
298 | +! | +
+ predicted_values_wide = reshape(predicted_values,+ |
+
299 | +! | +
+ idvar = colnames(predicted_values)[2L],+ |
+
300 | +! | +
+ timevar = colnames(predicted_values)[1L],+ |
+
301 | +! | +
+ direction = "wide")+ |
+
302 | +! | +
+ colname_vector = gsub(pattern = "Prediction.",+ |
+
303 | +! | +
+ replacement = "",+ |
+
304 | +! | +
+ x = names(predicted_values_wide))+ |
+
305 | +! | +
+ names(predicted_values_wide) = colname_vector+ |
+
306 | ++ | + + | +
307 | +! | +
+ return(list(predicted_study = predicted_study,+ |
+
308 | +! | +
+ predicted_values = predicted_values_wide))+ |
+
309 | ++ |
+ },+ |
+
310 | ++ |
+ #' @description+ |
+
311 | ++ |
+ #' Variable selection on the current training study.+ |
+
312 | ++ |
+ #'+ |
+
313 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
314 | ++ |
+ #' ID subset of individuals to be used for variable selection.+ |
+
315 | ++ |
+ #'+ |
+
316 | ++ |
+ #' @return+ |
+
317 | ++ |
+ #' The current layer is returned with the resulting model.+ |
+
318 | ++ |
+ #' @export+ |
+
319 | ++ |
+ #'+ |
+
320 | ++ |
+ varSelection = function (ind_subset = NULL) {+ |
+
321 | +! | +
+ layers = self$getKeyClass()+ |
+
322 | +! | +
+ if (nrow(layers)) {+ |
+
323 | ++ |
+ # This code accesses each layer (except MetaLayer) level and+ |
+
324 | ++ |
+ # perform variable selection.+ |
+
325 | +! | +
+ layers = layers[layers$class %in% "TrainLayer", ]+ |
+
326 | +! | +
+ selected = NULL+ |
+
327 | +! | +
+ for (k in layers$key) {+ |
+
328 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
329 | +! | +
+ layer_var_sel = layer$varSelection(ind_subset = ind_subset)+ |
+
330 | +! | +
+ selected = rbind(selected,+ |
+
331 | +! | +
+ data.frame(Layer = layer$getId(),+ |
+
332 | +! | +
+ variable = layer_var_sel))+ |
+
333 | ++ |
+ }+ |
+
334 | ++ |
+ } else {+ |
+
335 | +! | +
+ stop("No existing layer in the current training study.")+ |
+
336 | ++ |
+ }+ |
+
337 | +! | +
+ return(selected)+ |
+
338 | ++ |
+ },+ |
+
339 | ++ |
+ #' @description+ |
+
340 | ++ |
+ #' Gather target values from all layer.+ |
+
341 | ++ |
+ #'+ |
+
342 | ++ |
+ #' @return+ |
+
343 | ++ |
+ #' A \code{data.frame} containing individuals IDs and corresponding target values.+ |
+
344 | ++ |
+ #' @export+ |
+
345 | ++ |
+ #'+ |
+
346 | ++ |
+ getTargetValues = function() {+ |
+
347 | +! | +
+ layers = self$getKeyClass()+ |
+
348 | ++ |
+ # This code accesses each layer (except TrainMetaLayer) level+ |
+
349 | ++ |
+ # and get the target variable+ |
+
350 | +! | +
+ layers = layers[layers$class %in% "TrainLayer", ]+ |
+
351 | +! | +
+ target_data = NULL+ |
+
352 | +! | +
+ train_data = NULL+ |
+
353 | +! | +
+ for (k in layers$key) {+ |
+
354 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
355 | +! | +
+ target_data = as.data.frame(rbind(target_data,+ |
+
356 | +! | +
+ layer$getTargetValues()))+ |
+
357 | +! | +
+ train_data = layer$getTrainData()+ |
+
358 | ++ |
+ }+ |
+
359 | +! | +
+ target_data = target_data[!duplicated(target_data[ , train_data$getIndCol()]), ]+ |
+
360 | +! | +
+ return(target_data)+ |
+
361 | ++ |
+ },+ |
+
362 | ++ |
+ #' @description+ |
+
363 | ++ |
+ #' Gather individual IDs from all layer.+ |
+
364 | ++ |
+ #'+ |
+
365 | ++ |
+ #' @return+ |
+
366 | ++ |
+ #' A \code{data.frame} containing individuals IDs.+ |
+
367 | ++ |
+ #' @export+ |
+
368 | ++ |
+ #'+ |
+
369 | ++ |
+ getIndIDs = function() {+ |
+
370 | +! | +
+ layers = self$getKeyClass()+ |
+
371 | ++ |
+ # This code accesses each layer (except TrainMetaLayer) level+ |
+
372 | ++ |
+ # and get the individual IDs.+ |
+
373 | +! | +
+ layers = layers[layers$class %in% "TrainLayer", ]+ |
+
374 | +! | +
+ ids_data = NULL+ |
+
375 | +! | +
+ current_data = NULL+ |
+
376 | +! | +
+ for (k in layers$key) {+ |
+
377 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
378 | +! | +
+ ids_data = as.data.frame(rbind(ids_data,+ |
+
379 | +! | +
+ layer$getIndIDs()))+ |
+
380 | ++ |
+ }+ |
+
381 | +! | +
+ ids_data = ids_data[!duplicated(ids_data[ , 1L]), ,+ |
+
382 | +! | +
+ drop = FALSE]+ |
+
383 | +! | +
+ return(ids_data)+ |
+
384 | ++ |
+ },+ |
+
385 | ++ |
+ #' @description+ |
+
386 | ++ |
+ #' Getter of the meta layer.+ |
+
387 | ++ |
+ #'+ |
+
388 | ++ |
+ #' @return+ |
+
389 | ++ |
+ #' Object from class [TrainMetaLayer]+ |
+
390 | ++ |
+ #' @export+ |
+
391 | ++ |
+ #'+ |
+
392 | ++ |
+ getTrainMetaLayer = function () {+ |
+
393 | +! | +
+ layers = self$getKeyClass()+ |
+
394 | +! | +
+ meta_layer_key = layers[layers$class == "TrainMetaLayer" , "key"]+ |
+
395 | +! | +
+ meta_layer = self$getFromHashTable(key = meta_layer_key)+ |
+
396 | +! | +
+ return(meta_layer)+ |
+
397 | ++ |
+ },+ |
+
398 | ++ |
+ #' @description+ |
+
399 | ++ |
+ #' Getter of the individual column name.+ |
+
400 | ++ |
+ #' @export+ |
+
401 | ++ |
+ getIndCol = function () {+ |
+
402 | +! | +
+ return(private$ind_col)+ |
+
403 | ++ |
+ },+ |
+
404 | ++ |
+ #' @description+ |
+
405 | ++ |
+ #' Getter of the target variable name.+ |
+
406 | ++ |
+ #' @export+ |
+
407 | ++ |
+ getTarget = function () {+ |
+
408 | +! | +
+ return(private$target)+ |
+
409 | ++ |
+ },+ |
+
410 | ++ |
+ #' @description+ |
+
411 | ++ |
+ #' Increase the number of trained layer.+ |
+
412 | ++ |
+ increaseNbTrainedLayer = function () {+ |
+
413 | +! | +
+ private$nb_trained_layer = private$nb_trained_layer + 1L+ |
+
414 | +! | +
+ if (private$nb_trained_layer == length(private$hash_table)) {+ |
+
415 | +! | +
+ private$status = TRUE+ |
+
416 | ++ |
+ }+ |
+
417 | ++ |
+ },+ |
+
418 | ++ |
+ #' @description+ |
+
419 | ++ |
+ #' Test that individuals overlap over layers.+ |
+
420 | ++ |
+ #' At least five individuals must overlapped.+ |
+
421 | ++ |
+ #'+ |
+
422 | ++ |
+ #' @export+ |
+
423 | ++ |
+ #'+ |
+
424 | ++ |
+ test_overlap = function () {+ |
+
425 | +! | +
+ layers = self$getKeyClass()+ |
+
426 | ++ |
+ # This code accesses each layer (except TrainMetaLayer) level+ |
+
427 | ++ |
+ # and get the individual IDs.+ |
+
428 | +! | +
+ layers = layers[layers$class %in% "TrainLayer", ]+ |
+
429 | +! | +
+ ids_data = NULL+ |
+
430 | +! | +
+ current_data = NULL+ |
+
431 | +! | +
+ for (k in layers$key) {+ |
+
432 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
433 | +! | +
+ ids_data = as.data.frame(rbind(ids_data,+ |
+
434 | +! | +
+ layer$getIndIDs()))+ |
+
435 | ++ |
+ }+ |
+
436 | +! | +
+ if (sum(duplicated(ids_data[ , 1L])) > 5L) {+ |
+
437 | +! | +
+ return(TRUE)+ |
+
438 | ++ |
+ } else {+ |
+
439 | +! | +
+ return(FALSE)+ |
+
440 | ++ |
+ }+ |
+
441 | ++ |
+ },+ |
+
442 | ++ |
+ #' @description+ |
+
443 | ++ |
+ #' UpSet plot to show an overview of the overlap of individuals across various layers.+ |
+
444 | ++ |
+ #'+ |
+
445 | ++ |
+ #' @param ... \cr+ |
+
446 | ++ |
+ #' Further parameters to be passed to the the \code{upset} function from package \code{UpSetR}.+ |
+
447 | ++ |
+ #'+ |
+
448 | ++ |
+ #' @export+ |
+
449 | ++ |
+ #'+ |
+
450 | ++ |
+ upset = function (...) {+ |
+
451 | +! | +
+ layers = self$getKeyClass()+ |
+
452 | ++ |
+ # This code accesses each layer (except TrainMetaLayer) level+ |
+
453 | ++ |
+ # and get the individual IDs.+ |
+
454 | +! | +
+ layers = layers[layers$class %in% "TrainLayer", ]+ |
+
455 | +! | +
+ ids_list = lapply(layers$key, function (k) {+ |
+
456 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
457 | +! | +
+ return(layer$getIndIDs()[ , 1L])+ |
+
458 | ++ |
+ })+ |
+
459 | +! | +
+ param_upset = list(...)+ |
+
460 | +! | +
+ from_list_ids = do.call(eval(parse(text = "UpSetR::fromList")),+ |
+
461 | +! | +
+ list(input = ids_list))+ |
+
462 | +! | +
+ names(from_list_ids) = layers$key+ |
+
463 | +! | +
+ param_upset$data = from_list_ids+ |
+
464 | +! | +
+ print(do.call(eval(parse(text = "UpSetR::upset")),+ |
+
465 | +! | +
+ param_upset))+ |
+
466 | +! | +
+ invisible(TRUE)+ |
+
467 | ++ |
+ },+ |
+
468 | ++ |
+ #' @description+ |
+
469 | ++ |
+ #' Generate study summary+ |
+
470 | ++ |
+ #'+ |
+
471 | ++ |
+ #' @export+ |
+
472 | ++ |
+ #'+ |
+
473 | ++ |
+ summary = function () {+ |
+
474 | +! | +
+ cat(sprintf("Study %s\n", self$getId()))+ |
+
475 | +! | +
+ cat("----------------\n")+ |
+
476 | +! | +
+ self$print()+ |
+
477 | +! | +
+ cat("----------------\n")+ |
+
478 | +! | +
+ cat("\n")+ |
+
479 | +! | +
+ layers = self$getKeyClass()+ |
+
480 | +! | +
+ for (k in layers$key) {+ |
+
481 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
482 | +! | +
+ layer$summary()+ |
+
483 | +! | +
+ cat("\n")+ |
+
484 | ++ |
+ }+ |
+
485 | ++ |
+ }+ |
+
486 | ++ |
+ ),+ |
+
487 | ++ |
+ private = list(+ |
+
488 | ++ |
+ ind_col = character(0L),+ |
+
489 | ++ |
+ target = character(0L),+ |
+
490 | ++ |
+ nb_trained_layer = 0L,+ |
+
491 | ++ |
+ status = FALSE+ |
+
492 | ++ |
+ ),+ |
+
493 | ++ |
+ cloneable = FALSE+ |
+
494 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title PredictStudy Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class is the basic class of the present package. An object from this class+ |
+
5 | ++ |
+ #' is designed to contain multiple layers, but only one meta layer.+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' A study is structured as followed:+ |
+
8 | ++ |
+ #' * [PredictLayer]: Can be clinical, gene expression, etc.+ |
+
9 | ++ |
+ #' - [Lrner]: Specific to each layer, it must be set up by the user.+ |
+
10 | ++ |
+ #' - [TrainData]: Specific to each layer, it must be set up by the user.+ |
+
11 | ++ |
+ #' - [Model]: Specific to each layer, it is set up by training the learner on the training data.+ |
+
12 | ++ |
+ #' * [PredictMetaLayer]: Basically a [PredictLayer], but with some specific properties.+ |
+
13 | ++ |
+ #' - [Lrner]: This is the meta learner, it must be set up by the user.+ |
+
14 | ++ |
+ #' - [TrainData]: Specific to each layer, it is set up internally after cross-validation.+ |
+
15 | ++ |
+ #' - [Model]: Specific to each layer, it is set up by training the learner on the training data.+ |
+
16 | ++ |
+ #'+ |
+
17 | ++ |
+ #' Use the function \code{train} to train a study and \code{predict} to predict+ |
+
18 | ++ |
+ #' a new study.+ |
+
19 | ++ |
+ #'+ |
+
20 | ++ |
+ #' @export+ |
+
21 | ++ |
+ #'+ |
+
22 | ++ |
+ #' @importFrom R6 R6Class+ |
+
23 | ++ |
+ #'+ |
+
24 | ++ |
+ #' @seealso [TrainLayer]+ |
+
25 | ++ |
+ PredictStudy <- R6Class("PredictStudy",+ |
+
26 | ++ |
+ inherit = HashTable,+ |
+
27 | ++ |
+ public = list(+ |
+
28 | ++ |
+ #' @description+ |
+
29 | ++ |
+ #' constructor+ |
+
30 | ++ |
+ #'+ |
+
31 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
32 | ++ |
+ #' See class Param+ |
+
33 | ++ |
+ #' @param ind_col (`character(1L)`)+ |
+
34 | ++ |
+ #' Name of column of individuals IDS+ |
+
35 | ++ |
+ initialize = function (id, ind_col) {+ |
+
36 | +! | +
+ super$initialize(id = id)+ |
+
37 | +! | +
+ private$ind_col = ind_col+ |
+
38 | ++ |
+ },+ |
+
39 | ++ |
+ #' @description+ |
+
40 | ++ |
+ #' Printer+ |
+
41 | ++ |
+ #'+ |
+
42 | ++ |
+ #' @param ... (any) \cr+ |
+
43 | ++ |
+ #'+ |
+
44 | ++ |
+ print = function (...) {+ |
+
45 | +! | +
+ cat(sprintf("PredictStudy : %s\n", private$id))+ |
+
46 | +! | +
+ cat(sprintf("Nb. layers : %s\n", length(private$hash_table)))+ |
+
47 | ++ |
+ },+ |
+
48 | ++ |
+ #' @param meta_layer_id (`character(1)`) \cr+ |
+
49 | ++ |
+ #' ID of the meta layer where the new meta data will be stored.+ |
+
50 | ++ |
+ #'+ |
+
51 | ++ |
+ #' @description+ |
+
52 | ++ |
+ #' Creates a new meta dataset based on layer predictions.+ |
+
53 | ++ |
+ #'+ |
+
54 | ++ |
+ #' @return+ |
+
55 | ++ |
+ #' A [NewData] is returned.+ |
+
56 | ++ |
+ #' @export+ |
+
57 | ++ |
+ #'+ |
+
58 | ++ |
+ createMetaNewData = function (meta_layer_id) {+ |
+
59 | ++ |
+ # predicted_study = self$predictLayer(new_study = new_study,+ |
+
60 | ++ |
+ # ind_subset = ind_subset)+ |
+
61 | +! | +
+ key_class_study = self$getKeyClass()+ |
+
62 | +! | +
+ predicted_values = NULL+ |
+
63 | +! | +
+ for (k in key_class_study[ , "key"]) {+ |
+
64 | ++ |
+ # FIXME: Maybe define a class Prediction instead of+ |
+
65 | ++ |
+ # using Hashtable?+ |
+
66 | +! | +
+ pred_layer = self$getFromHashTable(key = k)+ |
+
67 | +! | +
+ pred_data = pred_layer$getPredictData()+ |
+
68 | +! | +
+ pred_values = pred_data$getPredictData()+ |
+
69 | +! | +
+ predicted_values = data.frame(rbind(predicted_values,+ |
+
70 | +! | +
+ pred_values))+ |
+
71 | ++ |
+ }+ |
+
72 | ++ |
+ # Will transform meta data.frame into wide format+ |
+
73 | +! | +
+ predicted_values_wide = reshape(predicted_values,+ |
+
74 | +! | +
+ idvar = colnames(predicted_values)[2L],+ |
+
75 | +! | +
+ timevar = colnames(predicted_values)[1L],+ |
+
76 | +! | +
+ direction = "wide")+ |
+
77 | +! | +
+ colname_vector = gsub(pattern = "Prediction.",+ |
+
78 | +! | +
+ replacement = "",+ |
+
79 | +! | +
+ x = names(predicted_values_wide))+ |
+
80 | +! | +
+ names(predicted_values_wide) = colname_vector+ |
+
81 | +! | +
+ ind_ids = self$getIndIDs()+ |
+
82 | +! | +
+ predicted_values_wide = merge(x = ind_ids,+ |
+
83 | +! | +
+ y = predicted_values_wide,+ |
+
84 | +! | +
+ by = colnames(ind_ids)[1L],+ |
+
85 | +! | +
+ all.y = TRUE)+ |
+
86 | ++ |
+ # Add layer specific predictions to a new predicted meta layer+ |
+
87 | +! | +
+ new_meta_layer = NewMetaLayer$new(id = meta_layer_id,+ |
+
88 | +! | +
+ new_study = self)+ |
+
89 | ++ |
+ # FIXME: Move this: Data should be created by the layer.+ |
+
90 | +! | +
+ new_meta_layer$openAccess()+ |
+
91 | +! | +
+ new_meta_data = NewData$new(id = "predicted",+ |
+
92 | +! | +
+ new_layer = new_meta_layer,+ |
+
93 | +! | +
+ data_frame = predicted_values_wide)+ |
+
94 | +! | +
+ new_meta_layer$closeAccess()+ |
+
95 | +! | +
+ return(new_meta_data)+ |
+
96 | ++ |
+ },+ |
+
97 | ++ |
+ #' @description+ |
+
98 | ++ |
+ #' Gather individual IDs from all layer.+ |
+
99 | ++ |
+ #'+ |
+
100 | ++ |
+ #' @return+ |
+
101 | ++ |
+ #' A \code{data.frame} containing individuals IDs.+ |
+
102 | ++ |
+ #' @export+ |
+
103 | ++ |
+ #'+ |
+
104 | ++ |
+ getIndIDs = function() {+ |
+
105 | ++ |
+ # FIXME: Adjust to the Predict class+ |
+
106 | +! | +
+ layers = self$getKeyClass()+ |
+
107 | ++ |
+ # This code accesses each layer (except MetaLayer) level+ |
+
108 | ++ |
+ # and get the target variable+ |
+
109 | ++ |
+ # FIXME: Replace "Predict" by "PredictLayer"+ |
+
110 | +! | +
+ layers = layers[layers$class %in% "PredictLayer", ]+ |
+
111 | +! | +
+ ids_data = NULL+ |
+
112 | +! | +
+ current_data = NULL+ |
+
113 | +! | +
+ for (k in layers$key) {+ |
+
114 | +! | +
+ layer = self$getFromHashTable(key = k)+ |
+
115 | +! | +
+ ids_data = as.data.frame(rbind(ids_data,+ |
+
116 | +! | +
+ layer$getIndIDs()))+ |
+
117 | ++ |
+ }+ |
+
118 | +! | +
+ ids_data = ids_data[!duplicated(ids_data[ , 1L]), ,+ |
+
119 | +! | +
+ drop = FALSE]+ |
+
120 | +! | +
+ return(ids_data)+ |
+
121 | ++ |
+ },+ |
+
122 | ++ |
+ #' @description+ |
+
123 | ++ |
+ #' Getter of the meta layer.+ |
+
124 | ++ |
+ #'+ |
+
125 | ++ |
+ #' @return+ |
+
126 | ++ |
+ #' Object from class [PredictMetaLayer]+ |
+
127 | ++ |
+ #' @export+ |
+
128 | ++ |
+ #'+ |
+
129 | ++ |
+ getPredictMetaLayer = function () {+ |
+
130 | +! | +
+ layers = self$getKeyClass()+ |
+
131 | ++ |
+ # FIXME: Use PredictMetaLayer instead of class MetaLayer+ |
+
132 | +! | +
+ meta_layer_key = layers[layers$class == "PredictMetaLayer" , "key"]+ |
+
133 | +! | +
+ meta_layer = self$getFromHashTable(key = meta_layer_key)+ |
+
134 | +! | +
+ return(meta_layer)+ |
+
135 | ++ |
+ },+ |
+
136 | ++ |
+ #' @description+ |
+
137 | ++ |
+ #' Getter of the individual column name.+ |
+
138 | ++ |
+ #' @export+ |
+
139 | ++ |
+ getIndCol = function () {+ |
+
140 | +! | +
+ return(private$ind_col)+ |
+
141 | ++ |
+ }+ |
+
142 | ++ |
+ ),+ |
+
143 | ++ |
+ private = list(+ |
+
144 | ++ |
+ ind_col = NULL+ |
+
145 | ++ |
+ ),+ |
+
146 | ++ |
+ cloneable = FALSE+ |
+
147 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Abstract class Data+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' As abstract, a [Data] object cannot be stored on any layer. Instead, extended+ |
+
5 | ++ |
+ #' [TrainData] or [NewData] objects can be stored on a layer.+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' @export+ |
+
8 | ++ |
+ #'+ |
+
9 | ++ |
+ #' @importFrom R6 R6Class+ |
+
10 | ++ |
+ #' @seealso [TrainData] and [NewData]+ |
+
11 | ++ |
+ Data <- R6Class("Data",+ |
+
12 | ++ |
+ public = list(+ |
+
13 | ++ |
+ #' @description+ |
+
14 | ++ |
+ #' Constructor of class Data.+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
17 | ++ |
+ #' Object ID.+ |
+
18 | ++ |
+ #' @param ind_col (`character(1)`) \cr+ |
+
19 | ++ |
+ #' Column name containing individual IDs.+ |
+
20 | ++ |
+ #' @param data_frame \cr+ |
+
21 | ++ |
+ #' \code{data.frame} containing data.+ |
+
22 | ++ |
+ initialize = function (id, ind_col, data_frame) {+ |
+
23 | +1x | +
+ private$id = id+ |
+
24 | +1x | +
+ private$ind_col = ind_col+ |
+
25 | +1x | +
+ if (is.data.frame(data_frame)) {+ |
+
26 | +1x | +
+ private$data_frame = data_frame+ |
+
27 | ++ |
+ } else {+ |
+
28 | +! | +
+ stop("'data_frame' must be a data.frame.")+ |
+
29 | ++ |
+ }+ |
+
30 | ++ |
+ },+ |
+
31 | ++ |
+ #' @description+ |
+
32 | ++ |
+ #' Printer+ |
+
33 | ++ |
+ #' @param ... (any) \cr+ |
+
34 | ++ |
+ #'+ |
+
35 | ++ |
+ print = function(...) {+ |
+
36 | +! | +
+ cat("Class : Data\n")+ |
+
37 | +! | +
+ cat(sprintf("name : %s\n", private$id))+ |
+
38 | +! | +
+ cat(sprintf("ind. id. : %s\n", private$ind_col))+ |
+
39 | +! | +
+ cat(sprintf("n : %s\n", nrow(private$data_frame)))+ |
+
40 | +! | +
+ cat(sprintf("p : %s\n", ncol(private$data_frame)))+ |
+
41 | ++ |
+ },+ |
+
42 | ++ |
+ #' @description+ |
+
43 | ++ |
+ #' Retrieve a data subset for a given variable name and values, a data subset.+ |
+
44 | ++ |
+ #'+ |
+
45 | ++ |
+ #' @param var_name (`character(1)`) \cr+ |
+
46 | ++ |
+ #' Variable name of interest.+ |
+
47 | ++ |
+ #' @param value (`vector(n)`) \cr+ |
+
48 | ++ |
+ #' Values of interest.+ |
+
49 | ++ |
+ #'+ |
+
50 | ++ |
+ #' @return+ |
+
51 | ++ |
+ #' The data subset is returned.+ |
+
52 | ++ |
+ #'+ |
+
53 | ++ |
+ #' @export+ |
+
54 | ++ |
+ #'+ |
+
55 | ++ |
+ getIndSubset = function (var_name, value) {+ |
+
56 | +! | +
+ subset_data <- self$clone(deep = FALSE)+ |
+
57 | +! | +
+ index = which(subset_data$getDataFrame()[[var_name]] %in% value)+ |
+
58 | +! | +
+ data_frame = subset_data$getDataFrame()[index, ]+ |
+
59 | +! | +
+ subset_data$setDataFrame(data_frame = data_frame)+ |
+
60 | +! | +
+ return(subset_data)+ |
+
61 | ++ |
+ },+ |
+
62 | ++ |
+ #' @description+ |
+
63 | ++ |
+ #' Retrieve a subset of variables from data.+ |
+
64 | ++ |
+ #'+ |
+
65 | ++ |
+ #' @param var_name (`character(n)`) \cr+ |
+
66 | ++ |
+ #' Variable names of interest.+ |
+
67 | ++ |
+ #'+ |
+
68 | ++ |
+ #' @return+ |
+
69 | ++ |
+ #' The data subset is returned.+ |
+
70 | ++ |
+ #'+ |
+
71 | ++ |
+ #' @export+ |
+
72 | ++ |
+ #'+ |
+
73 | ++ |
+ getVarSubset = function (var_name) {+ |
+
74 | +! | +
+ subset_data <- self$clone(deep = FALSE)+ |
+
75 | +! | +
+ data_frame = subset_data$getDataFrame()[ , var_name]+ |
+
76 | +! | +
+ subset_data$setDataFrame(data_frame = data_frame)+ |
+
77 | +! | +
+ return(subset_data)+ |
+
78 | ++ |
+ },+ |
+
79 | ++ |
+ #' @description+ |
+
80 | ++ |
+ #' For the given variable name, non existing values in the+ |
+
81 | ++ |
+ #' current dataset are returned.+ |
+
82 | ++ |
+ #'+ |
+
83 | ++ |
+ #' @param var_name `character(1)` \cr+ |
+
84 | ++ |
+ #' Variable name of interest.+ |
+
85 | ++ |
+ #' @param value `vector(n)` \cr+ |
+
86 | ++ |
+ #' Values of interest.+ |
+
87 | ++ |
+ #'+ |
+
88 | ++ |
+ #' @return+ |
+
89 | ++ |
+ #' The subset difference is returned.+ |
+
90 | ++ |
+ #'+ |
+
91 | ++ |
+ #' @export+ |
+
92 | ++ |
+ #'+ |
+
93 | ++ |
+ getSetDiff = function (var_name, value) {+ |
+
94 | +! | +
+ subset_diff <- self$clone(deep = FALSE)+ |
+
95 | +! | +
+ index = which(!(value %in% subset_diff$getDataFrame()[[var_name]]))+ |
+
96 | +! | +
+ if (length(index)) {+ |
+
97 | +! | +
+ return(value[index])+ |
+
98 | ++ |
+ } else {+ |
+
99 | +! | +
+ return(integer(0L))+ |
+
100 | ++ |
+ }+ |
+
101 | ++ |
+ },+ |
+
102 | ++ |
+ #' @description+ |
+
103 | ++ |
+ #' Getter of the \code{data.frame}.+ |
+
104 | ++ |
+ #'+ |
+
105 | ++ |
+ #' @return+ |
+
106 | ++ |
+ #' The \code{data.frame} of the current object is returned.+ |
+
107 | ++ |
+ #'+ |
+
108 | ++ |
+ #' @export+ |
+
109 | ++ |
+ #'+ |
+
110 | ++ |
+ getDataFrame = function () {+ |
+
111 | +! | +
+ return(private$data_frame)+ |
+
112 | ++ |
+ },+ |
+
113 | ++ |
+ #' @description+ |
+
114 | ++ |
+ #' Set a new \code{data.frame} to the current object.+ |
+
115 | ++ |
+ #'+ |
+
116 | ++ |
+ #' @param data_frame `data.frame(1)`+ |
+
117 | ++ |
+ #'+ |
+
118 | ++ |
+ #' @return+ |
+
119 | ++ |
+ #' The current object is returned.+ |
+
120 | ++ |
+ #'+ |
+
121 | ++ |
+ #' @export+ |
+
122 | ++ |
+ #'+ |
+
123 | ++ |
+ setDataFrame = function (data_frame) {+ |
+
124 | +! | +
+ private$data_frame = data_frame+ |
+
125 | +! | +
+ return(self)+ |
+
126 | ++ |
+ },+ |
+
127 | ++ |
+ #' @description+ |
+
128 | ++ |
+ #' Getter of the complete dataset without missing values.+ |
+
129 | ++ |
+ #'+ |
+
130 | ++ |
+ #' @return+ |
+
131 | ++ |
+ #' The complete dataset is returned.+ |
+
132 | ++ |
+ #'+ |
+
133 | ++ |
+ #' @export+ |
+
134 | ++ |
+ #'+ |
+
135 | ++ |
+ getCompleteData = function () {+ |
+
136 | +! | +
+ tmp_data = self$getDataFrame()+ |
+
137 | +! | +
+ tmp_data = tmp_data[complete.cases(tmp_data), ]+ |
+
138 | +! | +
+ return(tmp_data)+ |
+
139 | ++ |
+ },+ |
+
140 | ++ |
+ #' @description+ |
+
141 | ++ |
+ #' Getter of the current object ID.+ |
+
142 | ++ |
+ #'+ |
+
143 | ++ |
+ #' @return+ |
+
144 | ++ |
+ #' The current object ID is returned.+ |
+
145 | ++ |
+ #'+ |
+
146 | ++ |
+ #' @export+ |
+
147 | ++ |
+ #'+ |
+
148 | ++ |
+ getId = function () {+ |
+
149 | +! | +
+ return(private$id)+ |
+
150 | ++ |
+ },+ |
+
151 | ++ |
+ #' @description+ |
+
152 | ++ |
+ #' Getter of the current Data. This function is re-implemented+ |
+
153 | ++ |
+ #' by [TrainData] and [NewData].+ |
+
154 | ++ |
+ #'+ |
+
155 | ++ |
+ #' @return+ |
+
156 | ++ |
+ #' Do not use on this class.+ |
+
157 | ++ |
+ #' @export+ |
+
158 | ++ |
+ #'+ |
+
159 | ++ |
+ getData = function () {+ |
+
160 | +! | +
+ stop("Not implemented for this object.")+ |
+
161 | ++ |
+ },+ |
+
162 | ++ |
+ #' @description+ |
+
163 | ++ |
+ #' Getter of the individual column variable.+ |
+
164 | ++ |
+ #'+ |
+
165 | ++ |
+ #' @export+ |
+
166 | ++ |
+ #'+ |
+
167 | ++ |
+ getIndCol = function () {+ |
+
168 | +! | +
+ return(private$ind_col)+ |
+
169 | ++ |
+ }+ |
+
170 | ++ |
+ ),+ |
+
171 | ++ |
+ private = list(+ |
+
172 | ++ |
+ # Data ID.+ |
+
173 | ++ |
+ id = character(0L),+ |
+
174 | ++ |
+ # Individual column name.+ |
+
175 | ++ |
+ ind_col = NA,+ |
+
176 | ++ |
+ # \code{data.frame} containing data.+ |
+
177 | ++ |
+ data_frame = NA+ |
+
178 | ++ |
+ ),+ |
+
179 | ++ |
+ cloneable = TRUE+ |
+
180 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title TrainLayer Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements a traning layer. A [TrainLayer] object can only exist as a component of a [TrainStudy] object.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' A training layer is structured as followed:+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #' * [Lrner]: It is set by the user to be trained on the training data.+ |
+
9 | ++ |
+ #' * [TrainData]: It is set by the user to be used to train the learner.+ |
+
10 | ++ |
+ #' * [Model]: The result of training the learner on the training data, and therefore, not set by the user.+ |
+
11 | ++ |
+ #' * [NewData]: It is set by the user implements new data to be predicted.+ |
+
12 | ++ |
+ #'+ |
+
13 | ++ |
+ #' A layer can train its learner on its training data and store the resulting model. See the public function \code{Layer$train()} below.+ |
+
14 | ++ |
+ #'+ |
+
15 | ++ |
+ #' A layer can make predictions for a new layer passed as argument to its predict function. See the public function \code{Layer$predict()} below.+ |
+
16 | ++ |
+ #'+ |
+
17 | ++ |
+ #' @export+ |
+
18 | ++ |
+ #' @importFrom R6 R6Class+ |
+
19 | ++ |
+ #' @seealso [TrainStudy], [Lrner], [TrainData], [NewData] and [Model]+ |
+
20 | ++ |
+ TrainLayer <- R6Class("TrainLayer",+ |
+
21 | ++ |
+ inherit = HashTable,+ |
+
22 | ++ |
+ public = list(+ |
+
23 | ++ |
+ #' @description+ |
+
24 | ++ |
+ #' constructor+ |
+
25 | ++ |
+ #'+ |
+
26 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
27 | ++ |
+ #' See class Param+ |
+
28 | ++ |
+ #' @param train_study (`TrainStudy(1)`)\cr+ |
+
29 | ++ |
+ #'+ |
+
30 | ++ |
+ initialize = function (id, train_study) {+ |
+
31 | +1x | +
+ super$initialize(id = id)+ |
+
32 | +1x | +
+ private$train_study = train_study+ |
+
33 | +1x | +
+ if ("TrainStudy" %in% class(train_study)) {+ |
+
34 | +1x | +
+ train_study$add2HashTable(key = id,+ |
+
35 | +1x | +
+ value = self,+ |
+
36 | +1x | +
+ .class = "TrainLayer")+ |
+
37 | ++ |
+ } else {+ |
+
38 | +! | +
+ stop("A TrainLayer can only belong to a TrainStudy.")+ |
+
39 | ++ |
+ }+ |
+
40 | +1x | +
+ private$status = FALSE+ |
+
41 | ++ |
+ },+ |
+
42 | ++ |
+ #' @description+ |
+
43 | ++ |
+ #' Printer+ |
+
44 | ++ |
+ #' @param ... (any) \cr+ |
+
45 | ++ |
+ #'+ |
+
46 | ++ |
+ print = function (...){+ |
+
47 | +! | +
+ if (!private$status) {+ |
+
48 | +! | +
+ status = "Not trained"+ |
+
49 | ++ |
+ } else {+ |
+
50 | +! | +
+ status = "Trained"+ |
+
51 | ++ |
+ }+ |
+
52 | +! | +
+ cat(sprintf("TrainLayer : %s\n", private$id))+ |
+
53 | +! | +
+ cat(sprintf("Status : %s\n", status))+ |
+
54 | +! | +
+ stored_obj = self$getKeyClass()+ |
+
55 | +! | +
+ if (!nrow(stored_obj)) {+ |
+
56 | +! | +
+ cat("Empty layer.\n")+ |
+
57 | ++ |
+ } else {+ |
+
58 | +! | +
+ cat(sprintf("Nb. of objects stored : %s\n", nrow(stored_obj)))+ |
+
59 | +! | +
+ cat("-----------------------\n")+ |
+
60 | +! | +
+ print(stored_obj)+ |
+
61 | ++ |
+ }+ |
+
62 | ++ |
+ },+ |
+
63 | ++ |
+ #' @description+ |
+
64 | ++ |
+ #' Getter of the current study+ |
+
65 | ++ |
+ #'+ |
+
66 | ++ |
+ #' @return+ |
+
67 | ++ |
+ #' The current study is returned.+ |
+
68 | ++ |
+ #'+ |
+
69 | ++ |
+ getTrainStudy = function () {+ |
+
70 | +! | +
+ return(private$train_study)+ |
+
71 | ++ |
+ },+ |
+
72 | ++ |
+ #' @description+ |
+
73 | ++ |
+ #' Trains the current layer.+ |
+
74 | ++ |
+ #'+ |
+
75 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
76 | ++ |
+ #' ID subset of individuals to be used for training.+ |
+
77 | ++ |
+ #' @param use_var_sel `boolean(1)` \cr+ |
+
78 | ++ |
+ #' If TRUE, variable selection is performed before training.+ |
+
79 | ++ |
+ #'+ |
+
80 | ++ |
+ #' @return+ |
+
81 | ++ |
+ #' The current layer is returned with the resulting model.+ |
+
82 | ++ |
+ #' @export+ |
+
83 | ++ |
+ #'+ |
+
84 | ++ |
+ train = function (ind_subset = NULL, use_var_sel = FALSE) {+ |
+
85 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
86 | ++ |
+ # Stop if either learner of data is missing on this layer.+ |
+
87 | +! | +
+ if (!("Lrner" %in% layer_kc[ , "class"])){+ |
+
88 | +! | +
+ stop(sprintf("No learner on layer %s.", self$getId()))+ |
+
89 | ++ |
+ } else {+ |
+
90 | +! | +
+ if (!("TrainData" %in% layer_kc[ , "class"])) {+ |
+
91 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
92 | ++ |
+ }+ |
+
93 | ++ |
+ }+ |
+
94 | ++ |
+ # The learner is trained on the current dataset+ |
+
95 | +! | +
+ lrner_key = layer_kc[layer_kc$class == "Lrner" , "key"]+ |
+
96 | +! | +
+ lrner = self$getFromHashTable(key = lrner_key[1L])+ |
+
97 | +! | +
+ model = lrner$train(ind_subset = ind_subset,+ |
+
98 | +! | +
+ use_var_sel = use_var_sel)+ |
+
99 | ++ |
+ # Updating the training status.+ |
+
100 | +! | +
+ if (!private$status) {+ |
+
101 | ++ |
+ # The training layer has not been trained before.+ |
+
102 | +! | +
+ private$train_study$increaseNbTrainedLayer()+ |
+
103 | +! | +
+ private$status = TRUE+ |
+
104 | ++ |
+ } else {+ |
+
105 | ++ |
+ # The training layer has been trained before.+ |
+
106 | +! | +
+ private$status = TRUE+ |
+
107 | ++ |
+ }+ |
+
108 | +! | +
+ return(model)+ |
+
109 | ++ |
+ },+ |
+
110 | ++ |
+ #' @description+ |
+
111 | ++ |
+ #' Variable selection on the current layer.+ |
+
112 | ++ |
+ #'+ |
+
113 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
114 | ++ |
+ #' ID subset of individuals to be used for variable selection.+ |
+
115 | ++ |
+ #'+ |
+
116 | ++ |
+ #' @return+ |
+
117 | ++ |
+ #' The current layer is returned with the resulting model.+ |
+
118 | ++ |
+ #' @export+ |
+
119 | ++ |
+ #'+ |
+
120 | ++ |
+ varSelection = function (ind_subset = NULL) {+ |
+
121 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
122 | ++ |
+ # Stop if either selector or data is missing on this layer.+ |
+
123 | +! | +
+ if (!("VarSel" %in% layer_kc[ , "class"])){+ |
+
124 | +! | +
+ stop(sprintf("No var. sel. method on layer %s.", self$getId()))+ |
+
125 | ++ |
+ } else {+ |
+
126 | +! | +
+ if (!("TrainData" %in% layer_kc[ , "class"])) {+ |
+
127 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
128 | ++ |
+ }+ |
+
129 | ++ |
+ }+ |
+
130 | ++ |
+ # The learner is trained on the current dataset+ |
+
131 | +! | +
+ varsel_key = layer_kc[layer_kc$class == "VarSel" , "key"]+ |
+
132 | +! | +
+ varsel = self$getFromHashTable(key = varsel_key[1L])+ |
+
133 | +! | +
+ selected = varsel$varSelection(ind_subset = ind_subset)+ |
+
134 | +! | +
+ return(selected)+ |
+
135 | ++ |
+ },+ |
+
136 | ++ |
+ #' @description+ |
+
137 | ++ |
+ #' Predicts values for the new layer taking as argument.+ |
+
138 | ++ |
+ #'+ |
+
139 | ++ |
+ #' @param new_layer `TrainLayer()` \cr+ |
+
140 | ++ |
+ #' @param ind_subset `vector()` \cr+ |
+
141 | ++ |
+ #'+ |
+
142 | ++ |
+ #' @return+ |
+
143 | ++ |
+ #' A new [PredictLayer] object with the predicted data is returned.+ |
+
144 | ++ |
+ #' @export+ |
+
145 | ++ |
+ #'+ |
+
146 | ++ |
+ predict = function (new_layer,+ |
+
147 | ++ |
+ ind_subset = NULL) {+ |
+
148 | +! | +
+ k = self$getId()+ |
+
149 | ++ |
+ # Layer IDs must match together.+ |
+
150 | +! | +
+ if (k == new_layer$getId()) {+ |
+
151 | +! | +
+ m_layer = self$getModel()+ |
+
152 | ++ |
+ } else {+ |
+
153 | +! | +
+ stop("The new layer ID does not match with the current layer ID.")+ |
+
154 | ++ |
+ }+ |
+
155 | ++ |
+ # Check that a model exists on the current layer+ |
+
156 | +! | +
+ if (is.null(m_layer)) {+ |
+
157 | +! | +
+ stop(sprintf("There is no model stored on layer %s.",+ |
+
158 | +! | +
+ self$getId()))+ |
+
159 | ++ |
+ }+ |
+
160 | +! | +
+ new_data = new_layer$getNewData()+ |
+
161 | ++ |
+ # Predicting: Data and model exist on this layer.+ |
+
162 | ++ | + + | +
163 | +! | +
+ model = self$getModel()+ |
+
164 | +! | +
+ pred_data = model$predict(new_data = new_data,+ |
+
165 | +! | +
+ ind_subset = ind_subset)+ |
+
166 | ++ |
+ # Initialize a predicted layer to store predictions+ |
+
167 | +! | +
+ pred_layer = PredictLayer$new(+ |
+
168 | +! | +
+ id = private$id+ |
+
169 | ++ |
+ )+ |
+
170 | +! | +
+ pred_data$setPredictLayer(pred_layer)+ |
+
171 | +! | +
+ return(pred_layer)+ |
+
172 | ++ |
+ },+ |
+
173 | ++ |
+ #' @description+ |
+
174 | ++ |
+ #' Getter of the training dataset stored on the current layer.+ |
+
175 | ++ |
+ #'+ |
+
176 | ++ |
+ #' @return+ |
+
177 | ++ |
+ #' The stored [TrainData] object is returned.+ |
+
178 | ++ |
+ #' @export+ |
+
179 | ++ |
+ #'+ |
+
180 | ++ |
+ getTrainData = function () {+ |
+
181 | +1x | +
+ layer_kc = self$getKeyClass()+ |
+
182 | +1x | +
+ if ("TrainData" %in% layer_kc[ , "class"]) {+ |
+
183 | +! | +
+ train_data_key = layer_kc[layer_kc$class == "TrainData" ,+ |
+
184 | +! | +
+ "key"]+ |
+
185 | +! | +
+ train_data = self$getFromHashTable(key = train_data_key[1L])+ |
+
186 | ++ |
+ } else {+ |
+
187 | +1x | +
+ stop(sprintf("No train data on layer %s.", self$getId()))+ |
+
188 | ++ |
+ }+ |
+
189 | +! | +
+ return(train_data)+ |
+
190 | ++ |
+ },+ |
+
191 | ++ |
+ #' @description+ |
+
192 | ++ |
+ #' Getter of target values from the current layer.+ |
+
193 | ++ |
+ #'+ |
+
194 | ++ |
+ #' @return+ |
+
195 | ++ |
+ #' A \code{data.frame} containing individuals IDs and corresponding target values.+ |
+
196 | ++ |
+ #' @export+ |
+
197 | ++ |
+ #'+ |
+
198 | ++ |
+ getTargetValues = function () {+ |
+
199 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
200 | ++ |
+ # Stop if training data is missing on this layer.+ |
+
201 | +! | +
+ if (("TrainData" %in% layer_kc[ , "class"])) {+ |
+
202 | ++ |
+ # Searching for layer specific training dataset+ |
+
203 | +! | +
+ train_data_key = layer_kc[layer_kc$class == "TrainData" ,+ |
+
204 | +! | +
+ "key"]+ |
+
205 | +! | +
+ train_data = self$getTrainData()+ |
+
206 | +! | +
+ train_data_frame = train_data$getDataFrame()+ |
+
207 | +! | +
+ target_data = train_data_frame[ , c(train_data$getIndCol(),+ |
+
208 | +! | +
+ train_data$getTargetName())]+ |
+
209 | +! | +
+ return(target_data)+ |
+
210 | ++ |
+ } else {+ |
+
211 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
212 | ++ |
+ }+ |
+
213 | ++ |
+ },+ |
+
214 | ++ |
+ #' @description+ |
+
215 | ++ |
+ #' Getter of IDS from the current layer.+ |
+
216 | ++ |
+ #'+ |
+
217 | ++ |
+ #' @return+ |
+
218 | ++ |
+ #' A \code{data.frame} containing individuals IDs values.+ |
+
219 | ++ |
+ #' @export+ |
+
220 | ++ |
+ #'+ |
+
221 | ++ |
+ getIndIDs = function () {+ |
+
222 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
223 | ++ |
+ # Stop if training data is missing on this layer.+ |
+
224 | ++ |
+ # FIXME: Restrict this function to TrainData only.+ |
+
225 | +! | +
+ if (("NewData" %in% layer_kc[ , "class"])) {+ |
+
226 | ++ |
+ # Searching for layer specific new dataset+ |
+
227 | +! | +
+ data_key = layer_kc[layer_kc$class == "NewData" ,+ |
+
228 | +! | +
+ "key"]+ |
+
229 | +! | +
+ current_data = self$getNewData()+ |
+
230 | ++ |
+ } else {+ |
+
231 | +! | +
+ if (("TrainData" %in% layer_kc[ , "class"])) {+ |
+
232 | ++ |
+ # Searching for layer specific new dataset+ |
+
233 | +! | +
+ data_key = layer_kc[layer_kc$class == "TrainData" ,+ |
+
234 | +! | +
+ "key"]+ |
+
235 | +! | +
+ current_data = self$getTrainData()+ |
+
236 | ++ |
+ } else {+ |
+
237 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
238 | ++ |
+ }+ |
+
239 | ++ |
+ }+ |
+
240 | +! | +
+ current_data_frame = current_data$getDataFrame()+ |
+
241 | +! | +
+ ids_data = current_data_frame[ , current_data$getIndCol(), drop = FALSE]+ |
+
242 | +! | +
+ return(ids_data)+ |
+
243 | ++ |
+ },+ |
+
244 | ++ |
+ #' @description+ |
+
245 | ++ |
+ #' Getter of the new data.+ |
+
246 | ++ |
+ #'+ |
+
247 | ++ |
+ #' @return+ |
+
248 | ++ |
+ #' The stored [NewData] object is returned.+ |
+
249 | ++ |
+ #' @export+ |
+
250 | ++ |
+ # FIXME: This function has been moved to NewLayer, so remove it after testing.+ |
+
251 | ++ |
+ getNewData = function () {+ |
+
252 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
253 | +! | +
+ if (any(c("NewData", "TrainData") %in% layer_kc[ , "class"])) {+ |
+
254 | +! | +
+ if ("NewData" %in% layer_kc[ , "class"]) {+ |
+
255 | +! | +
+ new_data_key = layer_kc[layer_kc$class == "NewData" ,+ |
+
256 | +! | +
+ "key"]+ |
+
257 | +! | +
+ new_data = self$getFromHashTable(key = new_data_key[1L])+ |
+
258 | ++ |
+ } else {+ |
+
259 | +! | +
+ new_data = self$getTrainData()+ |
+
260 | ++ |
+ }+ |
+
261 | ++ |
+ } else {+ |
+
262 | +! | +
+ stop(sprintf("No new data on layer %s.", self$getId()))+ |
+
263 | ++ |
+ }+ |
+
264 | +! | +
+ return(new_data)+ |
+
265 | ++ |
+ },+ |
+
266 | ++ |
+ #' @description+ |
+
267 | ++ |
+ #' Getter of the learner.+ |
+
268 | ++ |
+ #'+ |
+
269 | ++ |
+ #' @return+ |
+
270 | ++ |
+ #' The stored [Lrner] object is returned.+ |
+
271 | ++ |
+ #' @export+ |
+
272 | ++ |
+ getLrner = function () {+ |
+
273 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
274 | +! | +
+ if (!("Lrner" %in% layer_kc[ , "class"])) {+ |
+
275 | +! | +
+ stop(sprintf("No Lrner on layer %s.", self$getId()))+ |
+
276 | ++ |
+ } else {+ |
+
277 | +! | +
+ lrner_key = layer_kc[layer_kc$class == "Lrner" ,+ |
+
278 | +! | +
+ "key"]+ |
+
279 | +! | +
+ lrner = self$getFromHashTable(key = lrner_key[1L])+ |
+
280 | ++ |
+ }+ |
+
281 | +! | +
+ return(lrner)+ |
+
282 | ++ |
+ },+ |
+
283 | ++ |
+ #' @description+ |
+
284 | ++ |
+ #' Getter of the variable selector.+ |
+
285 | ++ |
+ #'+ |
+
286 | ++ |
+ #' @return+ |
+
287 | ++ |
+ #' The stored [VarSel] object is returned.+ |
+
288 | ++ |
+ #' @export+ |
+
289 | ++ |
+ getVarSel = function () {+ |
+
290 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
291 | +! | +
+ if (!("VarSel" %in% layer_kc[ , "class"])) {+ |
+
292 | +! | +
+ stop(sprintf("No VarSel on layer %s.", self$getId()))+ |
+
293 | ++ |
+ } else {+ |
+
294 | +! | +
+ varsel_key = layer_kc[layer_kc$class == "VarSel" ,+ |
+
295 | +! | +
+ "key"]+ |
+
296 | +! | +
+ varsel = self$getFromHashTable(key = varsel_key[1L])+ |
+
297 | ++ |
+ }+ |
+
298 | +! | +
+ return(varsel)+ |
+
299 | ++ |
+ },+ |
+
300 | ++ |
+ #' @description+ |
+
301 | ++ |
+ #' Getter of the model.+ |
+
302 | ++ |
+ #'+ |
+
303 | ++ |
+ #' @return+ |
+
304 | ++ |
+ #' The stored [Model] object is returned.+ |
+
305 | ++ |
+ #' @export+ |
+
306 | ++ |
+ #'+ |
+
307 | ++ |
+ getModel = function () {+ |
+
308 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
309 | +! | +
+ if (!("Model" %in% layer_kc[ , "class"])) {+ |
+
310 | +! | +
+ stop(sprintf("No Model on layer %s.", self$getId()))+ |
+
311 | ++ |
+ } else {+ |
+
312 | +! | +
+ model_key = layer_kc[layer_kc$class == "Model" ,+ |
+
313 | +! | +
+ "key"]+ |
+
314 | +! | +
+ model = self$getFromHashTable(key = model_key[1L])+ |
+
315 | ++ |
+ }+ |
+
316 | +! | +
+ return(model)+ |
+
317 | ++ |
+ },+ |
+
318 | ++ |
+ #' @description+ |
+
319 | ++ |
+ #' Getter of predictions.+ |
+
320 | ++ |
+ #'+ |
+
321 | ++ |
+ #' @return+ |
+
322 | ++ |
+ #' The stored predictions are returned.+ |
+
323 | ++ |
+ #' @export+ |
+
324 | ++ |
+ # FIXME: Move this function to PredictLayer+ |
+
325 | ++ |
+ getPredictions = function () {+ |
+
326 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
327 | +! | +
+ if (!("Prediction" %in% layer_kc[ , "class"])) {+ |
+
328 | +! | +
+ stop(sprintf("No Prediction on layer %s.", self$getId()))+ |
+
329 | ++ |
+ } else {+ |
+
330 | +! | +
+ prediction_key = layer_kc[layer_kc$class == "Prediction",+ |
+
331 | +! | +
+ "key"]+ |
+
332 | +! | +
+ predictions = self$getFromHashTable(+ |
+
333 | +! | +
+ key = prediction_key[1L])+ |
+
334 | ++ |
+ }+ |
+
335 | +! | +
+ return(predictions)+ |
+
336 | ++ |
+ },+ |
+
337 | ++ |
+ #' @description+ |
+
338 | ++ |
+ #' Check whether a training data has been already stored.+ |
+
339 | ++ |
+ #'+ |
+
340 | ++ |
+ #' @return+ |
+
341 | ++ |
+ #' Boolean value+ |
+
342 | ++ |
+ #'+ |
+
343 | ++ |
+ #TODO: checkLrnerExist with "s"+ |
+
344 | ++ |
+ checkLrnerExist = function () {+ |
+
345 | +1x | +
+ return(super$checkClassExist(.class = "Lrner"))+ |
+
346 | ++ |
+ },+ |
+
347 | ++ |
+ #' @description+ |
+
348 | ++ |
+ #' Check whether a training data has been already stored.+ |
+
349 | ++ |
+ #'+ |
+
350 | ++ |
+ #' @return+ |
+
351 | ++ |
+ #' Boolean value+ |
+
352 | ++ |
+ #'+ |
+
353 | ++ |
+ checkTrainDataExist = function () {+ |
+
354 | +! | +
+ return(super$checkClassExist(.class = "TrainData"))+ |
+
355 | ++ |
+ },+ |
+
356 | ++ |
+ #' @description+ |
+
357 | ++ |
+ #' Generate summary.+ |
+
358 | ++ |
+ #'+ |
+
359 | ++ |
+ #' @export+ |
+
360 | ++ |
+ #'+ |
+
361 | ++ |
+ summary = function () {+ |
+
362 | +! | +
+ cat(sprintf(" Layer %s\n", self$getId()))+ |
+
363 | +! | +
+ cat(" ----------------\n")+ |
+
364 | +! | +
+ if (!private$status) {+ |
+
365 | +! | +
+ status = "Not trained"+ |
+
366 | ++ |
+ } else {+ |
+
367 | +! | +
+ status = "Trained"+ |
+
368 | ++ |
+ }+ |
+
369 | +! | +
+ cat(sprintf(" TrainLayer : %s\n", private$id))+ |
+
370 | +! | +
+ cat(sprintf(" Status : %s\n", status))+ |
+
371 | +! | +
+ stored_obj = self$getKeyClass()+ |
+
372 | +! | +
+ if (!nrow(stored_obj)) {+ |
+
373 | +! | +
+ cat(" Empty layer.\n")+ |
+
374 | ++ |
+ } else {+ |
+
375 | +! | +
+ cat(sprintf(" Nb. of objects stored : %s\n", nrow(stored_obj)))+ |
+
376 | ++ |
+ }+ |
+
377 | +! | +
+ cat(" ----------------\n")+ |
+
378 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
379 | +! | +
+ cat(sprintf(" Object(s) on layer %s\n\n", self$getId()))+ |
+
380 | +! | +
+ if (!nrow(layer_kc)) {+ |
+
381 | +! | +
+ cat(" Empty layer\n")+ |
+
382 | ++ |
+ }+ |
+
383 | +! | +
+ for (k in layer_kc[ , "key"]) {+ |
+
384 | +! | +
+ cat(" ----------------\n")+ |
+
385 | +! | +
+ current_obj = self$getFromHashTable(key = k)+ |
+
386 | +! | +
+ current_obj$summary()+ |
+
387 | +! | +
+ cat(" ----------------\n")+ |
+
388 | +! | +
+ cat("\n")+ |
+
389 | ++ |
+ }+ |
+
390 | ++ |
+ }+ |
+
391 | ++ |
+ ),+ |
+
392 | ++ |
+ private = list(+ |
+
393 | ++ |
+ train_study = NULL,+ |
+
394 | ++ |
+ status = FALSE+ |
+
395 | ++ |
+ ),+ |
+
396 | ++ |
+ # TODO: define a deep_clone function for this class.+ |
+
397 | ++ |
+ cloneable = FALSE+ |
+
398 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title PredictLayer Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements a layer. A [PredictLayer] object can only exist as a component of a [PredictStudy] object.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' A predicted layer can only contain [PredictData].+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #'+ |
+
9 | ++ |
+ #' @export+ |
+
10 | ++ |
+ #' @importFrom R6 R6Class+ |
+
11 | ++ |
+ #' @seealso [TrainStudy], [Lrner], [TrainData], [NewData] and [Model]+ |
+
12 | ++ |
+ PredictLayer <- R6Class("PredictLayer",+ |
+
13 | ++ |
+ inherit = HashTable,+ |
+
14 | ++ |
+ public = list(+ |
+
15 | ++ |
+ #' @description+ |
+
16 | ++ |
+ #' constructor+ |
+
17 | ++ |
+ #'+ |
+
18 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
19 | ++ |
+ #' The layer ID.+ |
+
20 | ++ |
+ initialize = function (id) {+ |
+
21 | +! | +
+ super$initialize(id = id)+ |
+
22 | ++ |
+ },+ |
+
23 | ++ |
+ #' @description+ |
+
24 | ++ |
+ #' Printer+ |
+
25 | ++ |
+ #' @param ... (any) \cr+ |
+
26 | ++ |
+ #'+ |
+
27 | ++ |
+ print = function (...){+ |
+
28 | +! | +
+ cat(sprintf("PredictLayer : %s\n", private$id))+ |
+
29 | +! | +
+ cat(sprintf("Contains %s object.\n", length(private$hash_table)))+ |
+
30 | ++ |
+ },+ |
+
31 | ++ |
+ #' @description+ |
+
32 | ++ |
+ #' Getter of the current study+ |
+
33 | ++ |
+ #'+ |
+
34 | ++ |
+ #' @return+ |
+
35 | ++ |
+ #' The current study is returned.+ |
+
36 | ++ |
+ #'+ |
+
37 | ++ |
+ getPredictStudy = function () {+ |
+
38 | +! | +
+ return(private$predict_study)+ |
+
39 | ++ |
+ },+ |
+
40 | ++ |
+ #' @description+ |
+
41 | ++ |
+ #' Getter of IDS from the current layer.+ |
+
42 | ++ |
+ #'+ |
+
43 | ++ |
+ #' @return+ |
+
44 | ++ |
+ #' A \code{data.frame} containing individuals IDs values.+ |
+
45 | ++ |
+ #' @export+ |
+
46 | ++ |
+ #'+ |
+
47 | ++ |
+ getIndIDs = function () {+ |
+
48 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
49 | ++ |
+ # Stop if training data is missing on this layer.+ |
+
50 | +! | +
+ if (("PredictData" %in% layer_kc[ , "class"])) {+ |
+
51 | ++ |
+ # Searching for layer specific new dataset+ |
+
52 | +! | +
+ data_key = layer_kc[layer_kc$class == "PredictData" ,+ |
+
53 | +! | +
+ "key"]+ |
+
54 | +! | +
+ current_data = self$getPredictData()+ |
+
55 | ++ |
+ } else {+ |
+
56 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
57 | ++ |
+ }+ |
+
58 | +! | +
+ current_data_frame = current_data$getDataFrame()+ |
+
59 | +! | +
+ ids_data = current_data_frame[ , current_data$getIndCol(), drop = FALSE]+ |
+
60 | +! | +
+ return(ids_data)+ |
+
61 | ++ |
+ },+ |
+
62 | ++ |
+ #' @description+ |
+
63 | ++ |
+ #' Getter of the predicted data stored on the current layer.+ |
+
64 | ++ |
+ #'+ |
+
65 | ++ |
+ #' @return+ |
+
66 | ++ |
+ #' The stored [PredictData] object is returned.+ |
+
67 | ++ |
+ #' @export+ |
+
68 | ++ |
+ #'+ |
+
69 | ++ |
+ getPredictData = function () {+ |
+
70 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
71 | +! | +
+ if ("PredictData" %in% layer_kc[ , "class"]) {+ |
+
72 | +! | +
+ predict_data_key = layer_kc[layer_kc$class == "PredictData" ,+ |
+
73 | +! | +
+ "key"]+ |
+
74 | +! | +
+ predict_data = self$getFromHashTable(key = predict_data_key[1L])+ |
+
75 | ++ |
+ } else {+ |
+
76 | +! | +
+ stop(sprintf("No predicted data on layer %s.", self$getId()))+ |
+
77 | ++ |
+ }+ |
+
78 | +! | +
+ return(predict_data)+ |
+
79 | ++ |
+ },+ |
+
80 | ++ |
+ #' @description+ |
+
81 | ++ |
+ #' Assigns a predicted study to the predicted layer.+ |
+
82 | ++ |
+ #'+ |
+
83 | ++ |
+ #' @param predict_study `PredictStudy(1)` \cr+ |
+
84 | ++ |
+ #'+ |
+
85 | ++ |
+ #' @return+ |
+
86 | ++ |
+ #' The current object+ |
+
87 | ++ |
+ #'+ |
+
88 | ++ |
+ setPredictStudy = function (predict_study) {+ |
+
89 | +! | +
+ if (!is.null(private$predict_study)) {+ |
+
90 | +! | +
+ stop(sprintf("This layer already belong to study",+ |
+
91 | +! | +
+ private$predict_study$getId()))+ |
+
92 | ++ |
+ } else {+ |
+
93 | +! | +
+ if ("PredictStudy" %in% class(predict_study)) {+ |
+
94 | +! | +
+ predict_study$add2HashTable(key = private$id,+ |
+
95 | +! | +
+ value = self,+ |
+
96 | +! | +
+ .class = "PredictLayer")+ |
+
97 | ++ |
+ } else {+ |
+
98 | +! | +
+ stop("A PredictLayer can only belong to a PredictStudy.")+ |
+
99 | ++ |
+ }+ |
+
100 | ++ |
+ }+ |
+
101 | +! | +
+ return(self)+ |
+
102 | ++ |
+ },+ |
+
103 | ++ |
+ #' @description+ |
+
104 | ++ |
+ #' Generate summary.+ |
+
105 | ++ |
+ #'+ |
+
106 | ++ |
+ #' @export+ |
+
107 | ++ |
+ #'+ |
+
108 | ++ |
+ summary = function () {+ |
+
109 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
110 | +! | +
+ for (k in layer_kc[ , "key"]) {+ |
+
111 | +! | +
+ current_obj = self$getFromHashTable(key = k)+ |
+
112 | +! | +
+ print(current_obj)+ |
+
113 | +! | +
+ cat("\n")+ |
+
114 | ++ |
+ }+ |
+
115 | ++ |
+ }+ |
+
116 | ++ |
+ ),+ |
+
117 | ++ |
+ private = list(+ |
+
118 | ++ |
+ predict_study = NULL+ |
+
119 | ++ |
+ ),+ |
+
120 | ++ |
+ cloneable = FALSE+ |
+
121 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Class HashTable+ |
+
2 | ++ |
+ #' @description Hashtable to contain object entities. Study and layers are extensions of this class.+ |
+
3 | ++ |
+ #'+ |
+
4 | ++ |
+ #' @export+ |
+
5 | ++ |
+ #' @importFrom R6 R6Class+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' @importFrom digest digest+ |
+
8 | ++ |
+ HashTable <- R6Class("HashTable",+ |
+
9 | ++ |
+ public = list(+ |
+
10 | ++ |
+ #' @description+ |
+
11 | ++ |
+ #' Initialize a default parameters list.+ |
+
12 | ++ |
+ #'+ |
+
13 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
14 | ++ |
+ #' ID of the hash table. It must be unique.+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @export+ |
+
17 | ++ |
+ initialize = function (id) {+ |
+
18 | +3x | +
+ private$id = id+ |
+
19 | +3x | +
+ private$key_class = data.frame(key = character(0L),+ |
+
20 | +3x | +
+ class = character(0L))+ |
+
21 | +3x | +
+ private$hash_table = new.env(hash = TRUE,+ |
+
22 | +3x | +
+ parent = emptyenv())+ |
+
23 | ++ |
+ },+ |
+
24 | ++ |
+ #' @description+ |
+
25 | ++ |
+ #' Function to add a key-value pair to the hash table.+ |
+
26 | ++ |
+ #' @param key (`character(1)`) \cr+ |
+
27 | ++ |
+ #' The key to be added.+ |
+
28 | ++ |
+ #' @param value (`object(1)`) \cr+ |
+
29 | ++ |
+ #' Object to be added.+ |
+
30 | ++ |
+ #' @param .class (`character(1)`) \cr+ |
+
31 | ++ |
+ #' Class of the object to be added.+ |
+
32 | ++ |
+ #' @export+ |
+
33 | ++ |
+ #'+ |
+
34 | ++ |
+ add2HashTable = function (key, value, .class) {+ |
+
35 | +2x | +
+ hash_key = digest(key, algo = "xxhash64")+ |
+
36 | +2x | +
+ private$hash_table[[hash_key]] = value+ |
+
37 | ++ |
+ # Tests if the instance has already been stored and+ |
+
38 | ++ |
+ # updates table accordingly.+ |
+
39 | +2x | +
+ if (!nrow(self$getKeyClass())) {+ |
+
40 | +2x | +
+ private$key_class[nrow(private$key_class) + 1L, ] = c(key,+ |
+
41 | +2x | +
+ .class)+ |
+
42 | ++ |
+ } else {+ |
+
43 | +! | +
+ key_exists = (key %in% self$getKeyClass()$key)+ |
+
44 | +! | +
+ class_exists = (.class %in% self$getKeyClass()$class)+ |
+
45 | +! | +
+ if (!(key_exists & class_exists)) {+ |
+
46 | +! | +
+ private$key_class[nrow(private$key_class) + 1L, ] = c(key,+ |
+
47 | +! | +
+ .class)+ |
+
48 | ++ |
+ }+ |
+
49 | ++ |
+ }+ |
+
50 | +2x | +
+ invisible(private)+ |
+
51 | ++ |
+ },+ |
+
52 | ++ |
+ #' @description+ |
+
53 | ++ |
+ #' Getter of the object which the key passed as argument.+ |
+
54 | ++ |
+ #'+ |
+
55 | ++ |
+ #' @param key `character()` \cr+ |
+
56 | ++ |
+ #' Key of the required object.+ |
+
57 | ++ |
+ #'+ |
+
58 | ++ |
+ #' @export+ |
+
59 | ++ |
+ #'+ |
+
60 | ++ |
+ getFromHashTable = function (key) {+ |
+
61 | +! | +
+ hash_key = digest(key, algo = "xxhash64")+ |
+
62 | +! | +
+ if (exists(hash_key, envir = private$hash_table)) {+ |
+
63 | +! | +
+ return(private$hash_table[[hash_key]])+ |
+
64 | ++ |
+ } else {+ |
+
65 | +! | +
+ return(NULL)+ |
+
66 | ++ |
+ }+ |
+
67 | ++ |
+ },+ |
+
68 | ++ |
+ #' @description+ |
+
69 | ++ |
+ #' Getter of the \code{data.frame} that stores all key class pairs.+ |
+
70 | ++ |
+ #'+ |
+
71 | ++ |
+ #' @return+ |
+
72 | ++ |
+ #' [data.frame]+ |
+
73 | ++ |
+ #'+ |
+
74 | ++ |
+ #' @export+ |
+
75 | ++ |
+ #'+ |
+
76 | ++ |
+ getKeyClass = function () {+ |
+
77 | +3x | +
+ return(private$key_class)+ |
+
78 | ++ |
+ },+ |
+
79 | ++ |
+ #' @description+ |
+
80 | ++ |
+ #' Remove the object with the corresponding key from the hashtable.+ |
+
81 | ++ |
+ #'+ |
+
82 | ++ |
+ #' @param key+ |
+
83 | ++ |
+ #' Key of the object to be removed.+ |
+
84 | ++ |
+ #'+ |
+
85 | ++ |
+ #' @export+ |
+
86 | ++ |
+ #'+ |
+
87 | ++ |
+ removeFromHashTable = function (key) {+ |
+
88 | +! | +
+ hash_key = digest(key, algo = "xxhash64")+ |
+
89 | +! | +
+ if (exists(hash_key, envir = private$hash_table)) {+ |
+
90 | +! | +
+ rm(list = hash_key, envir = private$hash_table)+ |
+
91 | +! | +
+ rm_index = which(private$key_class$key == key)+ |
+
92 | +! | +
+ private$key_class = private$key_class[- rm_index , ]+ |
+
93 | ++ |
+ }+ |
+
94 | +! | +
+ invisible(TRUE)+ |
+
95 | ++ |
+ },+ |
+
96 | ++ |
+ #' @description+ |
+
97 | ++ |
+ #' Printer+ |
+
98 | ++ |
+ #' @param ... (any) \cr+ |
+
99 | ++ |
+ #'+ |
+
100 | ++ |
+ #' @export+ |
+
101 | ++ |
+ #'+ |
+
102 | ++ |
+ print = function (...) {+ |
+
103 | +! | +
+ cat("Class: HashTable\n")+ |
+
104 | +! | +
+ cat(sprintf("id: %s\n", private$id))+ |
+
105 | +! | +
+ cat("-----------------\n")+ |
+
106 | +! | +
+ print(private$key_class)+ |
+
107 | ++ |
+ },+ |
+
108 | ++ |
+ #' @description+ |
+
109 | ++ |
+ #' Getter of the current object ID.+ |
+
110 | ++ |
+ #'+ |
+
111 | ++ |
+ #' @export+ |
+
112 | ++ |
+ #'+ |
+
113 | ++ |
+ getId = function () {+ |
+
114 | +1x | +
+ return(private$id)+ |
+
115 | ++ |
+ },+ |
+
116 | ++ |
+ #' @description+ |
+
117 | ++ |
+ #' Getter of the current hashtable.+ |
+
118 | ++ |
+ #'+ |
+
119 | ++ |
+ #' @export+ |
+
120 | ++ |
+ getHashTable = function () {+ |
+
121 | +! | +
+ return(private$hash_table)+ |
+
122 | ++ |
+ },+ |
+
123 | ++ |
+ #' @description+ |
+
124 | ++ |
+ #' Check whether object from a class has already been stored.+ |
+
125 | ++ |
+ #'+ |
+
126 | ++ |
+ #' @param .class `character()` \cr+ |
+
127 | ++ |
+ #'+ |
+
128 | ++ |
+ #' @return+ |
+
129 | ++ |
+ #' Boolean value+ |
+
130 | ++ |
+ #'+ |
+
131 | ++ |
+ checkClassExist = function (.class) {+ |
+
132 | +1x | +
+ return(.class %in% private$key_class$class)+ |
+
133 | ++ |
+ }+ |
+
134 | ++ |
+ ),+ |
+
135 | ++ |
+ private = list(+ |
+
136 | ++ |
+ id = character(0L),+ |
+
137 | ++ |
+ hash_table = NULL,+ |
+
138 | ++ |
+ key_class = NULL+ |
+
139 | ++ |
+ ),+ |
+
140 | ++ |
+ # TODO: define a deep_clone function for this class.+ |
+
141 | ++ |
+ cloneable = FALSE+ |
+
142 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title TrainData Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements the training data. A [TrainData] object can only+ |
+
5 | ++ |
+ #' exist as a component of a [TrainLayer] or a [TrainMetaLayer] object.+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' @export+ |
+
8 | ++ |
+ #'+ |
+
9 | ++ |
+ #' @importFrom R6 R6Class+ |
+
10 | ++ |
+ #' @seealso [TrainLayer], [Lrner], [Model], [ParamLrner], [NewData]+ |
+
11 | ++ |
+ TrainData <- R6Class("TrainData",+ |
+
12 | ++ |
+ inherit = Data,+ |
+
13 | ++ |
+ public = list(+ |
+
14 | ++ |
+ #' @description+ |
+
15 | ++ |
+ #' Initialize a new object from the current class.+ |
+
16 | ++ |
+ #'+ |
+
17 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
18 | ++ |
+ #' The Object ID.+ |
+
19 | ++ |
+ #' @param data_frame (`data.frame(1)`)\cr+ |
+
20 | ++ |
+ #' \code{data.frame} containing data.+ |
+
21 | ++ |
+ #' @param train_layer (`TrainLayer(1)`) \cr+ |
+
22 | ++ |
+ #' Training layer where to store the current object.+ |
+
23 | ++ |
+ initialize = function (id,+ |
+
24 | ++ |
+ data_frame,+ |
+
25 | ++ |
+ train_layer) {+ |
+
26 | +! | +
+ ind_col = train_layer$getTrainStudy()$getIndCol()+ |
+
27 | +! | +
+ target = train_layer$getTrainStudy()$getTarget()+ |
+
28 | +! | +
+ if (!any(c("TrainLayer", "TrainMetaLayer") %in% class(train_layer))) {+ |
+
29 | +! | +
+ stop("A Traindata can belong a TrainLayer or a TrainMetaLayer object.\n")+ |
+
30 | ++ |
+ }+ |
+
31 | +! | +
+ if (!all(c(ind_col, target) %in% colnames(data_frame))) {+ |
+
32 | +! | +
+ stop("Individual column ID or target variable not found in the provided data.frame.\n")+ |
+
33 | ++ |
+ }+ |
+
34 | +! | +
+ missing_target = is.na(data_frame[ , target])+ |
+
35 | +! | +
+ if (any(missing_target)) {+ |
+
36 | +! | +
+ warning(sprintf("%s individual(s) with missing target value(s) recognized and removed\n",+ |
+
37 | +! | +
+ sum(missing_target)))+ |
+
38 | +! | +
+ data_frame = data_frame[!missing_target]+ |
+
39 | ++ |
+ }+ |
+
40 | +! | +
+ super$initialize(id = id,+ |
+
41 | +! | +
+ ind_col = train_layer$getTrainStudy()$getIndCol(),+ |
+
42 | +! | +
+ data_frame = data_frame)+ |
+
43 | +! | +
+ private$target = train_layer$getTrainStudy()$getTarget()+ |
+
44 | +! | +
+ if (train_layer$checkTrainDataExist()) {+ |
+
45 | +! | +
+ stop(sprintf("Only one training data is allowed per training layer.\n The training data %s already exists on the training layer %s.\n",+ |
+
46 | +! | +
+ private$id,+ |
+
47 | +! | +
+ train_layer$getId()))+ |
+
48 | ++ |
+ }+ |
+
49 | +! | +
+ private$train_layer = train_layer+ |
+
50 | +! | +
+ if (length(unique(self$getTargetValues())) > 2) {+ |
+
51 | +! | +
+ stop("Only a binary or dichotomous target variable is allowed.")+ |
+
52 | ++ |
+ }+ |
+
53 | ++ |
+ # Add to object to ht+ |
+
54 | +! | +
+ if ("TrainMetaLayer" %in% class(train_layer)) {+ |
+
55 | +! | +
+ if (train_layer$getAccess()) {+ |
+
56 | +! | +
+ train_layer$add2HashTable(key = private$id,+ |
+
57 | +! | +
+ value = self,+ |
+
58 | +! | +
+ .class = "TrainData")+ |
+
59 | ++ |
+ } else {+ |
+
60 | +! | +
+ stop("Training data cannot not be added manually to a meta training layer.")+ |
+
61 | ++ |
+ }+ |
+
62 | ++ |
+ } else {+ |
+
63 | +! | +
+ train_layer$add2HashTable(key = private$id,+ |
+
64 | +! | +
+ value = self,+ |
+
65 | +! | +
+ .class = "TrainData")+ |
+
66 | ++ |
+ }+ |
+
67 | ++ |
+ },+ |
+
68 | ++ |
+ #' @description+ |
+
69 | ++ |
+ #' Printer+ |
+
70 | ++ |
+ #' @param ... (any) \cr+ |
+
71 | ++ |
+ #'+ |
+
72 | ++ |
+ print = function (...) {+ |
+
73 | +! | +
+ cat(sprintf("TrainData : %s\n", private$id))+ |
+
74 | +! | +
+ cat(sprintf("Layer : %s\n", private$train_layer$getId()))+ |
+
75 | +! | +
+ cat(sprintf("ind. id. : %s\n", private$ind_col))+ |
+
76 | +! | +
+ cat(sprintf("target : %s\n", private$target))+ |
+
77 | +! | +
+ cat(sprintf("n : %s\n", nrow(private$data_frame)))+ |
+
78 | +! | +
+ cat(sprintf("Missing : %s\n", sum(!complete.cases(private$data_frame))))+ |
+
79 | +! | +
+ cat(sprintf("p : %s\n", ncol(private$data_frame)))+ |
+
80 | ++ |
+ },+ |
+
81 | ++ |
+ #' @description+ |
+
82 | ++ |
+ #' Summary+ |
+
83 | ++ |
+ #' @param ... (any) \cr+ |
+
84 | ++ |
+ #'+ |
+
85 | ++ |
+ summary = function (...) {+ |
+
86 | +! | +
+ cat(sprintf(" TrainData : %s\n", private$id))+ |
+
87 | +! | +
+ cat(sprintf(" Layer : %s\n", private$train_layer$getId()))+ |
+
88 | +! | +
+ cat(sprintf(" ind. id. : %s\n", private$ind_col))+ |
+
89 | +! | +
+ cat(sprintf(" target : %s\n", private$target))+ |
+
90 | +! | +
+ cat(sprintf(" n : %s\n", nrow(private$data_frame)))+ |
+
91 | +! | +
+ cat(sprintf(" Missing : %s\n", sum(!complete.cases(private$data_frame))))+ |
+
92 | +! | +
+ cat(sprintf(" p : %s\n", ncol(private$data_frame)))+ |
+
93 | ++ |
+ },+ |
+
94 | ++ |
+ #' @description+ |
+
95 | ++ |
+ #' Getter of the current \code{data.frame} wihtout individual+ |
+
96 | ++ |
+ #' ID nor target variables.+ |
+
97 | ++ |
+ #'+ |
+
98 | ++ |
+ #' @return+ |
+
99 | ++ |
+ #' The \code{data.frame} without individual ID nor target variables is returned.+ |
+
100 | ++ |
+ #' @export+ |
+
101 | ++ |
+ #'+ |
+
102 | ++ |
+ getData = function () {+ |
+
103 | +! | +
+ tmp_data <- private$data_frame+ |
+
104 | +! | +
+ tmp_data[[private$ind_col]] <- NULL+ |
+
105 | +! | +
+ tmp_data[[private$target]] <- NULL+ |
+
106 | +! | +
+ return(tmp_data)+ |
+
107 | ++ |
+ },+ |
+
108 | ++ |
+ #' @description+ |
+
109 | ++ |
+ #' Getter of target values stored on the current training layer.+ |
+
110 | ++ |
+ #'+ |
+
111 | ++ |
+ #' @return+ |
+
112 | ++ |
+ #' The observed target values stored on the current training layer are returned.+ |
+
113 | ++ |
+ #' @export+ |
+
114 | ++ |
+ #'+ |
+
115 | ++ |
+ getTargetValues = function () {+ |
+
116 | +! | +
+ return(private$data_frame[[private$target]])+ |
+
117 | ++ |
+ },+ |
+
118 | ++ |
+ #' @description+ |
+
119 | ++ |
+ #' Getter of the target variable name.+ |
+
120 | ++ |
+ #'+ |
+
121 | ++ |
+ #' @export+ |
+
122 | ++ |
+ #'+ |
+
123 | ++ |
+ getTargetName = function () {+ |
+
124 | +! | +
+ return(private$target)+ |
+
125 | ++ |
+ },+ |
+
126 | ++ |
+ #' @description+ |
+
127 | ++ |
+ #' Getter of the current training layer.+ |
+
128 | ++ |
+ #'+ |
+
129 | ++ |
+ #' @return+ |
+
130 | ++ |
+ #' The training layer (from class [TrainLayer]) on which the current train data are stored+ |
+
131 | ++ |
+ #' is returned.+ |
+
132 | ++ |
+ #' @export+ |
+
133 | ++ |
+ #'+ |
+
134 | ++ |
+ getTrainLayer = function () {+ |
+
135 | +! | +
+ return(private$train_layer)+ |
+
136 | ++ |
+ },+ |
+
137 | ++ |
+ #' @description+ |
+
138 | ++ |
+ #' Getter of the current layer.+ |
+
139 | ++ |
+ #'+ |
+
140 | ++ |
+ #' @return+ |
+
141 | ++ |
+ #' The layer (from class [NewLayer]) on which the current train data are stored+ |
+
142 | ++ |
+ #' is returned.+ |
+
143 | ++ |
+ #' @export+ |
+
144 | ++ |
+ #'+ |
+
145 | ++ |
+ #TODO: Maybe rename getNewLayer, getTrainLayer and getPredictLayer as getLayer?+ |
+
146 | ++ |
+ getNewLayer = function () {+ |
+
147 | +! | +
+ return(private$train_layer)+ |
+
148 | ++ |
+ }+ |
+
149 | ++ |
+ ),+ |
+
150 | ++ |
+ private = list(+ |
+
151 | ++ |
+ target = character(0L),+ |
+
152 | ++ |
+ train_layer = NULL+ |
+
153 | ++ |
+ ),+ |
+
154 | ++ |
+ cloneable = TRUE+ |
+
155 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title NewStudy Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class is the basic class of the present package. An object from this class+ |
+
5 | ++ |
+ #' is designed to contain multiple layers, but only one new meta layer.+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' A study is structured as followed:+ |
+
8 | ++ |
+ #' * [NewLayer]+ |
+
9 | ++ |
+ #' * [NewMetaLayer]+ |
+
10 | ++ |
+ #'+ |
+
11 | ++ |
+ #' @export+ |
+
12 | ++ |
+ #'+ |
+
13 | ++ |
+ #' @importFrom R6 R6Class+ |
+
14 | ++ |
+ #'+ |
+
15 | ++ |
+ #' @seealso [TrainLayer]+ |
+
16 | ++ |
+ NewStudy <- R6Class("NewStudy",+ |
+
17 | ++ |
+ inherit = HashTable,+ |
+
18 | ++ |
+ public = list(+ |
+
19 | ++ |
+ #' @description+ |
+
20 | ++ |
+ #' constructor+ |
+
21 | ++ |
+ #'+ |
+
22 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
23 | ++ |
+ #' See class Param+ |
+
24 | ++ |
+ #' @param ind_col (`character(1)`)+ |
+
25 | ++ |
+ #' Name of column of individuals IDS+ |
+
26 | ++ |
+ initialize = function (id, ind_col) {+ |
+
27 | +! | +
+ super$initialize(id = id)+ |
+
28 | +! | +
+ private$ind_col = ind_col+ |
+
29 | ++ |
+ },+ |
+
30 | ++ |
+ #' @description+ |
+
31 | ++ |
+ #' Printer+ |
+
32 | ++ |
+ #'+ |
+
33 | ++ |
+ #' @param ... (any) \cr+ |
+
34 | ++ |
+ #'+ |
+
35 | ++ |
+ print = function (...) {+ |
+
36 | +! | +
+ nb_layers = length(private$hash_table)+ |
+
37 | +! | +
+ cat(sprintf("NewStudy : %s\n", private$id))+ |
+
38 | +! | +
+ cat(sprintf("Number of layers: %s\n", nb_layers))+ |
+
39 | ++ |
+ },+ |
+
40 | ++ |
+ #' @param meta_layer_id (`character()`) \cr+ |
+
41 | ++ |
+ #' ID of the meta layer where the new meta data will be stored.+ |
+
42 | ++ |
+ #'+ |
+
43 | ++ |
+ #' @description+ |
+
44 | ++ |
+ #' Creates a new meta dataset based on layer predictions.+ |
+
45 | ++ |
+ #'+ |
+
46 | ++ |
+ #' @return+ |
+
47 | ++ |
+ #' A [NewData] is returned.+ |
+
48 | ++ |
+ #' @export+ |
+
49 | ++ |
+ #'+ |
+
50 | ++ |
+ createMetaNewData = function (meta_layer_id) {+ |
+
51 | ++ |
+ # predicted_study = self$predictLayer(new_study = new_study,+ |
+
52 | ++ |
+ # ind_subset = ind_subset)+ |
+
53 | +! | +
+ key_class_study = self$getKeyClass()+ |
+
54 | +! | +
+ predicted_values = NULL+ |
+
55 | +! | +
+ for (k in key_class_study[ , "key"]) {+ |
+
56 | ++ |
+ # FIXME: Maybe define a class Prediction instead of+ |
+
57 | ++ |
+ # using Hashtable?+ |
+
58 | +! | +
+ pred_layer = self$getFromHashTable(key = k)+ |
+
59 | +! | +
+ pred = pred_layer$getFromHashTable(key = "predict")+ |
+
60 | +! | +
+ predicted_values = data.frame(rbind(predicted_values,+ |
+
61 | +! | +
+ pred))+ |
+
62 | ++ |
+ }+ |
+
63 | ++ |
+ # Will transform meta data.frame into wide format+ |
+
64 | +! | +
+ predicted_values_wide = reshape(predicted_values,+ |
+
65 | +! | +
+ idvar = colnames(predicted_values)[2L],+ |
+
66 | +! | +
+ timevar = colnames(predicted_values)[1L],+ |
+
67 | +! | +
+ direction = "wide")+ |
+
68 | +! | +
+ colname_vector = gsub(pattern = "Prediction.",+ |
+
69 | +! | +
+ replacement = "",+ |
+
70 | +! | +
+ x = names(predicted_values_wide))+ |
+
71 | +! | +
+ names(predicted_values_wide) = colname_vector+ |
+
72 | +! | +
+ ind_ids = self$getIndIDs()+ |
+
73 | +! | +
+ predicted_values_wide = merge(x = ind_ids,+ |
+
74 | +! | +
+ y = predicted_values_wide,+ |
+
75 | +! | +
+ by = colnames(ind_ids)[1L],+ |
+
76 | +! | +
+ all.y = TRUE)+ |
+
77 | ++ |
+ # Add layer specific predictions to a new meta layer+ |
+
78 | +! | +
+ new_meta_layer = MetaLayer$new(id = meta_layer_id,+ |
+
79 | +! | +
+ study = self)+ |
+
80 | ++ |
+ # FIXME: Move this: Data should be created by the a new layer.+ |
+
81 | +! | +
+ new_meta_layer$openAccess()+ |
+
82 | +! | +
+ new_meta_layer$setNewData(id = "predicted",+ |
+
83 | +! | +
+ ind_col = names(predicted_values_wide)[1L],+ |
+
84 | +! | +
+ data_frame = predicted_values_wide,+ |
+
85 | +! | +
+ layer = meta_layer)+ |
+
86 | +! | +
+ new_meta_layer$closeAccess()+ |
+
87 | +! | +
+ return(new_meta_data)+ |
+
88 | ++ |
+ },+ |
+
89 | ++ |
+ #' @description+ |
+
90 | ++ |
+ #' Gather individual IDs from all layer.+ |
+
91 | ++ |
+ #'+ |
+
92 | ++ |
+ #' @return+ |
+
93 | ++ |
+ #' A \code{data.frame} containing individuals IDs.+ |
+
94 | ++ |
+ #' @export+ |
+
95 | ++ |
+ #'+ |
+
96 | ++ |
+ getIndIDs = function() {+ |
+
97 | ++ |
+ # FIXME: Adjust to the Predict class+ |
+
98 | +! | +
+ layers = self$getKeyClass()+ |
+
99 | ++ |
+ # This code accesses each layer (except the MetaLayer) level+ |
+
100 | ++ |
+ # and get the target variable+ |
+
101 | +! | +
+ layers = layers[layers$class %in% "NewLayer", ]+ |
+
102 | +! | +
+ ids_data = NULL+ |
+
103 | +! | +
+ current_data = NULL+ |
+
104 | +! | +
+ for (k in layers$key) {+ |
+
105 | +! | +
+ new_layer = self$getFromHashTable(key = k)+ |
+
106 | +! | +
+ ids_data = as.data.frame(rbind(ids_data,+ |
+
107 | +! | +
+ new_layer$getIndIDs()))+ |
+
108 | ++ |
+ }+ |
+
109 | +! | +
+ ids_data = ids_data[!duplicated(ids_data[ , 1L]), ,+ |
+
110 | +! | +
+ drop = FALSE]+ |
+
111 | +! | +
+ return(ids_data)+ |
+
112 | ++ |
+ },+ |
+
113 | ++ |
+ #' @description+ |
+
114 | ++ |
+ #' Getter of the meta layer.+ |
+
115 | ++ |
+ #'+ |
+
116 | ++ |
+ #' @return+ |
+
117 | ++ |
+ #' Object from class [NewMetaLayer]+ |
+
118 | ++ |
+ #' @export+ |
+
119 | ++ |
+ #'+ |
+
120 | ++ |
+ getNewMetaLayer = function () {+ |
+
121 | +! | +
+ new_layers = self$getKeyClass()+ |
+
122 | +! | +
+ new_meta_layer_key = layers[layers$class == "NewMetaLayer" , "key"]+ |
+
123 | +! | +
+ new_meta_layer = self$getFromHashTable(key = new_meta_layer_key)+ |
+
124 | +! | +
+ return(new_meta_layer)+ |
+
125 | ++ |
+ },+ |
+
126 | ++ |
+ #' @description+ |
+
127 | ++ |
+ #' Getter of the individual column name.+ |
+
128 | ++ |
+ #' @export+ |
+
129 | ++ |
+ getIndCol = function () {+ |
+
130 | +! | +
+ return(private$ind_col)+ |
+
131 | ++ |
+ },+ |
+
132 | ++ |
+ #' @description+ |
+
133 | ++ |
+ #' Getter of the target variable name.+ |
+
134 | ++ |
+ #' @export+ |
+
135 | ++ |
+ getTarget = function () {+ |
+
136 | +! | +
+ return(private$target)+ |
+
137 | ++ |
+ }+ |
+
138 | ++ |
+ ),+ |
+
139 | ++ |
+ private = list(+ |
+
140 | ++ |
+ ind_col = character(0L),+ |
+
141 | ++ |
+ target = character(0L)+ |
+
142 | ++ |
+ ),+ |
+
143 | ++ |
+ cloneable = FALSE+ |
+
144 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Varsel Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements a learner. A [VarSel] object can only exist as a component of a+ |
+
5 | ++ |
+ #' [TrainLayer] or a [TrainMetaLayer] object.+ |
+
6 | ++ |
+ #'+ |
+
7 | ++ |
+ #' @export+ |
+
8 | ++ |
+ #'+ |
+
9 | ++ |
+ #' @importFrom R6 R6Class+ |
+
10 | ++ |
+ VarSel <- R6Class("VarSel",+ |
+
11 | ++ |
+ public = list(+ |
+
12 | ++ |
+ #' @description+ |
+
13 | ++ |
+ #' Variable selection parameter list.+ |
+
14 | ++ |
+ #'+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' Learner ID.+ |
+
17 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
18 | ++ |
+ #' Package that implements the variable selection function.+ |
+
19 | ++ |
+ #' If NULL, the variable selection function is called from+ |
+
20 | ++ |
+ #' the current environment.+ |
+
21 | ++ |
+ #' @param package (`character(1)`) \cr+ |
+
22 | ++ |
+ #' Variable selection function name.+ |
+
23 | ++ |
+ #' @param varsel_fct (`character(1)`) \cr+ |
+
24 | ++ |
+ #' Variable selection parameters.+ |
+
25 | ++ |
+ #' @param param (`ParamVarSel(1)`) \cr+ |
+
26 | ++ |
+ #' Layer on which the learner is stored.+ |
+
27 | ++ |
+ #' @param train_layer (`TrainLayer(1)`) \cr+ |
+
28 | ++ |
+ #' The training layer where to store the learner.+ |
+
29 | ++ |
+ initialize = function (id,+ |
+
30 | ++ |
+ package = NULL,+ |
+
31 | ++ |
+ varsel_fct,+ |
+
32 | ++ |
+ param,+ |
+
33 | ++ |
+ train_layer) {+ |
+
34 | +! | +
+ private$id = id+ |
+
35 | +! | +
+ private$package = package+ |
+
36 | +! | +
+ private$varsel_fct = varsel_fct+ |
+
37 | +! | +
+ private$param = param+ |
+
38 | +! | +
+ if (!any(c("TrainLayer", "TrainMetaLayer") %in% class(train_layer))) {+ |
+
39 | +! | +
+ stop("A Lrner can only belong to a TrainLayer or a TrainMetaLayer object.")+ |
+
40 | ++ |
+ }+ |
+
41 | +! | +
+ if (train_layer$checkLrnerExist()) {+ |
+
42 | +! | +
+ stop(sprintf("Only one learner is allowed per training layer.\n The learner %s already exists on the training layer %s.\n",+ |
+
43 | +! | +
+ self$getId(),+ |
+
44 | +! | +
+ train_layer$getId()))+ |
+
45 | ++ |
+ }+ |
+
46 | +! | +
+ private$train_layer = train_layer+ |
+
47 | ++ |
+ # Add to object to ht+ |
+
48 | +! | +
+ train_layer$add2HashTable(key = private$id,+ |
+
49 | +! | +
+ value = self,+ |
+
50 | +! | +
+ .class = "VarSel")+ |
+
51 | ++ |
+ },+ |
+
52 | ++ |
+ #' @description+ |
+
53 | ++ |
+ #' Printer+ |
+
54 | ++ |
+ #' @param ... (any) \cr+ |
+
55 | ++ |
+ #'+ |
+
56 | ++ |
+ print = function (...) {+ |
+
57 | +! | +
+ cat(sprintf("VarSel : %s\n", private$id))+ |
+
58 | +! | +
+ cat(sprintf("TrainLayer : %s\n", private$train_layer$getId()))+ |
+
59 | +! | +
+ cat(sprintf("Package : %s\n", private$package))+ |
+
60 | +! | +
+ cat(sprintf("Function : %s\n", private$varsel_fct))+ |
+
61 | ++ |
+ },+ |
+
62 | ++ |
+ #' @description+ |
+
63 | ++ |
+ #' Summary+ |
+
64 | ++ |
+ #' @param ... (any) \cr+ |
+
65 | ++ |
+ #'+ |
+
66 | ++ |
+ summary = function (...) {+ |
+
67 | +! | +
+ cat(sprintf(" VarSel : %s\n", private$id))+ |
+
68 | +! | +
+ cat(sprintf(" TrainLayer : %s\n", private$train_layer$getId()))+ |
+
69 | +! | +
+ cat(sprintf(" Package : %s\n", private$package))+ |
+
70 | +! | +
+ cat(sprintf(" Function : %s\n", private$varsel_fct))+ |
+
71 | ++ |
+ },+ |
+
72 | ++ |
+ #' @description+ |
+
73 | ++ |
+ #' Tains the current learner (from class [Lrner]) on the current training data (from class [TrainData]).+ |
+
74 | ++ |
+ #'+ |
+
75 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
76 | ++ |
+ #' Individual ID subset on which the training will be performed.+ |
+
77 | ++ |
+ #'+ |
+
78 | ++ |
+ #' @return+ |
+
79 | ++ |
+ #' The resulting model, from class [Model], is returned.+ |
+
80 | ++ |
+ #' @export+ |
+
81 | ++ |
+ #'+ |
+
82 | ++ |
+ varSelection = function (ind_subset = NULL) {+ |
+
83 | +! | +
+ train_data = private$train_layer$getTrainData()+ |
+
84 | +! | +
+ if(private$train_layer$getId() != train_data$getTrainLayer()$getId()) {+ |
+
85 | +! | +
+ stop("Variable selection method and data must belong to the same layer.")+ |
+
86 | ++ |
+ }+ |
+
87 | ++ |
+ # Variable selection only on complete data+ |
+
88 | +! | +
+ train_data = train_data$clone(deep = FALSE)+ |
+
89 | +! | +
+ complete_data = train_data$getCompleteData()+ |
+
90 | +! | +
+ train_data$setDataFrame(data_frame = complete_data)+ |
+
91 | +! | +
+ if (is.null(private$package)) {+ |
+
92 | +! | +
+ varsel = private$varsel_fct+ |
+
93 | ++ |
+ } else {+ |
+
94 | +! | +
+ varsel = sprintf('%s::%s', private$package,+ |
+
95 | +! | +
+ private$varsel_fct)+ |
+
96 | ++ |
+ }+ |
+
97 | +! | +
+ varsel_param = private$param$getParamVarSel()+ |
+
98 | ++ |
+ # Prepare training dataset+ |
+
99 | +! | +
+ if (!is.null(ind_subset)) {+ |
+
100 | +! | +
+ train_data = train_data$getIndSubset(+ |
+
101 | +! | +
+ var_name = train_data$getIndCol(),+ |
+
102 | +! | +
+ value = ind_subset)+ |
+
103 | +! | +
+ private$ind_subset = ind_subset+ |
+
104 | ++ |
+ } else {+ |
+
105 | +! | +
+ private$ind_subset = "ALL"+ |
+
106 | ++ |
+ }+ |
+
107 | +! | +
+ varsel_param$x = train_data$getData()+ |
+
108 | +! | +
+ varsel_param$y = train_data$getTargetValues()+ |
+
109 | +! | +
+ varselected = do.call(eval(parse(text = varsel)),+ |
+
110 | +! | +
+ varsel_param)+ |
+
111 | ++ |
+ # Only confirmed variables are remained+ |
+
112 | +! | +
+ if (private$package == "Boruta") {+ |
+
113 | +! | +
+ tmp_param = list(x = varselected, withTentative = FALSE)+ |
+
114 | +! | +
+ get_varsel = sprintf('%s::getSelectedAttributes',+ |
+
115 | +! | +
+ private$package)+ |
+
116 | ++ |
+ # Get selected variables as vector+ |
+
117 | +! | +
+ varselected = do.call(eval(parse(text = get_varsel)),+ |
+
118 | +! | +
+ tmp_param)+ |
+
119 | ++ |
+ } else {+ |
+
120 | +! | +
+ if (is.vector(varselected)) {+ |
+
121 | +! | +
+ stop("Your variable selection function should return a vector of selected variables.")+ |
+
122 | ++ |
+ }+ |
+
123 | ++ |
+ }+ |
+
124 | +! | +
+ private$ind_subset = ind_subset+ |
+
125 | +! | +
+ if (!length(varselected)) {+ |
+
126 | +! | +
+ stop(sprintf("No variable selected on layer", train_layer$getId()))+ |
+
127 | ++ |
+ } else {+ |
+
128 | +! | +
+ private$var_subset = varselected+ |
+
129 | ++ |
+ }+ |
+
130 | +! | +
+ return(varselected)+ |
+
131 | ++ |
+ },+ |
+
132 | ++ |
+ #' @description+ |
+
133 | ++ |
+ #' The current layer is returned.+ |
+
134 | ++ |
+ #'+ |
+
135 | ++ |
+ #' @return+ |
+
136 | ++ |
+ #' [TrainLayer] object.+ |
+
137 | ++ |
+ #' @export+ |
+
138 | ++ |
+ #'+ |
+
139 | ++ |
+ getTrainLayer = function () {+ |
+
140 | +! | +
+ return(private$train_layer)+ |
+
141 | ++ |
+ },+ |
+
142 | ++ |
+ #' @description+ |
+
143 | ++ |
+ #' Getter of the current learner ID.+ |
+
144 | ++ |
+ #'+ |
+
145 | ++ |
+ #' @return+ |
+
146 | ++ |
+ #' The current learner ID.+ |
+
147 | ++ |
+ #' @export+ |
+
148 | ++ |
+ #'+ |
+
149 | ++ |
+ getId = function () {+ |
+
150 | +! | +
+ return(private$id)+ |
+
151 | ++ |
+ },+ |
+
152 | ++ |
+ #' @description+ |
+
153 | ++ |
+ #' Getter of the variable selection package implementing the variable selection function.+ |
+
154 | ++ |
+ #'+ |
+
155 | ++ |
+ #' @return+ |
+
156 | ++ |
+ #' The name of the package implementing the variable selection function.+ |
+
157 | ++ |
+ #'+ |
+
158 | ++ |
+ #' @export+ |
+
159 | ++ |
+ #'+ |
+
160 | ++ |
+ getPackage = function () {+ |
+
161 | +! | +
+ return(private$package)+ |
+
162 | ++ |
+ },+ |
+
163 | ++ |
+ #' @description+ |
+
164 | ++ |
+ #' Getter of the list of selected variables.+ |
+
165 | ++ |
+ #'+ |
+
166 | ++ |
+ #' @return+ |
+
167 | ++ |
+ #' List of selected variables..+ |
+
168 | ++ |
+ #'+ |
+
169 | ++ |
+ #' @export+ |
+
170 | ++ |
+ #'+ |
+
171 | ++ |
+ getVarSubSet = function () {+ |
+
172 | +! | +
+ return(private$var_subset)+ |
+
173 | ++ |
+ }+ |
+
174 | ++ |
+ ),+ |
+
175 | ++ |
+ private = list(+ |
+
176 | ++ |
+ # ID field.+ |
+
177 | ++ |
+ id = character(0L),+ |
+
178 | ++ |
+ # Package defining the learner (like \code{ranger}).+ |
+
179 | ++ |
+ package = NULL,+ |
+
180 | ++ |
+ # Learn function name (like \code{ranger}).+ |
+
181 | ++ |
+ varsel_fct = NULL,+ |
+
182 | ++ |
+ # Parameters (from class [Param]) of the learn function.+ |
+
183 | ++ |
+ param = NULL,+ |
+
184 | ++ |
+ # Training layer (from class [TainLayer] or [TrainMetaLayer]) of the current learner.+ |
+
185 | ++ |
+ train_layer = NULL,+ |
+
186 | ++ |
+ # Individuals subset IDs.+ |
+
187 | ++ |
+ ind_subset = NULL,+ |
+
188 | ++ |
+ # Variable subset IDs.+ |
+
189 | ++ |
+ var_subset = NULL+ |
+
190 | ++ |
+ ),+ |
+
191 | ++ |
+ cloneable = FALSE+ |
+
192 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Class ParamVarSel.+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' Implement the list of parameters to be passed to the [VarSel] object.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' @export+ |
+
7 | ++ |
+ #' @importFrom R6 R6Class+ |
+
8 | ++ |
+ ParamVarSel <- R6Class("ParamVarSel",+ |
+
9 | ++ |
+ inherit = Param,+ |
+
10 | ++ |
+ public = list(+ |
+
11 | ++ |
+ #' @description+ |
+
12 | ++ |
+ #' constructor+ |
+
13 | ++ |
+ #'+ |
+
14 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
15 | ++ |
+ #' See class Param+ |
+
16 | ++ |
+ #' @param param_list (`list(1)`)\cr+ |
+
17 | ++ |
+ #' See class Param+ |
+
18 | ++ |
+ #'+ |
+
19 | ++ |
+ initialize = function (id,+ |
+
20 | ++ |
+ param_list) {+ |
+
21 | +! | +
+ super$initialize(id = id, param_list = param_list)+ |
+
22 | ++ |
+ },+ |
+
23 | ++ |
+ #' @description+ |
+
24 | ++ |
+ #' Printer+ |
+
25 | ++ |
+ #' @param ... (any) \cr+ |
+
26 | ++ |
+ #'+ |
+
27 | ++ |
+ print = function(...){+ |
+
28 | +! | +
+ cat("Class: ParamVarSel\n")+ |
+
29 | +! | +
+ cat(sprintf("id : %s\n", private$id))+ |
+
30 | +! | +
+ cat("Parameter combination\n")+ |
+
31 | +! | +
+ print(private$param_list)+ |
+
32 | ++ |
+ },+ |
+
33 | ++ |
+ #' @description+ |
+
34 | ++ |
+ #' Getter of learner parameters.+ |
+
35 | ++ |
+ #'+ |
+
36 | ++ |
+ getParamVarSel = function() {+ |
+
37 | +! | +
+ return(private$param_list)+ |
+
38 | ++ |
+ }+ |
+
39 | ++ |
+ ),+ |
+
40 | ++ |
+ cloneable = TRUE+ |
+
41 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title NewLayer Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements a layer. A [NewLayer] object can only exist as a component of a [PredictStudy] object.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' A predicted layer can only contain [NewData].+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #'+ |
+
9 | ++ |
+ #' @export+ |
+
10 | ++ |
+ #' @importFrom R6 R6Class+ |
+
11 | ++ |
+ #' @seealso [TrainStudy], [Lrner], [TrainData], [NewData] and [Model]+ |
+
12 | ++ |
+ NewLayer <- R6Class("NewLayer",+ |
+
13 | ++ |
+ inherit = HashTable,+ |
+
14 | ++ |
+ public = list(+ |
+
15 | ++ |
+ #' @description+ |
+
16 | ++ |
+ #' constructor+ |
+
17 | ++ |
+ #'+ |
+
18 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
19 | ++ |
+ #' See class Param+ |
+
20 | ++ |
+ #' @param new_study (`NewStudy(1)`)\cr+ |
+
21 | ++ |
+ #'+ |
+
22 | ++ |
+ initialize = function (id, new_study) {+ |
+
23 | +! | +
+ super$initialize(id = id)+ |
+
24 | +! | +
+ private$new_study = new_study+ |
+
25 | +! | +
+ if ("NewStudy" %in% class(new_study)) {+ |
+
26 | +! | +
+ new_study$add2HashTable(key = id,+ |
+
27 | +! | +
+ value = self,+ |
+
28 | +! | +
+ .class = "NewLayer")+ |
+
29 | ++ |
+ } else {+ |
+
30 | +! | +
+ stop("A NewLayer can only belong to a NewStudy.")+ |
+
31 | ++ |
+ }+ |
+
32 | ++ |
+ },+ |
+
33 | ++ |
+ #' @description+ |
+
34 | ++ |
+ #' Printer+ |
+
35 | ++ |
+ #' @param ... (any) \cr+ |
+
36 | ++ |
+ #'+ |
+
37 | ++ |
+ print = function (...){+ |
+
38 | +! | +
+ cat(sprintf("NewLayer : %s\n", private$id))+ |
+
39 | +! | +
+ cat(sprintf("Contains %s object.\n", length(private$hash_table)))+ |
+
40 | ++ |
+ },+ |
+
41 | ++ |
+ #' @description+ |
+
42 | ++ |
+ #' Getter of the current study+ |
+
43 | ++ |
+ #'+ |
+
44 | ++ |
+ #' @return+ |
+
45 | ++ |
+ #' The current study is returned.+ |
+
46 | ++ |
+ #'+ |
+
47 | ++ |
+ getNewStudy = function () {+ |
+
48 | +! | +
+ return(private$new_study)+ |
+
49 | ++ |
+ },+ |
+
50 | ++ |
+ #' @description+ |
+
51 | ++ |
+ #' Getter of IDS from the current layer.+ |
+
52 | ++ |
+ #'+ |
+
53 | ++ |
+ #' @return+ |
+
54 | ++ |
+ #' A \code{data.frame} containing individuals IDs values.+ |
+
55 | ++ |
+ #' @export+ |
+
56 | ++ |
+ #'+ |
+
57 | ++ |
+ getIndIDs = function () {+ |
+
58 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
59 | ++ |
+ # Stop if training data is missing on this layer.+ |
+
60 | +! | +
+ if (("NewData" %in% layer_kc[ , "class"])) {+ |
+
61 | ++ |
+ # Searching for layer specific new dataset+ |
+
62 | +! | +
+ data_key = layer_kc[layer_kc$class == "NewData" ,+ |
+
63 | +! | +
+ "key"]+ |
+
64 | +! | +
+ current_data = self$getNewtData()+ |
+
65 | ++ |
+ } else {+ |
+
66 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
67 | ++ |
+ }+ |
+
68 | +! | +
+ current_data_frame = current_data$getDataFrame()+ |
+
69 | +! | +
+ ids_data = current_data_frame[ , current_data$getIndCol(), drop = FALSE]+ |
+
70 | +! | +
+ return(ids_data)+ |
+
71 | ++ |
+ },+ |
+
72 | ++ |
+ #' @description+ |
+
73 | ++ |
+ #' Getter of the predicted data stored on the current layer.+ |
+
74 | ++ |
+ #'+ |
+
75 | ++ |
+ #' @return+ |
+
76 | ++ |
+ #' The stored [NewData] object is returned.+ |
+
77 | ++ |
+ #' @export+ |
+
78 | ++ |
+ #'+ |
+
79 | ++ |
+ getNewData = function () {+ |
+
80 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
81 | +! | +
+ if ("NewData" %in% layer_kc[ , "class"]) {+ |
+
82 | +! | +
+ predict_data_key = layer_kc[layer_kc$class == "NewData" ,+ |
+
83 | +! | +
+ "key"]+ |
+
84 | +! | +
+ predict_data = self$getFromHashTable(key = predict_data_key[1L])+ |
+
85 | ++ |
+ } else {+ |
+
86 | +! | +
+ stop(sprintf("No predicted data on layer %s.", self$getId()))+ |
+
87 | ++ |
+ }+ |
+
88 | +! | +
+ return(predict_data)+ |
+
89 | ++ |
+ },+ |
+
90 | ++ |
+ #' @description+ |
+
91 | ++ |
+ #' Check whether a new data has been already stored.+ |
+
92 | ++ |
+ #'+ |
+
93 | ++ |
+ #' @return+ |
+
94 | ++ |
+ #' Boolean value+ |
+
95 | ++ |
+ #'+ |
+
96 | ++ |
+ checkNewDataExist = function () {+ |
+
97 | +! | +
+ return(super$checkClassExist(.class = "NewData"))+ |
+
98 | ++ |
+ },+ |
+
99 | ++ |
+ #' @description+ |
+
100 | ++ |
+ #' Generate summary.+ |
+
101 | ++ |
+ #'+ |
+
102 | ++ |
+ #' @export+ |
+
103 | ++ |
+ #'+ |
+
104 | ++ |
+ summary = function () {+ |
+
105 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
106 | +! | +
+ for (k in layer_kc[ , "key"]) {+ |
+
107 | +! | +
+ current_obj = self$getFromHashTable(key = k)+ |
+
108 | +! | +
+ print(current_obj)+ |
+
109 | +! | +
+ cat("\n")+ |
+
110 | ++ |
+ }+ |
+
111 | ++ |
+ }+ |
+
112 | ++ |
+ ),+ |
+
113 | ++ |
+ private = list(+ |
+
114 | ++ |
+ new_study = NULL+ |
+
115 | ++ |
+ ),+ |
+
116 | ++ |
+ # TODO: define a deep_clone function for this class.+ |
+
117 | ++ |
+ cloneable = FALSE+ |
+
118 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title TrainMetaLayer Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implement a meta meta layer. A [TrainMetaLayer] can only exist as unique element of a [TrainStudy] object.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' A layer is structured as followed:+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #' * [Lrner]: It is set by the user to be trained on the meta training data.+ |
+
9 | ++ |
+ #' * [TrainData]: It are meta data, automatically created by the internal cross validation.+ |
+
10 | ++ |
+ #' * [Model]: The meta model, result of training the learner on the training data, and therefore, not to be set by the user.+ |
+
11 | ++ |
+ #' * [NewData]: The meta new data to be predicted, consisting in predictions obtained from each layer.+ |
+
12 | ++ |
+ #'+ |
+
13 | ++ |
+ #' A meta layer can train its meta learner on the meta training data and store the resulting meta model.+ |
+
14 | ++ |
+ #' The meta layer can predict values given a new meta layer.+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @export+ |
+
17 | ++ |
+ #' @importFrom R6 R6Class+ |
+
18 | ++ |
+ TrainMetaLayer <- R6Class("TrainMetaLayer",+ |
+
19 | ++ |
+ inherit = HashTable,+ |
+
20 | ++ |
+ public = list(+ |
+
21 | ++ |
+ #' @description+ |
+
22 | ++ |
+ #' constructor+ |
+
23 | ++ |
+ #'+ |
+
24 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
25 | ++ |
+ #' See class Param+ |
+
26 | ++ |
+ #' @param train_study (`TrainStudy(1)`)\cr+ |
+
27 | ++ |
+ #'+ |
+
28 | ++ |
+ initialize = function (id, train_study) {+ |
+
29 | +! | +
+ super$initialize(id = id)+ |
+
30 | +! | +
+ private$train_study = train_study+ |
+
31 | +! | +
+ train_study$add2HashTable(key = id,+ |
+
32 | +! | +
+ value = self,+ |
+
33 | +! | +
+ .class = "TrainMetaLayer")+ |
+
34 | +! | +
+ private$status = FALSE+ |
+
35 | ++ |
+ },+ |
+
36 | ++ |
+ #' @description+ |
+
37 | ++ |
+ #' Printer+ |
+
38 | ++ |
+ #' @param ... (any) \cr+ |
+
39 | ++ |
+ #'+ |
+
40 | ++ |
+ print = function(...) {+ |
+
41 | +! | +
+ if (!private$status) {+ |
+
42 | +! | +
+ status = "Not trained"+ |
+
43 | ++ |
+ } else {+ |
+
44 | +! | +
+ status = "Trained"+ |
+
45 | ++ |
+ }+ |
+
46 | +! | +
+ cat(sprintf("TrainMetaLayer : %s\n", private$id))+ |
+
47 | +! | +
+ cat(sprintf("Status : %s\n", status))+ |
+
48 | +! | +
+ stored_obj = self$getKeyClass()+ |
+
49 | +! | +
+ if (!nrow(stored_obj)) {+ |
+
50 | +! | +
+ cat("Empty layer.\n")+ |
+
51 | ++ |
+ } else {+ |
+
52 | +! | +
+ cat(sprintf("Nb. of objects stored : %s\n", nrow(stored_obj)))+ |
+
53 | +! | +
+ print(stored_obj)+ |
+
54 | ++ |
+ }+ |
+
55 | ++ |
+ },+ |
+
56 | ++ |
+ #' @description+ |
+
57 | ++ |
+ #' Getter of the current training study+ |
+
58 | ++ |
+ #'+ |
+
59 | ++ |
+ #' @return+ |
+
60 | ++ |
+ #' The current training study is returned.+ |
+
61 | ++ |
+ #'+ |
+
62 | ++ |
+ getTrainStudy = function () {+ |
+
63 | +! | +
+ return(private$train_study)+ |
+
64 | ++ |
+ },+ |
+
65 | ++ |
+ #' @description+ |
+
66 | ++ |
+ #' Trains the current layer.+ |
+
67 | ++ |
+ #'+ |
+
68 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
69 | ++ |
+ #' ID subset of individuals to be used for training.+ |
+
70 | ++ |
+ #'+ |
+
71 | ++ |
+ #' @return+ |
+
72 | ++ |
+ #' The current layer is returned with the resulting model.+ |
+
73 | ++ |
+ #' @export+ |
+
74 | ++ |
+ #'+ |
+
75 | ++ |
+ train = function (ind_subset = NULL) {+ |
+
76 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
77 | ++ |
+ # Stop if either learner of data is missing on this layer.+ |
+
78 | +! | +
+ if (!("Lrner" %in% layer_kc[ , "class"])){+ |
+
79 | +! | +
+ stop(sprintf("No learner on layer %s.", self$getId()))+ |
+
80 | ++ |
+ } else {+ |
+
81 | +! | +
+ if (!("TrainData" %in% layer_kc[ , "class"])) {+ |
+
82 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
83 | ++ |
+ }+ |
+
84 | ++ |
+ }+ |
+
85 | ++ |
+ # The learner is trained on the current dataset+ |
+
86 | +! | +
+ lrner_key = layer_kc[layer_kc$class == "Lrner" , "key"]+ |
+
87 | +! | +
+ lrner = self$getFromHashTable(key = lrner_key[1L])+ |
+
88 | +! | +
+ model = lrner$train(ind_subset = ind_subset)+ |
+
89 | ++ |
+ # Updating the training status.+ |
+
90 | +! | +
+ if (!private$status) {+ |
+
91 | ++ |
+ # The training layer has not been trained before.+ |
+
92 | +! | +
+ private$train_study$increaseNbTrainedLayer()+ |
+
93 | +! | +
+ private$status = TRUE+ |
+
94 | ++ |
+ } else {+ |
+
95 | ++ |
+ # The training layer has been trained before.+ |
+
96 | +! | +
+ private$status = TRUE+ |
+
97 | ++ |
+ }+ |
+
98 | +! | +
+ return(model)+ |
+
99 | ++ |
+ },+ |
+
100 | ++ |
+ #' @description+ |
+
101 | ++ |
+ #' Predicts values for the new layer taking as argument.+ |
+
102 | ++ |
+ #'+ |
+
103 | ++ |
+ #' @param new_layer `TrainLayer(1)` \cr+ |
+
104 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
105 | ++ |
+ #'+ |
+
106 | ++ |
+ #' @return+ |
+
107 | ++ |
+ #' A new study with the predicted values is returned.+ |
+
108 | ++ |
+ #' @export+ |
+
109 | ++ |
+ #'+ |
+
110 | ++ |
+ predict = function (new_layer,+ |
+
111 | ++ |
+ ind_subset = NULL) {+ |
+
112 | +! | +
+ k = self$getId()+ |
+
113 | ++ |
+ # Layer IDs must match together.+ |
+
114 | +! | +
+ if (k == new_layer$getId()) {+ |
+
115 | +! | +
+ m_layer = self$getModel()+ |
+
116 | ++ |
+ } else {+ |
+
117 | +! | +
+ stop("The new layer ID does not match with the current layer ID.")+ |
+
118 | ++ |
+ }+ |
+
119 | ++ |
+ # Check that a model exists on the current layer+ |
+
120 | +! | +
+ if (is.null(m_layer)) {+ |
+
121 | +! | +
+ stop(sprintf("There is no model stored on layer %s.",+ |
+
122 | +! | +
+ self$getId()))+ |
+
123 | ++ |
+ }+ |
+
124 | +! | +
+ new_data = new_layer$getNewData()+ |
+
125 | ++ |
+ # Predicting: Data and model exist on this layer.+ |
+
126 | ++ |
+ # Initialize a layer to store predictions+ |
+
127 | ++ |
+ # pred_layer = HashTable$new(id = self$getId())+ |
+
128 | +! | +
+ pred_layer = PredictLayer$new(id = self$getId())+ |
+
129 | +! | +
+ model = self$getModel()+ |
+
130 | ++ |
+ # Layer specific prediction+ |
+
131 | +! | +
+ pred = model$predict(new_data = new_data,+ |
+
132 | +! | +
+ ind_subset = ind_subset)+ |
+
133 | ++ |
+ # Store predictions+ |
+
134 | ++ | + + | +
135 | +! | +
+ pred_layer$add2HashTable(key = "predict",+ |
+
136 | +! | +
+ value = pred,+ |
+
137 | +! | +
+ .class = "PredictData")+ |
+
138 | ++ | + + | +
139 | +! | +
+ return(pred_layer)+ |
+
140 | ++ |
+ },+ |
+
141 | ++ |
+ #' @description+ |
+
142 | ++ |
+ #' Getter of the training dataset stored on the current layer.+ |
+
143 | ++ |
+ #'+ |
+
144 | ++ |
+ #' @return+ |
+
145 | ++ |
+ #' The stored [TrainData] object is returned.+ |
+
146 | ++ |
+ #' @export+ |
+
147 | ++ |
+ #'+ |
+
148 | ++ |
+ getTrainData = function () {+ |
+
149 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
150 | +! | +
+ if ("TrainData" %in% layer_kc[ , "class"]) {+ |
+
151 | +! | +
+ train_data_key = layer_kc[layer_kc$class == "TrainData" ,+ |
+
152 | +! | +
+ "key"]+ |
+
153 | +! | +
+ train_data = self$getFromHashTable(key = train_data_key[1L])+ |
+
154 | ++ |
+ } else {+ |
+
155 | +! | +
+ stop(sprintf("No train data on layer %s.", self$getId()))+ |
+
156 | ++ |
+ }+ |
+
157 | +! | +
+ return(train_data)+ |
+
158 | ++ |
+ },+ |
+
159 | ++ |
+ #' @description+ |
+
160 | ++ |
+ #' Getter of the new data.+ |
+
161 | ++ |
+ #'+ |
+
162 | ++ |
+ #' @return+ |
+
163 | ++ |
+ #' The stored [NewData] object is returned.+ |
+
164 | ++ |
+ #' @export+ |
+
165 | ++ |
+ #'+ |
+
166 | ++ |
+ getNewData = function () {+ |
+
167 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
168 | +! | +
+ if (any(c("NewData", "TrainData") %in% layer_kc[ , "class"])) {+ |
+
169 | +! | +
+ if ("NewData" %in% layer_kc[ , "class"]) {+ |
+
170 | +! | +
+ new_data_key = layer_kc[layer_kc$class == "NewData" ,+ |
+
171 | +! | +
+ "key"]+ |
+
172 | +! | +
+ new_data = self$getFromHashTable(key = new_data_key[1L])+ |
+
173 | ++ |
+ } else {+ |
+
174 | +! | +
+ new_data = self$getTrainData()+ |
+
175 | ++ |
+ }+ |
+
176 | ++ |
+ } else {+ |
+
177 | +! | +
+ stop(sprintf("No new data on layer %s.", self$getId()))+ |
+
178 | ++ |
+ }+ |
+
179 | +! | +
+ return(new_data)+ |
+
180 | ++ |
+ },+ |
+
181 | ++ |
+ #' @description+ |
+
182 | ++ |
+ #' Getter of the learner.+ |
+
183 | ++ |
+ #'+ |
+
184 | ++ |
+ #' @return+ |
+
185 | ++ |
+ #' The stored [Lrner] object is returned.+ |
+
186 | ++ |
+ #' @export+ |
+
187 | ++ |
+ #'+ |
+
188 | ++ |
+ getLrner = function () {+ |
+
189 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
190 | +! | +
+ if (!("Lrner" %in% layer_kc[ , "class"])) {+ |
+
191 | +! | +
+ stop(sprintf("No Lrner on layer %s.", self$getId()))+ |
+
192 | ++ |
+ } else {+ |
+
193 | +! | +
+ lrner_key = layer_kc[layer_kc$class == "Lrner" ,+ |
+
194 | +! | +
+ "key"]+ |
+
195 | +! | +
+ lrner = self$getFromHashTable(key = lrner_key[1L])+ |
+
196 | ++ |
+ }+ |
+
197 | +! | +
+ return(lrner)+ |
+
198 | ++ |
+ },+ |
+
199 | ++ |
+ #' @description+ |
+
200 | ++ |
+ #' Getter of the model.+ |
+
201 | ++ |
+ #'+ |
+
202 | ++ |
+ #' @return+ |
+
203 | ++ |
+ #' The stored [Model] object is returned.+ |
+
204 | ++ |
+ #' @export+ |
+
205 | ++ |
+ getModel = function () {+ |
+
206 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
207 | +! | +
+ if (!("Model" %in% layer_kc[ , "class"])) {+ |
+
208 | +! | +
+ stop(sprintf("No Model on layer %s.", self$getId()))+ |
+
209 | ++ |
+ } else {+ |
+
210 | +! | +
+ model_key = layer_kc[layer_kc$class == "Model" ,+ |
+
211 | +! | +
+ "key"]+ |
+
212 | +! | +
+ model = self$getFromHashTable(key = model_key[1L])+ |
+
213 | ++ |
+ }+ |
+
214 | +! | +
+ return(model)+ |
+
215 | ++ |
+ },+ |
+
216 | ++ |
+ #' @description+ |
+
217 | ++ |
+ #' Open access to the meta layer. A meta learner is only+ |
+
218 | ++ |
+ #' modifiable if the access is opened.+ |
+
219 | ++ |
+ #'+ |
+
220 | ++ |
+ #'+ |
+
221 | ++ |
+ openAccess = function () {+ |
+
222 | +! | +
+ private$access = TRUE+ |
+
223 | +! | +
+ invisible(self)+ |
+
224 | ++ |
+ },+ |
+
225 | ++ |
+ #' @description+ |
+
226 | ++ |
+ #' Close access to the meta layer to avoid accidental+ |
+
227 | ++ |
+ #' modification.+ |
+
228 | ++ |
+ #'+ |
+
229 | ++ |
+ #'+ |
+
230 | ++ |
+ closeAccess = function () {+ |
+
231 | +! | +
+ private$access = FALSE+ |
+
232 | +! | +
+ invisible(self)+ |
+
233 | ++ |
+ },+ |
+
234 | ++ |
+ #' @description+ |
+
235 | ++ |
+ #' Getter of the current access to the meta layer.+ |
+
236 | ++ |
+ #'+ |
+
237 | ++ |
+ #' @export+ |
+
238 | ++ |
+ getAccess = function () {+ |
+
239 | +! | +
+ return(private$access)+ |
+
240 | ++ |
+ },+ |
+
241 | ++ |
+ #' @description+ |
+
242 | ++ |
+ #' Create and set an [TrainData] object to the current+ |
+
243 | ++ |
+ #' meta learner.+ |
+
244 | ++ |
+ #'+ |
+
245 | ++ |
+ #' @param id `character(1)` \cr+ |
+
246 | ++ |
+ #' ID of the [TrainData] object to be instanciated.+ |
+
247 | ++ |
+ #' @param ind_col `character(1)` \cr+ |
+
248 | ++ |
+ #' Name of individual column IDs.+ |
+
249 | ++ |
+ #' @param data_frame `data.frame(1)` \cr+ |
+
250 | ++ |
+ #' \code{data.frame} of layer specific predictions.+ |
+
251 | ++ |
+ #' @param meta_layer `Layer(1)` \cr+ |
+
252 | ++ |
+ #' Layer where to store the [TrainData] object.+ |
+
253 | ++ |
+ #' @param target `character(1)` \cr+ |
+
254 | ++ |
+ #' Name of the target variable+ |
+
255 | ++ |
+ #'+ |
+
256 | ++ |
+ #' @export+ |
+
257 | ++ |
+ # TODO: Please do not export me.+ |
+
258 | ++ |
+ setTrainData = function (id,+ |
+
259 | ++ |
+ ind_col,+ |
+
260 | ++ |
+ data_frame,+ |
+
261 | ++ |
+ meta_layer,+ |
+
262 | ++ |
+ target) {+ |
+
263 | +! | +
+ TrainData$new(id = id,+ |
+
264 | +! | +
+ data_frame = data_frame,+ |
+
265 | +! | +
+ train_layer = self)+ |
+
266 | +! | +
+ return(self)+ |
+
267 | ++ |
+ },+ |
+
268 | ++ |
+ #' @description+ |
+
269 | ++ |
+ #' Check whether a training data has been already stored.+ |
+
270 | ++ |
+ #'+ |
+
271 | ++ |
+ #' @return+ |
+
272 | ++ |
+ #' Boolean value+ |
+
273 | ++ |
+ #'+ |
+
274 | ++ |
+ checkLrnerExist = function () {+ |
+
275 | +! | +
+ return(super$checkClassExist(.class = "Lrner"))+ |
+
276 | ++ |
+ },+ |
+
277 | ++ |
+ #' @description+ |
+
278 | ++ |
+ #' Check whether a training data has been already stored.+ |
+
279 | ++ |
+ #'+ |
+
280 | ++ |
+ #' @return+ |
+
281 | ++ |
+ #' Boolean value+ |
+
282 | ++ |
+ #'+ |
+
283 | ++ |
+ checkTrainDataExist = function () {+ |
+
284 | ++ |
+ # Fix predicted20242806 as reserved word+ |
+
285 | +! | +
+ test = super$checkClassExist(.class = "TrainData") & ("predicted20242806" %in% private$key_class$class)+ |
+
286 | ++ |
+ },+ |
+
287 | ++ |
+ #' @description+ |
+
288 | ++ |
+ #' Only usefull to reset status FALSE after cross validation.+ |
+
289 | ++ |
+ set2NotTrained = function () {+ |
+
290 | +! | +
+ private$status = FALSE+ |
+
291 | ++ |
+ },+ |
+
292 | ++ |
+ #' @description+ |
+
293 | ++ |
+ #' Generate summary.+ |
+
294 | ++ |
+ #'+ |
+
295 | ++ |
+ #' @export+ |
+
296 | ++ |
+ #'+ |
+
297 | ++ |
+ summary = function () {+ |
+
298 | +! | +
+ cat(" MetaLayer\n")+ |
+
299 | +! | +
+ cat(" ----------------\n")+ |
+
300 | +! | +
+ if (!private$status) {+ |
+
301 | +! | +
+ status = "Not trained"+ |
+
302 | ++ |
+ } else {+ |
+
303 | +! | +
+ status = "Trained"+ |
+
304 | ++ |
+ }+ |
+
305 | +! | +
+ cat(sprintf(" TrainMetaLayer : %s\n", private$id))+ |
+
306 | +! | +
+ cat(sprintf(" Status : %s\n", status))+ |
+
307 | +! | +
+ stored_obj = self$getKeyClass()+ |
+
308 | +! | +
+ if (!nrow(stored_obj)) {+ |
+
309 | +! | +
+ cat(" Empty layer.\n")+ |
+
310 | ++ |
+ } else {+ |
+
311 | +! | +
+ cat(sprintf(" Nb. of objects stored : %s\n", nrow(stored_obj)))+ |
+
312 | ++ |
+ }+ |
+
313 | +! | +
+ cat("\n")+ |
+
314 | +! | +
+ cat(" ----------------\n")+ |
+
315 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
316 | +! | +
+ cat(" Object(s) on MetaLayer\n\n")+ |
+
317 | +! | +
+ if (!nrow(layer_kc)) {+ |
+
318 | +! | +
+ cat(" Empty layer\n")+ |
+
319 | ++ |
+ }+ |
+
320 | +! | +
+ for (k in layer_kc[ , "key"]) {+ |
+
321 | +! | +
+ cat(" ----------------\n")+ |
+
322 | +! | +
+ current_obj = self$getFromHashTable(key = k)+ |
+
323 | +! | +
+ current_obj$summary()+ |
+
324 | +! | +
+ cat(" ----------------\n")+ |
+
325 | +! | +
+ cat("\n")+ |
+
326 | ++ |
+ }+ |
+
327 | ++ |
+ }+ |
+
328 | ++ |
+ ),+ |
+
329 | ++ |
+ private = list(+ |
+
330 | ++ |
+ # The current training study+ |
+
331 | ++ |
+ train_study = NULL,+ |
+
332 | ++ |
+ # Access to the meta layer.+ |
+
333 | ++ |
+ access = FALSE,+ |
+
334 | ++ |
+ status = FALSE+ |
+
335 | ++ |
+ ),+ |
+
336 | ++ |
+ cloneable = FALSE+ |
+
337 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Model Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements a model. A [Model] object can only exist as element of a+ |
+
5 | ++ |
+ #' [TrainLayer] or a [TrainMetaLayer] object. A [Model] object is+ |
+
6 | ++ |
+ #' automatically created by fitting a learner on a training data.+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #' A [Model] object can compute predictions for a [NewData] object. See the \code{predict} function below.+ |
+
9 | ++ |
+ #'+ |
+
10 | ++ |
+ #' @export+ |
+
11 | ++ |
+ #'+ |
+
12 | ++ |
+ #' @importFrom R6 R6Class+ |
+
13 | ++ |
+ #'+ |
+
14 | ++ |
+ Model <- R6Class("Model",+ |
+
15 | ++ |
+ public = list(+ |
+
16 | ++ |
+ #' @description+ |
+
17 | ++ |
+ #' Constructor of Model class.+ |
+
18 | ++ |
+ #'+ |
+
19 | ++ |
+ #' @param lrner (`Lrner(1)`) \cr+ |
+
20 | ++ |
+ #' The learner.+ |
+
21 | ++ |
+ #' @param train_data (`TrainData(1)`) \cr+ |
+
22 | ++ |
+ #' Training data.+ |
+
23 | ++ |
+ #' @param base_model (`object(1)`) \cr+ |
+
24 | ++ |
+ #' Base model as returned by the original learn function.+ |
+
25 | ++ |
+ #' @param train_layer (`TrainLayer(1)`) \cr+ |
+
26 | ++ |
+ #' The current training layer on which the model is stored.+ |
+
27 | ++ |
+ #'+ |
+
28 | ++ |
+ #' @return+ |
+
29 | ++ |
+ #' An object is returned.+ |
+
30 | ++ |
+ #'+ |
+
31 | ++ |
+ #' @export+ |
+
32 | ++ |
+ #FIXME: Do not export me, since a user can not create model itself.+ |
+
33 | ++ |
+ #'+ |
+
34 | ++ |
+ initialize = function (lrner,+ |
+
35 | ++ |
+ train_data,+ |
+
36 | ++ |
+ base_model,+ |
+
37 | ++ |
+ train_layer) {+ |
+
38 | +! | +
+ private$lrner = lrner+ |
+
39 | +! | +
+ private$train_data = train_data+ |
+
40 | +! | +
+ private$base_model = base_model+ |
+
41 | +! | +
+ private$train_layer = train_layer+ |
+
42 | +! | +
+ if (any(c("TrainLayer", "TrainMetaLayer") %in% class(train_layer))) {+ |
+
43 | +! | +
+ train_layer$add2HashTable(key = sprintf("%sMo", lrner$getId()),+ |
+
44 | +! | +
+ value = self,+ |
+
45 | +! | +
+ .class = "Model")+ |
+
46 | ++ |
+ } else {+ |
+
47 | +! | +
+ stop("A Model can only belong to a TrainLayer or a TrainMetaLayer.")+ |
+
48 | ++ |
+ }+ |
+
49 | ++ |
+ },+ |
+
50 | ++ |
+ #' @description+ |
+
51 | ++ |
+ #' Printer+ |
+
52 | ++ |
+ #' @param ... (any) \cr+ |
+
53 | ++ |
+ #'+ |
+
54 | ++ |
+ print = function (...) {+ |
+
55 | +! | +
+ cat("Class : Model\n\n")+ |
+
56 | +! | +
+ cat("Learner info. \n")+ |
+
57 | +! | +
+ cat("-----------------------\n")+ |
+
58 | +! | +
+ print(private$lrner)+ |
+
59 | +! | +
+ cat("\n")+ |
+
60 | +! | +
+ cat("Train data info. \n")+ |
+
61 | +! | +
+ cat("-----------------------\n")+ |
+
62 | +! | +
+ print(private$train_data)+ |
+
63 | ++ |
+ },+ |
+
64 | ++ |
+ #' @description+ |
+
65 | ++ |
+ #' Summary+ |
+
66 | ++ |
+ #' @param ... (any) \cr+ |
+
67 | ++ |
+ #'+ |
+
68 | ++ |
+ summary = function (...) {+ |
+
69 | +! | +
+ cat(" Model \n\n")+ |
+
70 | +! | +
+ cat(" -----------------------\n")+ |
+
71 | +! | +
+ cat(sprintf("Individual(s) used : $s\n", length(private$lrner$getVarSubset())))+ |
+
72 | +! | +
+ cat(sprintf("Variable(s) used : $s\n", length(private$lrner$getIndSubset())))+ |
+
73 | +! | +
+ cat(" -----------------------\n")+ |
+
74 | ++ |
+ },+ |
+
75 | ++ |
+ #' @description+ |
+
76 | ++ |
+ #' Getter of the base model+ |
+
77 | ++ |
+ #'+ |
+
78 | ++ |
+ #' @export+ |
+
79 | ++ |
+ #'+ |
+
80 | ++ |
+ getBaseModel = function () {+ |
+
81 | +! | +
+ return(private$base_model)+ |
+
82 | ++ |
+ },+ |
+
83 | ++ |
+ #' @description+ |
+
84 | ++ |
+ #' Getter of the traning data+ |
+
85 | ++ |
+ #'+ |
+
86 | ++ |
+ #' @export+ |
+
87 | ++ |
+ #'+ |
+
88 | ++ |
+ getTrainData = function () {+ |
+
89 | +! | +
+ return(private$train_data)+ |
+
90 | ++ |
+ },+ |
+
91 | ++ |
+ #' @description+ |
+
92 | ++ |
+ #' Getter of the individual ID column in the training data.+ |
+
93 | ++ |
+ #'+ |
+
94 | ++ |
+ #' @param ... (any) \cr+ |
+
95 | ++ |
+ #'+ |
+
96 | ++ |
+ getTrainLabel = function () {+ |
+
97 | +! | +
+ train_data = private$train_data+ |
+
98 | +! | +
+ return(train_data$getDataFrame()[ , train_data$getIndCol()])+ |
+
99 | ++ |
+ },+ |
+
100 | ++ |
+ #' @description+ |
+
101 | ++ |
+ #' Getter of the learner use to fit the model.+ |
+
102 | ++ |
+ #'+ |
+
103 | ++ |
+ #' @export+ |
+
104 | ++ |
+ #'+ |
+
105 | ++ |
+ getLrner = function () {+ |
+
106 | +! | +
+ return(private$lrner)+ |
+
107 | ++ |
+ },+ |
+
108 | ++ |
+ #' @description+ |
+
109 | ++ |
+ #' Setter of the model ID.+ |
+
110 | ++ |
+ #'+ |
+
111 | ++ |
+ #' @param id \cr+ |
+
112 | ++ |
+ #' ID value+ |
+
113 | ++ |
+ #'+ |
+
114 | ++ |
+ #' @export+ |
+
115 | ++ |
+ #'+ |
+
116 | ++ |
+ setId = function (id) {+ |
+
117 | +! | +
+ private$id = id+ |
+
118 | +! | +
+ invisible(self)+ |
+
119 | ++ |
+ },+ |
+
120 | ++ |
+ #' @description+ |
+
121 | ++ |
+ #' Predict target values for the new data+ |
+
122 | ++ |
+ #' (from class [NewData]) taken as into.+ |
+
123 | ++ |
+ #'+ |
+
124 | ++ |
+ #' @param new_data `NewData(1)` \cr+ |
+
125 | ++ |
+ #' An object from class [NewData].+ |
+
126 | ++ |
+ #' @param ind_subset `vector(1)` \cr+ |
+
127 | ++ |
+ #' Subset of individual IDs to be predicted.+ |
+
128 | ++ |
+ #' @param ...+ |
+
129 | ++ |
+ #' Further parameters.+ |
+
130 | ++ |
+ #'+ |
+
131 | ++ |
+ #' @return+ |
+
132 | ++ |
+ #' The predicted object are returned. The predicted object must be either a vector or a list+ |
+
133 | ++ |
+ #' containing a field predictions with predictions.+ |
+
134 | ++ |
+ #'+ |
+
135 | ++ |
+ #' @export+ |
+
136 | ++ |
+ #'+ |
+
137 | ++ |
+ predict = function (new_data, ind_subset = NULL, ...) {+ |
+
138 | +! | +
+ tmp_lrner = self$getLrner()+ |
+
139 | +! | +
+ if(tmp_lrner$getTrainLayer()$getId() != new_data$getNewLayer()$getId()) {+ |
+
140 | +! | +
+ stop("Learner and data must belong to the same layer.")+ |
+
141 | ++ |
+ }+ |
+
142 | ++ |
+ # Predict only on complete data+ |
+
143 | +! | +
+ new_data = new_data$clone(deep = FALSE)+ |
+
144 | +! | +
+ complete_data = new_data$getCompleteData()+ |
+
145 | +! | +
+ new_data$setDataFrame(data_frame = complete_data)+ |
+
146 | ++ |
+ # Prepare new dataset+ |
+
147 | +! | +
+ if (is.null(ind_subset)) {+ |
+
148 | +! | +
+ missing_ind = NULL+ |
+
149 | +! | +
+ new_data = new_data+ |
+
150 | +! | +
+ ind_subset = new_data$getDataFrame()[ , new_data$getIndCol()]+ |
+
151 | ++ |
+ } else {+ |
+
152 | ++ |
+ # Filter individuals with missing values on this layer+ |
+
153 | +! | +
+ missing_ind = new_data$getSetDiff(+ |
+
154 | +! | +
+ var_name = new_data$getIndCol(),+ |
+
155 | +! | +
+ value = ind_subset)+ |
+
156 | ++ |
+ # Keeping only individuals with observations+ |
+
157 | +! | +
+ ind_subset = setdiff(ind_subset, missing_ind)+ |
+
158 | +! | +
+ new_data = new_data$getIndSubset(+ |
+
159 | +! | +
+ var_name = new_data$getIndCol(),+ |
+
160 | +! | +
+ value = ind_subset)+ |
+
161 | ++ |
+ }+ |
+
162 | +! | +
+ pred_param <- list(...)+ |
+
163 | +! | +
+ pred_param$object = self$getBaseModel()+ |
+
164 | +! | +
+ pred_param$data = new_data$getData()+ |
+
165 | +! | +
+ lrn_package = private$lrner$getPackage()+ |
+
166 | +! | +
+ if (is.null(lrn_package)) {+ |
+
167 | +! | +
+ predict_fct = "predict"+ |
+
168 | ++ |
+ } else {+ |
+
169 | +! | +
+ predict_fct = sprintf('%s:::%s',+ |
+
170 | +! | +
+ lrn_package,+ |
+
171 | +! | +
+ sprintf("predict.%s", lrn_package))+ |
+
172 | ++ |
+ }+ |
+
173 | +! | +
+ predicted_obj = do.call(eval(parse(text = predict_fct)),+ |
+
174 | +! | +
+ pred_param)+ |
+
175 | ++ |
+ # The predicted object must be either a vector or a list+ |
+
176 | ++ |
+ # containing a field predictions with predictions.+ |
+
177 | +! | +
+ if (is.vector(predicted_obj)) {+ |
+
178 | +! | +
+ predicted_obj = data.frame(+ |
+
179 | +! | +
+ layer = private$lrner$getTrainLayer()$getId(),+ |
+
180 | +! | +
+ id = ind_subset,+ |
+
181 | +! | +
+ pred = predicted_obj)+ |
+
182 | +! | +
+ pred_colnames = c("Layer",+ |
+
183 | +! | +
+ new_data$getIndCol(),+ |
+
184 | +! | +
+ "Prediction")+ |
+
185 | +! | +
+ names(predicted_obj) = pred_colnames+ |
+
186 | ++ |
+ } else {+ |
+
187 | +! | +
+ if (is.list(predicted_obj)) {+ |
+
188 | +! | +
+ if (is.null(predicted_obj$predictions)) {+ |
+
189 | +! | +
+ stop("Predicted object must either be a vector or a list containing a field named 'predictions'")+ |
+
190 | ++ |
+ } else {+ |
+
191 | +! | +
+ predicted_obj = data.frame(+ |
+
192 | +! | +
+ layer = private$lrner$getTrainLayer()$getId(),+ |
+
193 | +! | +
+ id = ind_subset,+ |
+
194 | +! | +
+ pred = predicted_obj$predictions)+ |
+
195 | +! | +
+ pred_colnames = c("Layer",+ |
+
196 | +! | +
+ private$train_data$getIndCol(),+ |
+
197 | +! | +
+ "Prediction")+ |
+
198 | +! | +
+ names(predicted_obj) = pred_colnames+ |
+
199 | ++ |
+ }+ |
+
200 | ++ |
+ } else {+ |
+
201 | +! | +
+ stop("Predicted object must either be a vector or a list containing a field named 'predictions'")+ |
+
202 | ++ |
+ }+ |
+
203 | ++ |
+ }+ |
+
204 | ++ |
+ # Ignore all other columns than layer, individual ids and+ |
+
205 | ++ |
+ # predicted values+ |
+
206 | +! | +
+ predicted_obj = predicted_obj[, pred_colnames]+ |
+
207 | ++ |
+ # Add eventual individuals with missing values+ |
+
208 | +! | +
+ if (length(missing_ind)) {+ |
+
209 | +! | +
+ predicted_obj_missing = data.frame(+ |
+
210 | +! | +
+ layer = private$lrner$getTrainLayer()$getId(),+ |
+
211 | +! | +
+ id = missing_ind,+ |
+
212 | +! | +
+ pred = NA)+ |
+
213 | +! | +
+ names(predicted_obj_missing) = pred_colnames+ |
+
214 | ++ |
+ } else {+ |
+
215 | +! | +
+ predicted_obj_missing = NULL+ |
+
216 | ++ |
+ }+ |
+
217 | +! | +
+ predicted_obj = data.frame(+ |
+
218 | +! | +
+ rbind(predicted_obj,+ |
+
219 | +! | +
+ predicted_obj_missing))+ |
+
220 | +! | +
+ predicted_data = PredictData$new(+ |
+
221 | +! | +
+ id = new_data$getId(),+ |
+
222 | +! | +
+ ind_col = new_data$getIndCol(),+ |
+
223 | +! | +
+ data_frame = predicted_obj+ |
+
224 | ++ |
+ )+ |
+
225 | +! | +
+ return(predicted_data)+ |
+
226 | ++ |
+ }+ |
+
227 | ++ |
+ ),+ |
+
228 | ++ |
+ private = list(+ |
+
229 | ++ |
+ id = character(0L),+ |
+
230 | ++ |
+ lrner = NULL,+ |
+
231 | ++ |
+ train_data = NULL,+ |
+
232 | ++ |
+ base_model = NULL,+ |
+
233 | ++ |
+ train_layer = NULL+ |
+
234 | ++ |
+ ),+ |
+
235 | ++ |
+ cloneable = TRUE+ |
+
236 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title PredictData Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implements [PredictData] object to be predicted.+ |
+
5 | ++ |
+ #' A [PredictData] object can only exist as a component of a [PredictLayer] or a [PredictMetaLayer] object.+ |
+
6 | ++ |
+ #' @export+ |
+
7 | ++ |
+ #' @importFrom R6 R6Class+ |
+
8 | ++ |
+ #' @seealso [TrainData], [NewData]+ |
+
9 | ++ |
+ PredictData <- R6Class("PredictData",+ |
+
10 | ++ |
+ inherit = Data,+ |
+
11 | ++ |
+ public = list(+ |
+
12 | ++ |
+ #' @description+ |
+
13 | ++ |
+ #' Initialize a new object from the current class.+ |
+
14 | ++ |
+ #'+ |
+
15 | ++ |
+ #' @param id (`character(1)`) \cr+ |
+
16 | ++ |
+ #' Object ID.+ |
+
17 | ++ |
+ #' @param ind_col (`character(1)`)\cr+ |
+
18 | ++ |
+ #' Column name containing individual IDs.+ |
+
19 | ++ |
+ #' @param data_frame (`data.frame(1)`)\cr+ |
+
20 | ++ |
+ #' \code{data.frame} containing data.+ |
+
21 | ++ |
+ initialize = function (id,+ |
+
22 | ++ |
+ ind_col,+ |
+
23 | ++ |
+ data_frame) {+ |
+
24 | +! | +
+ super$initialize(id = id,+ |
+
25 | +! | +
+ ind_col = ind_col,+ |
+
26 | +! | +
+ data_frame = data_frame)+ |
+
27 | ++ |
+ },+ |
+
28 | ++ |
+ #' @description+ |
+
29 | ++ |
+ #' Printer+ |
+
30 | ++ |
+ #' @param ... (any) \cr+ |
+
31 | ++ |
+ #'+ |
+
32 | ++ |
+ print = function (...) {+ |
+
33 | +! | +
+ cat("Class : PredictData\n")+ |
+
34 | +! | +
+ cat(sprintf("Layer : %s\n", private$predict_layer$id))+ |
+
35 | +! | +
+ cat(sprintf("name : %s\n", private$id))+ |
+
36 | +! | +
+ cat(sprintf("ind. id. : %s\n", private$ind_col))+ |
+
37 | +! | +
+ cat(sprintf("n : %s\n", nrow(private$data_frame)))+ |
+
38 | +! | +
+ cat(sprintf("p : %s\n", ncol(private$data_frame)))+ |
+
39 | ++ |
+ },+ |
+
40 | ++ |
+ #' @description+ |
+
41 | ++ |
+ #' Getter of the current predicted \code{data.frame} wihtout individual+ |
+
42 | ++ |
+ #' ID variable.+ |
+
43 | ++ |
+ #'+ |
+
44 | ++ |
+ #' @return+ |
+
45 | ++ |
+ #' The \code{data.frame} without individual ID nor target variables is returned.+ |
+
46 | ++ |
+ #' @export+ |
+
47 | ++ |
+ #'+ |
+
48 | ++ |
+ getPredictData = function () {+ |
+
49 | +! | +
+ tmp_data <- private$data_frame+ |
+
50 | +! | +
+ return(tmp_data)+ |
+
51 | ++ |
+ },+ |
+
52 | ++ |
+ #' @description+ |
+
53 | ++ |
+ #' Getter of the current layer.+ |
+
54 | ++ |
+ #'+ |
+
55 | ++ |
+ #' @return+ |
+
56 | ++ |
+ #' The layer (from class [PredictLayer]) on which the current train data are stored+ |
+
57 | ++ |
+ #' is returned.+ |
+
58 | ++ |
+ #' @export+ |
+
59 | ++ |
+ #'+ |
+
60 | ++ |
+ getPredictLayer = function () {+ |
+
61 | +! | +
+ return(private$predict_layer)+ |
+
62 | ++ |
+ },+ |
+
63 | ++ |
+ #' @description+ |
+
64 | ++ |
+ #' Assigns a predicted layer to the predicted data.+ |
+
65 | ++ |
+ #'+ |
+
66 | ++ |
+ #' @param predict_layer `PredictLayer(1)` \cr+ |
+
67 | ++ |
+ #'+ |
+
68 | ++ |
+ #' @return+ |
+
69 | ++ |
+ #' The current object+ |
+
70 | ++ |
+ #'+ |
+
71 | ++ |
+ setPredictLayer = function (predict_layer) {+ |
+
72 | +! | +
+ private$predict_layer = predict_layer+ |
+
73 | +! | +
+ predict_layer$add2HashTable(key = private$id,+ |
+
74 | +! | +
+ value = self,+ |
+
75 | +! | +
+ .class = "PredictData")+ |
+
76 | +! | +
+ return(self)+ |
+
77 | ++ |
+ }+ |
+
78 | ++ |
+ ),+ |
+
79 | ++ |
+ private = list(+ |
+
80 | ++ |
+ # Current predicted layer.+ |
+
81 | ++ |
+ predict_layer = NULL+ |
+
82 | ++ |
+ ),+ |
+
83 | ++ |
+ cloneable = TRUE+ |
+
84 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Class Param+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' Implements a parameter set. Objects from this class contain non-tunable parameters.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' @export+ |
+
7 | ++ |
+ #' @importFrom R6 R6Class+ |
+
8 | ++ |
+ #' @seealso [ParamLrner]+ |
+
9 | ++ |
+ Param <- R6Class("Param",+ |
+
10 | ++ |
+ public = list(+ |
+
11 | ++ |
+ #' @description+ |
+
12 | ++ |
+ #' Initialize a default parameters list.+ |
+
13 | ++ |
+ #'+ |
+
14 | ++ |
+ #'+ |
+
15 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
16 | ++ |
+ #' The ID of current parameter object.+ |
+
17 | ++ |
+ #' @param param_list (`list(1)`)\cr+ |
+
18 | ++ |
+ #' List of parameters.+ |
+
19 | ++ |
+ #'+ |
+
20 | ++ |
+ initialize = function (id, param_list) {+ |
+
21 | +3x | +
+ private$id = id+ |
+
22 | +3x | +
+ private$param_list = param_list+ |
+
23 | ++ |
+ },+ |
+
24 | ++ |
+ #' @description+ |
+
25 | ++ |
+ #' Printer+ |
+
26 | ++ |
+ #' @param ... (any) \cr+ |
+
27 | ++ |
+ #'+ |
+
28 | ++ |
+ print = function(...){+ |
+
29 | +! | +
+ cat("Class: Param\n")+ |
+
30 | +! | +
+ cat(sprintf("id : %s\n", private$id))+ |
+
31 | +! | +
+ cat("Parameter combination\n")+ |
+
32 | +! | +
+ print(private$param_list)+ |
+
33 | ++ |
+ },+ |
+
34 | ++ |
+ #' @description+ |
+
35 | ++ |
+ #' Getter of parameter ID.+ |
+
36 | ++ |
+ #'+ |
+
37 | ++ |
+ getId = function () {+ |
+
38 | +! | +
+ return(private$id)+ |
+
39 | ++ |
+ },+ |
+
40 | ++ |
+ #' @description+ |
+
41 | ++ |
+ #' Getter of parameter list.+ |
+
42 | ++ |
+ #'+ |
+
43 | ++ |
+ getParamList = function () {+ |
+
44 | +! | +
+ return(private$param_list)+ |
+
45 | ++ |
+ }+ |
+
46 | ++ |
+ ),+ |
+
47 | ++ |
+ private = list(+ |
+
48 | ++ |
+ id = character(0L),+ |
+
49 | ++ |
+ param_list = NA+ |
+
50 | ++ |
+ ),+ |
+
51 | ++ |
+ cloneable = TRUE+ |
+
52 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title The weighted mean super learner+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' Layer weights are estimated for each layer based on Brier score.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' @param x `data.frame(1)` \cr+ |
+
7 | ++ |
+ #' \code{data.frame} of predictors.+ |
+
8 | ++ |
+ #' @param y `vector(1)` \cr+ |
+
9 | ++ |
+ #' Target observations.+ |
+
10 | ++ |
+ #'+ |
+
11 | ++ |
+ #' @return+ |
+
12 | ++ |
+ #' A model object of class \code{weightedMeanLeaner}.+ |
+
13 | ++ |
+ #'+ |
+
14 | ++ |
+ #' @export+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @examples+ |
+
17 | ++ |
+ #' set.seed(20240624)+ |
+
18 | ++ |
+ #' x = data.frame(x1 = rnorm(50))+ |
+
19 | ++ |
+ #' y = sample(x = 0:1, size = 50, replace = TRUE)+ |
+
20 | ++ |
+ #' my_model = weightedMeanLearner(x = x, y = y)+ |
+
21 | ++ |
+ #'+ |
+
22 | ++ |
+ weightedMeanLearner = function (x, y) {+ |
+
23 | ++ |
+ # y must be binomial. If dichotomy, first category (case) = 1 and+ |
+
24 | ++ |
+ # second (control) = 0+ |
+
25 | +! | +
+ if (length(unique(y)) > 2) {+ |
+
26 | +! | +
+ stop("y must be dichtom or binary")+ |
+
27 | ++ |
+ } else {+ |
+
28 | +! | +
+ if (!all(y %in% 0:1)) {+ |
+
29 | +! | +
+ y = 2 - as.integer(y)+ |
+
30 | ++ |
+ } else {+ |
+
31 | +! | +
+ if (is.factor(y)) {+ |
+
32 | +! | +
+ y = as.integer(y) - 1+ |
+
33 | ++ |
+ } else {+ |
+
34 | +! | +
+ y = y+ |
+
35 | ++ |
+ }+ |
+
36 | ++ |
+ }+ |
+
37 | +! | +
+ brier_values = lapply(X = x, FUN = function (predicted) {+ |
+
38 | +! | +
+ mean(x = (predicted - y)^2, na.rm = TRUE)+ |
+
39 | ++ |
+ })+ |
+
40 | +! | +
+ brier_values = unlist(brier_values)+ |
+
41 | +! | +
+ weights_values = (1 - brier_values) / sum((1 - brier_values))+ |
+
42 | +! | +
+ names(weights_values) = names(x)+ |
+
43 | +! | +
+ class(weights_values) = "weightedMeanLearner"+ |
+
44 | +! | +
+ return(weights_values)+ |
+
45 | ++ |
+ }+ |
+
46 | ++ |
+ }+ |
+
1 | ++ |
+ #' @title PredictMetaLayer Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implement a predicted meta layer. A [PredictMetaLayer] can only exist as unique element of a [TrainStudy] object.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' A predicted meta layer can only contain a [PredictData] object.+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #' @export+ |
+
9 | ++ |
+ #' @importFrom R6 R6Class+ |
+
10 | ++ |
+ PredictMetaLayer <- R6Class("PredictMetaLayer",+ |
+
11 | ++ |
+ inherit = HashTable,+ |
+
12 | ++ |
+ public = list(+ |
+
13 | ++ |
+ #' @description+ |
+
14 | ++ |
+ #' constructor+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
17 | ++ |
+ #' See class Param+ |
+
18 | ++ |
+ #' @param predict_study (`PredictStudy(1)`)\cr+ |
+
19 | ++ |
+ #'+ |
+
20 | ++ |
+ initialize = function (id, predict_study) {+ |
+
21 | +! | +
+ super$initialize(id = id)+ |
+
22 | +! | +
+ private$predict_study = predict_study+ |
+
23 | +! | +
+ if ("PredictStudy" %in% class(predict_study)) {+ |
+
24 | +! | +
+ predict_study$add2HashTable(key = id,+ |
+
25 | +! | +
+ value = self,+ |
+
26 | +! | +
+ .class = "PredictMetaLayer")+ |
+
27 | ++ |
+ } else {+ |
+
28 | +! | +
+ stop("A predicted meta layer can only belong to a PredictStudy.")+ |
+
29 | ++ |
+ }+ |
+
30 | ++ |
+ },+ |
+
31 | ++ |
+ #' @description+ |
+
32 | ++ |
+ #' Printer+ |
+
33 | ++ |
+ #' @param ... (any) \cr+ |
+
34 | ++ |
+ #'+ |
+
35 | ++ |
+ print = function(...) {+ |
+
36 | +! | +
+ cat("Class: PredictMetaLayer\n")+ |
+
37 | +! | +
+ cat("Do not modify its instances manually.\n")+ |
+
38 | +! | +
+ cat(sprintf("id: %s\n", private$id))+ |
+
39 | +! | +
+ cat(sprintf("Contains %s object", length(private$hash_table)))+ |
+
40 | ++ |
+ },+ |
+
41 | ++ |
+ #' @description+ |
+
42 | ++ |
+ #' Getter of the current predicted study+ |
+
43 | ++ |
+ #'+ |
+
44 | ++ |
+ #' @return+ |
+
45 | ++ |
+ #' The current predicted study is returned.+ |
+
46 | ++ |
+ #'+ |
+
47 | ++ |
+ getPredictStudy = function () {+ |
+
48 | +! | +
+ return(private$predict_study)+ |
+
49 | ++ |
+ },+ |
+
50 | ++ |
+ #' @description+ |
+
51 | ++ |
+ #' Getter of IDS from the current layer.+ |
+
52 | ++ |
+ #'+ |
+
53 | ++ |
+ #' @return+ |
+
54 | ++ |
+ #' A \code{data.frame} containing individuals IDs values.+ |
+
55 | ++ |
+ #' @export+ |
+
56 | ++ |
+ #'+ |
+
57 | ++ |
+ getIndIDs = function () {+ |
+
58 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
59 | ++ |
+ # Stop if training data is missing on this layer.+ |
+
60 | +! | +
+ if (("PredictData" %in% layer_kc[ , "class"])) {+ |
+
61 | ++ |
+ # Searching for layer specific new dataset+ |
+
62 | +! | +
+ data_key = layer_kc[layer_kc$class == "PredictData" ,+ |
+
63 | +! | +
+ "key"]+ |
+
64 | +! | +
+ current_data = self$getPredictData()+ |
+
65 | ++ |
+ } else {+ |
+
66 | +! | +
+ stop(sprintf("No data on layer %s.", self$getId()))+ |
+
67 | ++ |
+ }+ |
+
68 | +! | +
+ current_data_frame = current_data$getDataFrame()+ |
+
69 | +! | +
+ ids_data = current_data_frame[ , current_data$getIndCol(), drop = FALSE]+ |
+
70 | +! | +
+ return(ids_data)+ |
+
71 | ++ |
+ },+ |
+
72 | ++ |
+ #' @description+ |
+
73 | ++ |
+ #' Getter of the predicted data.+ |
+
74 | ++ |
+ #'+ |
+
75 | ++ |
+ #' @return+ |
+
76 | ++ |
+ #' The stored [PredictData] object is returned.+ |
+
77 | ++ |
+ #' @export+ |
+
78 | ++ |
+ #'+ |
+
79 | ++ |
+ getPredictData = function () {+ |
+
80 | +! | +
+ print("I am in PredictMetaLayer")+ |
+
81 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
82 | +! | +
+ if (any(c("PredictData") %in% layer_kc[ , "class"])) {+ |
+
83 | +! | +
+ predict_data_key = layer_kc[layer_kc$class == "PredictData" ,+ |
+
84 | +! | +
+ "key"]+ |
+
85 | +! | +
+ predict_data = self$getFromHashTable(key = predict_data_key[1L])+ |
+
86 | ++ |
+ } else {+ |
+
87 | +! | +
+ stop(sprintf("No predicted data on layer %s.", self$getId()))+ |
+
88 | ++ |
+ }+ |
+
89 | +! | +
+ return(predict_data)+ |
+
90 | ++ |
+ },+ |
+
91 | ++ |
+ #' @description+ |
+
92 | ++ |
+ #' Open access to the meta layer. A meta learner is only+ |
+
93 | ++ |
+ #' modifiable if the access is opened.+ |
+
94 | ++ |
+ #'+ |
+
95 | ++ |
+ #'+ |
+
96 | ++ |
+ openAccess = function () {+ |
+
97 | +! | +
+ private$access = TRUE+ |
+
98 | +! | +
+ invisible(self)+ |
+
99 | ++ |
+ },+ |
+
100 | ++ |
+ #' @description+ |
+
101 | ++ |
+ #' Close access to the meta layer to avoid accidental+ |
+
102 | ++ |
+ #' modification.+ |
+
103 | ++ |
+ #'+ |
+
104 | ++ |
+ #'+ |
+
105 | ++ |
+ closeAccess = function () {+ |
+
106 | +! | +
+ private$access = FALSE+ |
+
107 | +! | +
+ invisible(self)+ |
+
108 | ++ |
+ },+ |
+
109 | ++ |
+ #' @description+ |
+
110 | ++ |
+ #' Getter of the current access to the meta layer.+ |
+
111 | ++ |
+ #'+ |
+
112 | ++ |
+ #' @export+ |
+
113 | ++ |
+ getAccess = function () {+ |
+
114 | +! | +
+ return(private$access)+ |
+
115 | ++ |
+ }+ |
+
116 | ++ |
+ ),+ |
+
117 | ++ |
+ private = list(+ |
+
118 | ++ |
+ # The current study+ |
+
119 | ++ |
+ predict_study = NULL,+ |
+
120 | ++ |
+ # Access to the meta layer.+ |
+
121 | ++ |
+ access = FALSE+ |
+
122 | ++ |
+ ),+ |
+
123 | ++ |
+ cloneable = FALSE+ |
+
124 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title NewMetaLayer Class+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' This class implement a predicted meta layer. A [NewMetaLayer] can only exist as unique element of a [TrainStudy] object.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' A predicted meta layer can only contain a [NewData] object.+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #' @export+ |
+
9 | ++ |
+ #' @importFrom R6 R6Class+ |
+
10 | ++ |
+ NewMetaLayer <- R6Class("NewMetaLayer",+ |
+
11 | ++ |
+ inherit = HashTable,+ |
+
12 | ++ |
+ public = list(+ |
+
13 | ++ |
+ #' @description+ |
+
14 | ++ |
+ #' constructor+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
17 | ++ |
+ #' See class Param+ |
+
18 | ++ |
+ #' @param new_study (`NewStudy(1)`)\cr+ |
+
19 | ++ |
+ #'+ |
+
20 | ++ |
+ initialize = function (id, new_study) {+ |
+
21 | +! | +
+ super$initialize(id = id)+ |
+
22 | +! | +
+ private$new_study = new_study+ |
+
23 | +! | +
+ new_study$add2HashTable(key = id,+ |
+
24 | +! | +
+ value = self,+ |
+
25 | +! | +
+ .class = "NewMetaLayer")+ |
+
26 | ++ |
+ },+ |
+
27 | ++ |
+ #' @description+ |
+
28 | ++ |
+ #' Printer+ |
+
29 | ++ |
+ #' @param ... (any) \cr+ |
+
30 | ++ |
+ #'+ |
+
31 | ++ |
+ print = function(...) {+ |
+
32 | +! | +
+ cat(sprintf("NewMetaLayer: %s\n", private$id))+ |
+
33 | +! | +
+ cat(sprintf("Contains %s object\n", length(private$hash_table)))+ |
+
34 | ++ |
+ },+ |
+
35 | ++ |
+ #' @description+ |
+
36 | ++ |
+ #' Getter of the current predicted study+ |
+
37 | ++ |
+ #'+ |
+
38 | ++ |
+ #' @return+ |
+
39 | ++ |
+ #' The current new study is returned.+ |
+
40 | ++ |
+ #'+ |
+
41 | ++ |
+ getNewStudy = function () {+ |
+
42 | +! | +
+ return(private$new_study)+ |
+
43 | ++ |
+ },+ |
+
44 | ++ |
+ #' @description+ |
+
45 | ++ |
+ #' Getter of the training dataset stored on the current layer.+ |
+
46 | ++ |
+ #'+ |
+
47 | ++ |
+ #' @return+ |
+
48 | ++ |
+ #' The stored [NewData] object is returned.+ |
+
49 | ++ |
+ #' @export+ |
+
50 | ++ |
+ #'+ |
+
51 | ++ |
+ getNewData = function () {+ |
+
52 | +! | +
+ layer_kc = self$getKeyClass()+ |
+
53 | +! | +
+ if ("NewData" %in% layer_kc[ , "class"]) {+ |
+
54 | +! | +
+ new_data_key = layer_kc[layer_kc$class == "NewData" ,+ |
+
55 | +! | +
+ "key"]+ |
+
56 | +! | +
+ new_data = self$getFromHashTable(key = new_data_key[1L])+ |
+
57 | ++ |
+ } else {+ |
+
58 | +! | +
+ stop(sprintf("No new data on layer %s.", self$getId()))+ |
+
59 | ++ |
+ }+ |
+
60 | +! | +
+ return(new_data)+ |
+
61 | ++ |
+ },+ |
+
62 | ++ |
+ #' @description+ |
+
63 | ++ |
+ #' Open access to the meta layer. A meta learner is only+ |
+
64 | ++ |
+ #' modifiable if the access is opened.+ |
+
65 | ++ |
+ #'+ |
+
66 | ++ |
+ #'+ |
+
67 | ++ |
+ openAccess = function () {+ |
+
68 | +! | +
+ private$access = TRUE+ |
+
69 | +! | +
+ invisible(self)+ |
+
70 | ++ |
+ },+ |
+
71 | ++ |
+ #' @description+ |
+
72 | ++ |
+ #' Close access to the meta layer to avoid accidental+ |
+
73 | ++ |
+ #' modification.+ |
+
74 | ++ |
+ #'+ |
+
75 | ++ |
+ #'+ |
+
76 | ++ |
+ closeAccess = function () {+ |
+
77 | +! | +
+ private$access = FALSE+ |
+
78 | +! | +
+ invisible(self)+ |
+
79 | ++ |
+ },+ |
+
80 | ++ |
+ #' @description+ |
+
81 | ++ |
+ #' Getter of the current access to the meta layer.+ |
+
82 | ++ |
+ #'+ |
+
83 | ++ |
+ #' @export+ |
+
84 | ++ |
+ getAccess = function () {+ |
+
85 | +! | +
+ return(private$access)+ |
+
86 | ++ |
+ },+ |
+
87 | ++ |
+ #' @description+ |
+
88 | ++ |
+ #' Create and set an [NewData] object to the current+ |
+
89 | ++ |
+ #' new meta learner.+ |
+
90 | ++ |
+ #'+ |
+
91 | ++ |
+ #' @param id `character(1)` \cr+ |
+
92 | ++ |
+ #' ID of the [NewData] object to be instanciated.+ |
+
93 | ++ |
+ #' @param ind_col `character(1)` \cr+ |
+
94 | ++ |
+ #' Name of individual column IDs.+ |
+
95 | ++ |
+ #' @param data_frame `data.frame(1)` \cr+ |
+
96 | ++ |
+ #' \code{data.frame} of layer specific predictions.+ |
+
97 | ++ |
+ #' @param meta_layer `NewLayer(1)` \cr+ |
+
98 | ++ |
+ #' Layer where to store the [NewData] object.+ |
+
99 | ++ |
+ #'+ |
+
100 | ++ |
+ #' @export+ |
+
101 | ++ |
+ # TODO: Please do not export me.+ |
+
102 | ++ |
+ setNewData = function (id,+ |
+
103 | ++ |
+ ind_col,+ |
+
104 | ++ |
+ data_frame,+ |
+
105 | ++ |
+ meta_layer) {+ |
+
106 | +! | +
+ NewData$new(id = id,+ |
+
107 | +! | +
+ ind_col = ind_col,+ |
+
108 | +! | +
+ data_frame = data_frame,+ |
+
109 | +! | +
+ meta_layer = self)+ |
+
110 | +! | +
+ return(self)+ |
+
111 | ++ |
+ },+ |
+
112 | ++ |
+ #' @description+ |
+
113 | ++ |
+ #' Check whether a new data has been already stored.+ |
+
114 | ++ |
+ #'+ |
+
115 | ++ |
+ #' @return+ |
+
116 | ++ |
+ #' Boolean value+ |
+
117 | ++ |
+ #'+ |
+
118 | ++ |
+ checkNewDataExist = function () {+ |
+
119 | +! | +
+ return(super$checkClassExist(.class = "NewData"))+ |
+
120 | ++ |
+ }+ |
+
121 | ++ |
+ ),+ |
+
122 | ++ |
+ private = list(+ |
+
123 | ++ |
+ # The current study+ |
+
124 | ++ |
+ new_study = NULL,+ |
+
125 | ++ |
+ # Access to the meta layer.+ |
+
126 | ++ |
+ access = FALSE+ |
+
127 | ++ |
+ ),+ |
+
128 | ++ |
+ cloneable = FALSE+ |
+
129 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Class ParamLrner.+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' Implement the list of parameters to be passed to the [Lrner] object.+ |
+
5 | ++ |
+ #' Non-tunable parameters and tunable paramters are stored in the object+ |
+
6 | ++ |
+ #' from this class.+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #' @export+ |
+
9 | ++ |
+ #' @importFrom R6 R6Class+ |
+
10 | ++ |
+ ParamLrner <- R6Class("ParamLrner",+ |
+
11 | ++ |
+ inherit = Param,+ |
+
12 | ++ |
+ public = list(+ |
+
13 | ++ |
+ #' @description+ |
+
14 | ++ |
+ #' constructor+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @param id (`character(1)`)\cr+ |
+
17 | ++ |
+ #' See class Param+ |
+
18 | ++ |
+ #' @param param_list (`list(1)`)\cr+ |
+
19 | ++ |
+ #' See class Param+ |
+
20 | ++ |
+ #' @param hyperparam_list (`list(1)`)\cr+ |
+
21 | ++ |
+ #' List of hyperparameters+ |
+
22 | ++ |
+ #'+ |
+
23 | ++ |
+ initialize = function (id,+ |
+
24 | ++ |
+ param_list,+ |
+
25 | ++ |
+ hyperparam_list) {+ |
+
26 | +2x | +
+ super$initialize(id = id, param_list = param_list)+ |
+
27 | +2x | +
+ private$hyperparam = hyperparam_list+ |
+
28 | +2x | +
+ param = c(private$param_list, hyperparam_list)+ |
+
29 | +2x | +
+ private$param_lrner = expand.grid(param)+ |
+
30 | ++ |
+ # Do not hash instances from this class. Hash Lrner+ |
+
31 | ++ |
+ # objects instead.+ |
+
32 | ++ |
+ },+ |
+
33 | ++ |
+ #' @description+ |
+
34 | ++ |
+ #' Printer+ |
+
35 | ++ |
+ #' @param ... (any) \cr+ |
+
36 | ++ |
+ #'+ |
+
37 | ++ |
+ print = function (...) {+ |
+
38 | +! | +
+ cat(sprintf("ParamLrner : %s\n", private$id))+ |
+
39 | +! | +
+ cat("Learner parameter combination\n")+ |
+
40 | +! | +
+ print(private$param_lrner)+ |
+
41 | ++ |
+ },+ |
+
42 | ++ |
+ #' @description+ |
+
43 | ++ |
+ #' Getter of learner parameters.+ |
+
44 | ++ |
+ #'+ |
+
45 | ++ |
+ getParamLrner = function() {+ |
+
46 | +! | +
+ return(private$param_lrner)+ |
+
47 | ++ |
+ },+ |
+
48 | ++ |
+ #' @description+ |
+
49 | ++ |
+ #' Getter of hyperparameters.+ |
+
50 | ++ |
+ #'+ |
+
51 | ++ |
+ getHyperparam = function () {+ |
+
52 | +! | +
+ return(private$hyperparam)+ |
+
53 | ++ |
+ }+ |
+
54 | ++ |
+ ),+ |
+
55 | ++ |
+ private = list(+ |
+
56 | ++ |
+ param_lrner = list(0L),+ |
+
57 | ++ |
+ hyperparam = list(0L)+ |
+
58 | ++ |
+ ),+ |
+
59 | ++ |
+ cloneable = TRUE+ |
+
60 | ++ |
+ )+ |
+
1 | ++ |
+ #' @title Weighted mean prediction.+ |
+
2 | ++ |
+ #'+ |
+
3 | ++ |
+ #' @description+ |
+
4 | ++ |
+ #' Predict function for models from class \code{weightedMeanLearner}.+ |
+
5 | ++ |
+ #'+ |
+
6 | ++ |
+ #' @include weightedMeanLearner.R+ |
+
7 | ++ |
+ #'+ |
+
8 | ++ |
+ #' @param object `weightedMeanLearner(1)` \cr+ |
+
9 | ++ |
+ #' An object from class [weightedMeanLearner]+ |
+
10 | ++ |
+ #' @param data `data.frame` \cr+ |
+
11 | ++ |
+ #' \code{data.frame} to be predicted.+ |
+
12 | ++ |
+ #'+ |
+
13 | ++ |
+ #' @return+ |
+
14 | ++ |
+ #' Predicted target values are returned.+ |
+
15 | ++ |
+ #'+ |
+
16 | ++ |
+ #' @export+ |
+
17 | ++ |
+ #'+ |
+
18 | ++ |
+ #' @importFrom stats weighted.mean+ |
+
19 | ++ |
+ #'+ |
+
20 | ++ |
+ #' @examples+ |
+
21 | ++ |
+ #' set.seed(20240625)+ |
+
22 | ++ |
+ #' x <- data.frame(x1 = rnorm(50))+ |
+
23 | ++ |
+ #' y <- sample(x = 0:1, size = 50, replace = TRUE)+ |
+
24 | ++ |
+ #' my_model <- weightedMeanLearner(x = x, y = y)+ |
+
25 | ++ |
+ #' x_new <- data.frame(x1 = rnorm(10))+ |
+
26 | ++ |
+ #' my_predictions <- predict(object = my_model, data = x_new)+ |
+
27 | ++ |
+ #'+ |
+
28 | ++ |
+ predict.weightedMeanLearner = function (object, data) {+ |
+
29 | +! | +
+ if (all(names(object) %in% names(data))) {+ |
+
30 | +! | +
+ pred = apply(data[ , names(object), drop = FALSE], 1L, function (row) {+ |
+
31 | +! | +
+ return(weighted.mean(x = row, w = object, na.rm = TRUE) )+ |
+
32 | ++ |
+ })+ |
+
33 | +! | +
+ return(list(predictions = unlist(pred)))+ |
+
34 | ++ |
+ } else {+ |
+
35 | +! | +
+ stop("Names of weights do not match with name columns in data")+ |
+
36 | ++ |
+ }+ |
+
37 | ++ |
+ }+ |
+