In my R Shiny application, I implemented a cross-validation model using the xgb.cv() and everything worked fine. Then I added the r_bg() function in order to make a multiple process since I needed the Start/Stop ability. After this addition, I face an issue when I pass the DMatrix to the args=list() of r_bg(). Specifically, a DMatrix is required for the xgb.cv() model which has to be passed in the r_bg() and I get the error:
Warning: Error in : ! error in callr subprocess
Caused by error in `getinfo.xgb.DMatrix(data, "label")`:
! [14:17:28] amalgamation/../src/c_api/c_api.cc:571: DMatrix/Booster has not been initialized or has already been disposed.
Below you can find my code for the data transformation to DMatrix structure as well as the part of the start training process:
Server Code:
server <- function(input, output, session) {
observe({
req(input$checkbox_regression_choice)
req(input$select_dependent_variable)
req(input$select_independent_variables)
values$train_data_x <- data.matrix(subset(values$train_partition, select = input$select_independent_variables))
values$train_label_y <- values$train_partition[[input$select_dependent_variable]]
values$test_data_x <- data.matrix(subset(values$test_partition, select = input$select_independent_variables))
values$test_label_y <- values$test_partition[[input$select_dependent_variable]]
values$xgb_train <- xgb.DMatrix(data = values$train_data_x, label = values$train_label_y)
values$xgb_test <- xgb.DMatrix(data = values$test_data_x, label = values$test_label_y)
})
observeEvent(input$ML_Submit_Button,{
shinyjs::hide("ML_Submit_Button")
shinyjs::show("ML_Stop_Button")
values$bg_process <- r_bg(xgb_gs_cv_regression,
args = list(xgb_train = values$xgb_train,
subsample_choice = values$subsample_slider_seq,
colsample_bytree_choice = values$colsample_bytree_slider_seq,
max_depth_choice = values$max_depth_slider_seq,
min_child_weight_choice = values$min_child_weight_slider_seq,
eta_choice = values$eta_slider_seq,
n_rounds_choice = values$n_rounds_slider_seq,
n_fold_choice = values$n_fold_slider_seq),
stdout = "|",
stderr = "2>&1")
})
observe({
invalidateLater(1000)
req(values$bg_process)
if(values$bg_process$poll_io(0)[["process"]] == "ready") {
shinyjs::hide("ML_Stop_Button")
shinyjs::show("ML_Submit_Button")
print(values$bg_process$get_result())
values$bg_process <- NULL
}
})
}
XGB CV Function Code:
xgb_gs_cv_regression <- function(xgb_train, subsample_choice, colsample_bytree_choice, max_depth_choice, min_child_weight_choice, eta_choice, n_rounds_choice, n_fold_choice){
searchGridSubCol = expand.grid(
subsample = subsample_choice,
colsample_bytree = colsample_bytree_choice,
max_depth = max_depth_choice,
min_child_weight = min_child_weight_choice,
eta = eta_choice,
n_rounds = n_rounds_choice,
n_fold = n_fold_choice
)
#Extract Parameters to test
currentSubsampleRate <- searchGridSubCol[["subsample"]]
currentColsampleRate <- searchGridSubCol[["colsample_bytree"]]
currentDepth <- searchGridSubCol[["max_depth"]]
currentEta <- searchGridSubCol[["eta"]]
currentMinChildWeight <- searchGridSubCol[["min_child_weight"]]
currentNRounds <- searchGridSubCol[["n_rounds"]]
currentNFold <- searchGridSubCol[["n_fold"]]
xgboostModelCV <- xgboost::xgb.cv(objective = "reg:squarederror", #xgb parameter
data = xgb_train,
booster = "gbtree", #xgb parameter
showsd = TRUE, #xgb parameter whether to show standard deviation of cross validation
#metrics = "rmse",#k-folds cv parameter
verbose = TRUE, #xgb print the statistics during the process
print_every_n = 10, #k-folds cv parameter
early_stopping_rounds = 10, #k-folds cv parameter
eval_metric = "rmse", #xgb parameter
"nrounds" = currentNRounds, #k-folds cv parameter
"nfold" = currentNFold, #k-folds cv parameter
"max_depth" = currentDepth,
"eta" = currentEta,
"subsample" = currentSubsampleRate,
"colsample_bytree" = currentColsampleRate,
"min_child_weight" = currentMinChildWeight
)
xgb_cv_xvalidationScores <- xgboostModelCV$evaluation_log
#best score
test_rmse <- tail(xgb_cv_xvalidationScores$test_rmse_mean, 1)
train_rmse <- tail(xgb_cv_xvalidationScores$train_rmse_mean,1)
gs_results_output <- c(test_rmse, train_rmse, currentSubsampleRate, currentColsampleRate, currentDepth, currentEta, currentMinChildWeight, currentNRounds, currentNFold)
return(gs_results_output)
}
Could you advise me how to overcome this error?