diff --git a/server.R b/server.R index 7833ecd..2c7b3df 100644 --- a/server.R +++ b/server.R @@ -13,14 +13,56 @@ function(input, output, session){ color = "#FFF" ) } + ## Reveal the app only once Shiny has actually finished rendering outputs + ## (content-ready), instead of guessing with a fixed delay. This removes the + ## brief "skeleton" flash on refresh. A max-timeout fail-safe guarantees the + ## overlay is never left stuck (e.g. slow Docker cold start -> no white screen). + hide_waiter_after_paint <- function(extra_js = "", fallback_ms = 6000) { + shinyjs::runjs(sprintf(" + (function() { + var revealed = false, idleTimer = null; + var STABLE_MS = 200; // reveal after outputs stay idle this long + function reveal() { + if (revealed) return; + revealed = true; + if (idleTimer) clearTimeout(idleTimer); + $(document).off('shiny:idle', onIdle); + $(document).off('shiny:busy', onBusy); + if (window.waiter && typeof window.waiter.hide === 'function') { + window.waiter.hide(null); + } + $('.waiter-overlay').remove(); + %s + } + function onBusy() { + if (idleTimer) { clearTimeout(idleTimer); idleTimer = null; } + } + function onIdle() { + if (idleTimer) clearTimeout(idleTimer); + idleTimer = setTimeout(function() { requestAnimationFrame(reveal); }, STABLE_MS); + } + $(document).on('shiny:busy', onBusy); + $(document).on('shiny:idle', onIdle); + onIdle(); // handle the already-idle case + setTimeout(reveal, %d); // absolute fail-safe + })(); + ", extra_js, fallback_ms)) + } + hide_waiter_after_flush <- function(extra_js = "") { + session$onFlushed(function() { + hide_waiter_after_paint(extra_js) + }, once = TRUE) + } update_progress("Loading packages...") - + source("server/auth.R") source("server/homepage_translation_labels.R", local = TRUE) register_homepage_labels(output, session, get_rv_labels) - + USER = user_auth(input, output, session) - + login_logged_in_output_id <- paste0(app_login_config$APP_ID, "-logged_in") + outputOptions(output, login_logged_in_output_id, suspendWhenHidden = FALSE) + authed_started = reactiveVal(FALSE) observeEvent(USER$logged_in, { @@ -30,11 +72,14 @@ function(input, output, session){ color = "#FFF" ) - if (authed_started()) return() + if (authed_started()) { + hide_waiter_after_flush() + return() + } authed_started(TRUE) app_username = USER$username - + model_training_caret_pb = Attendant$new("model_training_caret_pb", hide_on_max = TRUE) data_upload_id_pb = Attendant$new("data_upload_id_pb", hide_on_max = TRUE) model_metrics_caret_pb = Attendant$new("model_metrics_caret_pb", hide_on_max = TRUE) @@ -45,12 +90,12 @@ function(input, output, session){ generate_research_questions_additional_analysis_pb = Attendant$new("generate_research_questions_additional_analysis_pb", hide_on_max = TRUE) feature_engineering_perform_preprocess_pb = Attendant$new("feature_engineering_perform_preprocess_pb", hide_on_max = TRUE) model_training_caret_metrics_download_all_zip_pb = Attendant$new("model_training_caret_metrics_download_all_zip_pb", hide_on_max = TRUE) - + #### ---- Input validators --------------------------------------------------- source("server/input_validators.R") #### ---- Create needed folders for datasets and logs ------------------------ source("server/create_dirs.R", local=TRUE) - + #### ---- FastAPI base URL réactif (lié au champ fastapi_base) ---- source("R/utils_logging.R") @@ -62,12 +107,12 @@ function(input, output, session){ source("server/deploy_model_server.R", local=TRUE) source("ui/deploy_model_ui.R", local=TRUE) source("server/predict_pycaret_server.R", local = TRUE) - + source("server/history_actions.R", local = TRUE) source("server/history_transform_actions.R", local = TRUE) source("server/history_visualize_auto_actions.R", local = TRUE) source("server/history_visualize_custom_actions.R", local = TRUE) - + api_base <- reactive({ val <- input$fastapi_base if (is.null(val) || !nzchar(trimws(val))) { @@ -77,10 +122,10 @@ function(input, output, session){ } }) observe({ - + expand_label <- get_rv_labels("sidebar_toggle_expand_menu") collapse_label <- get_rv_labels("sidebar_toggle_menu_aria") - + session$sendCustomMessage( type = "sidebarLabels", message = list( @@ -88,24 +133,24 @@ function(input, output, session){ collapse = collapse_label ) ) - + }) - + # Send sidebar toggle labels to JS (reactive-safe) sent_sidebar_labels <- reactiveVal(FALSE) - + observe({ - req(rv_lang$labelling_file_df) - req(!sent_sidebar_labels()) - + req(rv_lang$labelling_file_df) + req(!sent_sidebar_labels()) + expand_label <- get_rv_labels("sidebar_toggle_expand_menu") collapse_label <- get_rv_labels("sidebar_toggle_menu_aria") - + session$sendCustomMessage( "sidebarLabels", list(expand = expand_label, collapse = collapse_label) ) - + sent_sidebar_labels(TRUE) }) @@ -144,21 +189,21 @@ function(input, output, session){ , outcome = NULL , vartype_all = NULL ) - + #####------------------Plots Reactive------------------- - + plots_custom_rv <- reactiveValues( plot_rv = NULL, tab_rv = NULL, plot_bivariate_auto = NULL, plot_corr = NULL ) - + plots_auto_rv <- reactiveValues( plot_bivariate_auto = NULL, plot_corr = NULL ) - + history_visualize_custom_actions_server( input = input, output = output, @@ -199,11 +244,11 @@ function(input, output, session){ ) ## --- - + rv_omop<- reactiveValues( url = NULL ) - - + + ## LLM/GAI rv_generative_ai = reactiveValues( history = NULL @@ -213,7 +258,7 @@ function(input, output, session){ rv_ml_ai = reactiveValues( session_id = NULL , seed_value = NULL - , dataset_id = NULL + , dataset_id = NULL , analysis_type = NULL , task = NULL , outcome = NULL @@ -236,7 +281,7 @@ function(input, output, session){ model_training_caret_models_ols_check = NULL , model_training_caret_models_ols_advance_control = NULL ) - + ## Train control caret rv_train_control_caret = reactiveValues( method = "cv" @@ -247,102 +292,102 @@ function(input, output, session){ , savePredictions = FALSE , classProbs = TRUE ) - + ## Trained models rv_training_models = reactiveValues( ols_model = NULL , ols_param = FALSE , ols_name = NULL , ols_trained_model = NULL - + , rf_model = NULL , rf_param = FALSE , rf_name = NULL , rf_trained_model = NULL - + , gbm_model = NULL , gbm_param = FALSE , gbm_name = NULL , gbm_trained_model = NULL - + , xgbTree_model = NULL , xgbTree_param = FALSE , xgbTree_name = NULL , xgbTree_trained_model = NULL - + , xgbLinear_model = NULL , xgbLinear_param = FALSE , xgbLinear_name = NULL , xgbLinear_trained_model = NULL - + , svmRadial_model = NULL , svmRadial_param = FALSE , svmRadial_name = NULL , svmRadial_trained_model = NULL - + , svmLinear_model = NULL , svmLinear_param = FALSE , svmLinear_name = NULL , svmLinear_trained_model = NULL - + , svmPoly_model = NULL , svmPoly_param = FALSE , svmPoly_name = NULL , svmPoly_trained_model = NULL - + , glmnet_model = NULL , glmnet_param = FALSE , glmnet_name = NULL , glmnet_trained_model = NULL - + , lasso_model = NULL , lasso_param = FALSE , lasso_name = NULL , lasso_trained_model = NULL - + , ridge_model = NULL , ridge_param = FALSE , ridge_name = NULL , ridge_trained_model = NULL - + , knn_model = NULL , knn_param = FALSE , knn_name = NULL , knn_trained_model = NULL - + , nnet_model = NULL , nnet_param = FALSE , nnet_name = NULL , nnet_trained_model = NULL - + , avNNet_model = NULL , avNNet_param = FALSE , avNNet_name = NULL , avNNet_trained_model = NULL - + , pls_model = NULL , pls_param = FALSE , pls_name = NULL , pls_trained_model = NULL - + , rpart_model = NULL , rpart_param = FALSE , rpart_name = NULL , rpart_trained_model = NULL - + , mlpWeightDecayML_model = NULL , mlpWeightDecayML_param = FALSE , mlpWeightDecayML_name = NULL , mlpWeightDecayML_trained_model = NULL - + , naive_bayes_model = NULL , naive_bayes_param = FALSE , naive_bayes_name = NULL , naive_bayes_trained_model = NULL - + , all_trained_models = NULL ) - + rv_training_results = reactiveValues( models = NULL , train_metrics_df = NULL @@ -435,7 +480,7 @@ function(input, output, session){ ## Deployed models rv_deployed_models = reactiveValues() - + ## Reactive values to stock AutoML leaderboard rv_automl <- reactiveValues( leaderboard = NULL @@ -445,20 +490,20 @@ function(input, output, session){ source("server/header_footer_configs.R", local=TRUE) app_title() - + ###-------App Footer-------------------------- - + footer_language_translation() ###-------Menu Translate--------- - + menu_translation() #### ---- Change language ---------------------------------------------------- output$change_language = change_language source("server/change_language_update.R", local = TRUE) - change_language_update() - + change_language_update() + # ---- Sidebar tooltip labels ---- nocode_tooltip_server( session = session, @@ -467,32 +512,32 @@ function(input, output, session){ #### ---- Upload data UI -------------------------------------------- source("ui/upload_data.R", local = TRUE) output$upload_type = upload_type - + #### ---- Upload dataset/files UI -------------------------------------------- source("server/input_files.R", local = TRUE) output$input_files = input_files - + #### ---- Show uploaded datasets UI -------------------------------------------- output$show_uploaded = show_uploaded - + #### ---- Data upload form ----------------------------------------------- source("ui/upload_form.R", local = TRUE) output$study_name = study_name output$study_country = study_country output$additional_info = additional_info output$submit_upload = submit_upload - + #### ---- Databse and API connection warning --------------------- db_api_con_future - + #### ---- Upload datasets ---------------------------------------- source("server/upload_data.R", local = TRUE) upload_data_server() - + #### ---- Database integration ---------------------------------------- source("server/database_integration.R", local = TRUE) database_integration_server() - + #### --- Database related form elements ---### output$db_type = db_type output$db_host = db_host @@ -508,19 +553,19 @@ function(input, output, session){ output$db_disconnect = db_disconnect output$db_tab_query = db_tab_query output$existing_connection = existing_connection - + source("server/omop_analysis.R", local = TRUE) omop_analysis_server() - + stderr_file_path <- file.path(getwd(), app_username, "output", "dq_stderr.txt") - + stderr_content<-create_log_reader(stderr_file_path) - + #### ---- Collect logs ---------------------------------------- source("server/collect_logs.R", local = TRUE) collect_logs_server() - + #### ---- Display uploaded datasets ---------------------------------------- source("server/display_uploaded_data.R", local = TRUE) display_uploaded_data_server() @@ -528,18 +573,18 @@ function(input, output, session){ #### ---- Delete uploaded dadatsets ---------------------------------------- source("server/delete_uploaded_data.R", local = TRUE) delete_uploaded_data_server() - + #### ---- Update logfiles based on existing datasets -------------------#### source("server/update_logs.R", local = TRUE) update_logs_server() - + #### ---- Manage data ---------------------------------------------- - + ##### ---- Select data --------------------------------------------- source("server/select_data.R", local = TRUE) select_data_server() manage_data_show_server() - + ##### ---- Display meta data for the selected dataset --------------------------------------------- source("server/display_metadata.R", local = TRUE) display_selected_metadata_server() @@ -558,7 +603,7 @@ function(input, output, session){ source("server/explore_data.R", local = TRUE) explore_data_server() explore_data_subactions_server() - + ##----User Defined Visualization section----------------------- source("ui/user_defined_visualization_header.R", local = TRUE) output$user_output_type = user_output_type @@ -568,14 +613,14 @@ function(input, output, session){ output$user_row_var = user_row_var output$usr_create_cross_tab = usr_create_cross_tab output$user_download_table = user_download_table - + output$user_table_options = user_table_options output$user_report_numeric = user_report_numeric output$user_add_p_value = user_add_p_value output$user_add_confidence_interval = user_add_confidence_interval output$user_drop_missing_values = user_drop_missing_values output$user_table_caption = user_table_caption - + output$user_plot_options = user_plot_options output$user_select_variable_on_x_axis = user_select_variable_on_x_axis output$user_select_variable_on_y_axis = user_select_variable_on_y_axis @@ -584,7 +629,7 @@ function(input, output, session){ output$user_y_axis_label = user_y_axis_label output$user_create = user_create output$user_download = user_download - + output$user_more_plot_options = user_more_plot_options output$user_transform_to_doughnut = user_transform_to_doughnut output$user_select_color_variable = user_select_color_variable @@ -594,7 +639,7 @@ function(input, output, session){ output$user_line_size = user_line_size output$user_select_line_type = user_select_line_type output$user_add_shapes = user_add_shapes - + output$user_select_shape = user_select_shape output$user_add_smooth = user_add_smooth output$user_display_confidence_interval = user_display_confidence_interval @@ -604,7 +649,7 @@ function(input, output, session){ output$user_add_points = user_add_points output$user_y_variable_summary_type = user_y_variable_summary_type output$user_title_position = user_title_position - + output$user_size_of_plot_title = user_size_of_plot_title output$user_axis_title_size = user_axis_title_size output$user_facet_title_size = user_facet_title_size @@ -618,10 +663,10 @@ function(input, output, session){ output$user_select_color_variable_single = user_select_color_variable_single output$user_select_color_parlet = user_select_color_parlet output$user_numeric_summary = user_numeric_summary - + output$bivariate_header_label = bivariate_header_label output$corrplot_header_label = corrplot_header_label - + output$user_select_bivariate_single_color = user_select_bivariate_single_color output$user_select_color_parlet_bivariate = user_select_color_parlet_bivariate output$user_select_color_parlet_corrplot = user_select_color_parlet_corrplot @@ -630,31 +675,31 @@ function(input, output, session){ output$user_download_autoreport = user_download_autoreport output$user_generatebivriate = user_generatebivriate - + ##### ---- Explore data actions ---------------------------------- explore_data_actions_server() - + ##### ---- Filter data -------------------------------------------- explore_data_filter_server() explore_data_apply_filter_server() explore_data_current_filter_server() - + ##### ---- Show/display ------------------------------------------------------- explore_show_data_server() explore_data_reset_current_filter_server() - + ##### ---- Compute proportion of missing data --------------------------- explore_missing_data_server() - + ##### ---- Select variables --------------------------------------------- explore_data_select_variables_server() explore_data_selected_variables_server() - + ##### ---- Update data ----------------------------------------------- explore_data_update_data_server() - + #### ---- Transform variables -------------------------------------- #### source("server/transform_data.R", local = TRUE) @@ -669,29 +714,29 @@ function(input, output, session){ ##### ---- Recode/change value labels ---------------------------------------### transform_data_quick_explore_recode_server() - + ##### ---- Handle missing data ---------------------------------------### transform_data_create_missing_values_server() - + ##### ---- Identify outliers ---------------------------------------### transform_data_identify_outliers_server() - + ##### ---- Handle missing values ---------------------------------------### transform_data_handle_missing_values_server() - + ##### ---- Plot transform data ----------------------------------------------### transform_data_quick_explore_plot_server() - + ##### ---- Plot missing data (LAZY-LOADED) --------------------------------### source("server/lazy_loaders.R", local = TRUE) lazy_load_missing_data() - + #### ---- Combine datasets with the existing one --------------------------------------#### source("server/combine_data.R", local = TRUE) - + ##### ---- List of internal data ------------------------------------------#### combine_data_list_datasets() - + ##### ---- Combine data options ------------------------------------------#### combine_data_type() @@ -700,7 +745,7 @@ function(input, output, session){ ##### ---- Combine data variables matched --------------------#### combine_data_variable_matching() - + #### ----- Perform matching ---------------------------------#### combine_data_perform_variable_match() @@ -726,20 +771,20 @@ function(input, output, session){ } ) ### ------- OMOP ------------------------------------------ ##### - + #### ----- Cohort Constructor ---------##### source("server/run_cohort_pipeline.R", local = TRUE) run_cohort_pipeline() - + #### ----- Feature Extraction ---------##### source("server/feature_extraction_pipeline.R", local = TRUE) feature_extraction_pipeline() - + #### ---- Achilles Integration -------------------#### - + source("server/run_achilles.R", local = TRUE) achilles_integration_server() - + ### ---- OMOP CDM Summaries---------------------------#### source("server/omop_summaries.R", local = TRUE) omopVizServer() @@ -751,7 +796,7 @@ function(input, output, session){ #### ---- Generate Research Questions --------------------------------------#### source("server/research_questions.R", local = TRUE) generate_research_questions_choices() - + ##### ---- API Token ------------------ #### generate_research_questions_api_token() @@ -764,34 +809,34 @@ function(input, output, session){ generate_research_questions_gemini() #### ---- Machine learning and AI --------------- #### - + ##### ----- Set ML/AI UI ------------------- #### update_progress("Loading ML modules...") source("server/setup_models.R", local=TRUE) setup_models_ui() - + ##### ----- Preprocessing ------------------- #### source("server/feature_engineering.R", local=TRUE) - + #### Preprocessing ------------------------------------------- #### feature_engineering_perform_preprocess_server() #### ------ Missing value imputation -------------------------- #### feature_engineering_recipe_server() feature_engineering_impute_missing_server() - + #### ----- Modelling framework --------------------------------- #### source("server/modelling_framework.R", local=TRUE) modelling_framework_choices() - + #### ----- Model setup ----------------------------------------- #### source("server/model_training_setup.R", local=TRUE) model_training_setup_server() #### ----- Caret models --------------------------------------- #### source("server/model_training_caret_models.R", local=TRUE) - + ## LM/GLM model_training_caret_models_ols_server() @@ -809,7 +854,7 @@ function(input, output, session){ ## svmRadial model_training_caret_models_svmRadial_server() - + ## svmLinear model_training_caret_models_svmLinear_server() @@ -818,7 +863,7 @@ function(input, output, session){ ## glmnet model_training_caret_models_glmnet_server() - + ## LASSO model_training_caret_models_lasso_server() @@ -848,10 +893,10 @@ function(input, output, session){ ## mlpWeightDecayML (MLP) model_training_caret_models_mlpWeightDecayML_server() - + ## Naive Bayes model_training_caret_models_naive_bayes_server() - + #### ----- Train all models ----------------------------------- #### source("server/train_caret_models.R", local=TRUE) model_training_caret_train_all_server() @@ -878,13 +923,13 @@ function(input, output, session){ predict_pycaret_server("predict_pycaret", api_base , rv_current, rv_ml_ai) # END NEW ADD - #### ---- Call current dataset for FastAPI --------------------------------------------------- + #### ---- Call current dataset for FastAPI --------------------------------------------------- source("server/automl_server.R", local=TRUE) automl_server("automl_module", rv_current, rv_ml_ai) observe({ req(!is.null(rv_ml_ai$modelling_framework)) # Check if value exist - + if (tolower(rv_ml_ai$modelling_framework) == "pycaret") { output$automl_module_ui <- renderUI({ automl_ui("automl_module") @@ -895,14 +940,14 @@ function(input, output, session){ }) } }) - + observeEvent(input$modelling_framework_choices, { rv_ml_ai$framework <- tolower(input$modelling_framework_choices %||% "") }, ignoreInit = FALSE) - + #### ---- Deep Learning Server (LAZY-LOADED) ----- ### lazy_load_deep_learning() - + #### ---- Reset various components --------------------------------------#### ## Various components come before this source("server/resets.R", local = TRUE) @@ -924,9 +969,19 @@ function(input, output, session){ admin_server(USER) update_progress("Ready!") - waiter::waiter_hide() + + ## Hide the loader only after Shiny has flushed outputs and the browser + ## has painted them. This avoids a brief textless dashboard flash. + hide_waiter_after_flush(" + var active = $('ul.sidebar-menu li.active > a').first(); + if (active.length) { active.trigger('click'); } + ") }, ignoreInit = FALSE) - waiter::waiter_hide() + session$onFlushed(function() { + if (!isTRUE(isolate(USER$logged_in))) { + hide_waiter_after_paint() + } + }, once = TRUE) } diff --git a/server/caret_job_manager.R b/server/caret_job_manager.R new file mode 100644 index 0000000..48c3d39 --- /dev/null +++ b/server/caret_job_manager.R @@ -0,0 +1,1009 @@ +source("server/caret_job_worker.R", local = TRUE) + +caret_job_manager_server <- function( + input, + output, + session, + rv_current, + rv_ml_ai, + rv_training_models, + rv_train_control_caret, + rv_training_results, + app_username, + get_rv_labels +) { + job_processes <- new.env(parent = emptyenv()) + job_configs <- new.env(parent = emptyenv()) + job_results <- new.env(parent = emptyenv()) + job_table <- reactiveVal(data.frame()) + context_cache <- reactiveVal(NULL) + context_version <- reactiveVal(0L) + context_cache_token <- digest::digest(paste(Sys.time(), runif(1)), algo = "xxhash64") + ensemble_request <- reactiveVal(NULL) + ensemble_build_scheduled <- reactiveVal(FALSE) + + label <- function(key, fallback) { + value <- tryCatch(as.character(get_rv_labels(key)), error = function(e) NULL) + if (is.null(value) || length(value) == 0 || is.na(value[[1]]) || !nzchar(value[[1]])) { + return(fallback) + } + value[[1]] + } + + notify <- function(...) { + tryCatch(showNotification(..., session = session), error = function(e) NULL) + invisible(NULL) + } + + empty_jobs <- function() { + data.frame( + job_id = character(), + model_id = character(), + model_label = character(), + status = character(), + step = character(), + started_at = as.POSIXct(character()), + finished_at = as.POSIXct(character()), + error = character(), + result_path = character(), + config_path = character(), + stringsAsFactors = FALSE + ) + } + + get_jobs <- function() { + jobs <- job_table() + if (is.null(jobs) || !NROW(jobs)) empty_jobs() else jobs + } + + set_jobs <- function(jobs) { + job_table(jobs) + } + + has_active_run <- function(jobs = get_jobs()) { + NROW(jobs) && any(jobs$status %in% c("queued", "running", "paused"), na.rm = TRUE) + } + + sync_training_state <- function(jobs = get_jobs()) { + rv_training_results$training_busy <- has_active_run(jobs) + rv_training_results$training_completed <- NROW(jobs) && any(jobs$status == "completed", na.rm = TRUE) + } + + clear_model_selection <- function(model_ids) { + for (id in model_ids) { + updatePrettyCheckbox( + session, + inputId = paste0("model_training_caret_models_", id, "_check"), + value = FALSE + ) + } + rv_ml_ai$at_least_one_model <- FALSE + invisible(NULL) + } + + clear_completed_model_results <- function(model_ids) { + result_names <- ls(job_results) + if (!length(result_names) || !length(model_ids)) return(invisible(NULL)) + for (result_name in result_names) { + result <- get(result_name, envir = job_results, inherits = FALSE) + if (!is.null(result$model_id) && result$model_id %in% model_ids) { + rm(list = result_name, envir = job_results) + } + } + invisible(NULL) + } + + update_job <- function(job_id, ...) { + jobs <- get_jobs() + idx <- which(jobs$job_id == job_id) + if (!length(idx)) return(invisible(FALSE)) + values <- list(...) + for (nm in names(values)) { + jobs[[nm]][idx] <- values[[nm]] + } + set_jobs(jobs) + sync_training_state(jobs) + invisible(TRUE) + } + + js_value <- function(x) { + x <- gsub("\\\\", "\\\\\\\\", x) + x <- gsub("'", "\\\\'", x) + x + } + + status_label <- function(status) { + switch( + status, + queued = label("caret_jobs_status_queued", "Queued"), + running = label("caret_jobs_status_running", "Running"), + paused = label("caret_jobs_status_paused", "Paused"), + stopped = label("caret_jobs_status_stopped", "Stopped"), + completed = label("caret_jobs_status_completed", "Completed"), + failed = label("caret_jobs_status_failed", "Failed"), + status + ) + } + + step_label <- function(step) { + switch( + step, + queued = label("caret_jobs_step_queued", "Queued"), + training = label("caret_jobs_step_training", "Training"), + evaluating = label("caret_jobs_step_evaluating", "Checking performance"), + saving = label("caret_jobs_step_saving", "Saving results"), + ready = label("caret_jobs_step_ready", "Ready"), + failed = label("caret_jobs_status_failed", "Failed"), + paused = label("caret_jobs_status_paused", "Paused"), + stopped = label("caret_jobs_status_stopped", "Stopped"), + step + ) + } + + job_status_label <- function(job) { + status <- job$status[[1]] + step <- job$step[[1]] + if (identical(status, "running") && !is.na(step) && nzchar(step)) return(step_label(step)) + if (identical(status, "completed")) return(step_label("ready")) + status_label(status) + } + + status_color <- function(status) { + switch( + status, + queued = "#9aa3a8", + running = "#2196f3", + paused = "#f6a100", + stopped = "#777777", + completed = "#4cae4c", + failed = "#d9534f", + "#9aa3a8" + ) + } + + active_step <- function(job) { + status <- job$status[[1]] + step <- if (!is.null(job$step[[1]]) && !is.na(job$step[[1]]) && nzchar(job$step[[1]])) { + job$step[[1]] + } else { + status + } + switch( + status, + queued = "queued", + running = step, + paused = step, + stopped = step, + completed = "ready", + failed = step, + step + ) + } + + step_rank <- function(step) { + steps <- c("queued", "training", "evaluating", "saving", "ready") + idx <- match(step, steps) + if (is.na(idx)) 1L else idx + } + + stepper_icon <- function(status, current, done) { + if (identical(status, "failed") && current) return("fa fa-exclamation-triangle") + if (identical(status, "stopped") && current) return("fa fa-stop") + if (identical(status, "paused") && current) return("fa fa-pause") + if (identical(status, "running") && current) return("fa fa-spinner fa-spin") + if (done || identical(status, "completed")) return("fa fa-check") + if (current) return("fa fa-clock-o") + "fa fa-circle-o" + } + + job_stepper <- function(job) { + status <- job$status[[1]] + steps <- c("queued", "training", "evaluating", "saving", "ready") + current_step <- active_step(job) + current_rank <- step_rank(current_step) + + tags$div( + class = "cmp-steps", + lapply(seq_along(steps), function(i) { + step <- steps[[i]] + current <- identical(step, current_step) + done <- i < current_rank || identical(status, "completed") + step_class <- paste( + "cmp-step", + if (done) "is-done" else "", + if (current) "is-current" else "", + if (current && status %in% c("paused", "stopped", "failed")) paste0("is-", status) else "" + ) + tags$div( + class = step_class, + tags$span(class = "cmp-step-icon", tags$i(class = stepper_icon(status, current, done))), + tags$span(class = "cmp-step-label", step_label(step)) + ) + }) + ) + } + + action_button <- function(job_id, action, text, class = "btn btn-xs btn-default") { + tags$button( + type = "button", + class = class, + onclick = sprintf( + "Shiny.setInputValue('caret_job_action', {job_id: '%s', action: '%s', nonce: Math.random()}, {priority: 'event'})", + js_value(job_id), + js_value(action) + ), + text + ) + } + + job_actions <- function(job) { + status <- job$status + job_id <- job$job_id + if (identical(status, "running")) { + tagList( + action_button(job_id, "pause", label("caret_jobs_pause", "Pause"), "btn btn-xs btn-warning"), + action_button(job_id, "stop", label("caret_jobs_stop", "Stop"), "btn btn-xs btn-danger") + ) + } else if (identical(status, "queued")) { + tagList( + action_button(job_id, "pause", label("caret_jobs_pause", "Pause"), "btn btn-xs btn-warning"), + action_button(job_id, "stop", label("caret_jobs_stop", "Stop"), "btn btn-xs btn-danger") + ) + } else if (identical(status, "paused")) { + tagList( + action_button(job_id, "resume", label("caret_jobs_resume", "Resume"), "btn btn-xs btn-success"), + action_button(job_id, "stop", label("caret_jobs_stop", "Stop"), "btn btn-xs btn-danger") + ) + } else if (identical(status, "failed")) { + tagList( + action_button(job_id, "resume", label("caret_jobs_retry", "Retry"), "btn btn-xs btn-primary"), + action_button(job_id, "clear", label("caret_jobs_clear", "Clear"), "btn btn-xs btn-default") + ) + } else if (identical(status, "stopped")) { + tagList( + action_button(job_id, "resume", label("caret_jobs_resume", "Resume"), "btn btn-xs btn-success"), + action_button(job_id, "clear", label("caret_jobs_clear", "Clear"), "btn btn-xs btn-default") + ) + } else if (identical(status, "completed")) { + action_button(job_id, "clear", label("caret_jobs_clear", "Clear"), "btn btn-xs btn-default") + } else { + action_button(job_id, "clear", label("caret_jobs_clear", "Clear"), "btn btn-xs btn-default") + } + } + + max_concurrent_jobs <- reactive({ + if (!isTRUE(input$model_training_setup_start_clusters_check)) return(1L) + env_cap <- suppressWarnings(as.integer(Sys.getenv("NOCODE_CARET_MAX_JOBS", unset = NA_character_))) + if (!is.na(env_cap) && env_cap >= 1L) return(env_cap) + detected <- tryCatch(parallel::detectCores(logical = FALSE), error = function(e) NA_integer_) + if (is.na(detected) || detected < 1L) return(2L) + max(1L, detected - 1L) + }) + + observeEvent(rv_ml_ai$preprocessed, { + context_version(context_version() + 1L) + context_cache(NULL) + }, ignoreInit = TRUE) + + # Pre-warm the context cache whenever preprocessing or the eval metric changes. + # Uses observeEvent so reactive reads inside the handler are automatically + # isolated — avoids "no active reactive context" errors from nested reads. + observeEvent( + ## Prewarm on anything that changes the context signature, so the matching + ## context file is already on disk before the user clicks Train (turns the + ## ~5s on-click rebuild into an instant disk-cache hit). Same build logic + ## as before — only the set of things that (re)trigger it is wider. + list( + rv_ml_ai$preprocessed, + input$model_training_setup_eval_metric, + rv_ml_ai$seed_value, + rv_train_control_caret$method, + rv_train_control_caret$number, + rv_train_control_caret$repeats, + rv_train_control_caret$search, + rv_train_control_caret$classProbs, + rv_train_control_caret$savePredictions, + rv_train_control_caret$verboseIter + ), + { + req(!is.null(rv_ml_ai$preprocessed)) + req(!is.null(input$model_training_setup_eval_metric)) + req(nzchar(input$model_training_setup_eval_metric)) + prewarm_dir <- file.path(app_username, ".caret_jobs", "_context_cache") + dir.create(prewarm_dir, recursive = TRUE, showWarnings = FALSE) + train_control <- reactiveValuesToList(rv_train_control_caret) + tryCatch( + get_training_context_path(prewarm_dir, train_control), + error = function(e) NULL + ) + }, + ignoreInit = TRUE, + ignoreNULL = FALSE + ) + + training_context_signature <- function(train_control) { + preprocessed <- rv_ml_ai$preprocessed + train_df <- preprocessed$train_df + test_df <- preprocessed$test_df + digest::digest( + list( + dataset_id = rv_ml_ai$dataset_id, + session_id = rv_ml_ai$session_id, + outcome = rv_ml_ai$outcome, + task = rv_ml_ai$task, + metric = input$model_training_setup_eval_metric, + seed = rv_ml_ai$seed_value, + model_formula = paste(deparse(rv_ml_ai$model_formula), collapse = ""), + train_dim = if (is.data.frame(train_df)) dim(train_df) else NULL, + test_dim = if (is.data.frame(test_df)) dim(test_df) else NULL, + train_names = if (is.data.frame(train_df)) names(train_df) else NULL, + test_names = if (is.data.frame(test_df)) names(test_df) else NULL, + context_cache_token = context_cache_token, + context_version = context_version(), + train_control = train_control + ), + algo = "xxhash64" + ) + } + + build_training_context <- function(train_control) { + list( + app_dir = getwd(), + app_username = app_username, + train_df = rv_ml_ai$preprocessed$train_df, + test_df = rv_ml_ai$preprocessed$test_df, + preprocessed = rv_ml_ai$preprocessed, + model_formula = rv_ml_ai$model_formula, + train_control = train_control, + metric = input$model_training_setup_eval_metric, + seed = rv_ml_ai$seed_value, + use_cluster = FALSE, + dataset_id = rv_ml_ai$dataset_id, + session_id = rv_ml_ai$session_id, + outcome = rv_ml_ai$outcome, + task = rv_ml_ai$task + ) + } + + get_training_context_path <- function(run_dir, train_control) { + signature <- training_context_signature(train_control) + cache <- context_cache() + if ( + !is.null(cache) && + identical(cache$signature, signature) && + !is.null(cache$path) && + file.exists(cache$path) + ) { + return(cache$path) + } + + cache_dir <- file.path(app_username, ".caret_jobs", "_context_cache") + dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) + context_path <- file.path(cache_dir, paste0(signature, ".rds")) + if (!file.exists(context_path)) { + saveRDS(build_training_context(train_control), context_path) + } + context_cache(list(signature = signature, path = context_path)) + context_path + } + + write_training_context_path <- function(signature, training_context) { + cache_dir <- file.path(app_username, ".caret_jobs", "_context_cache") + dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) + context_path <- file.path(cache_dir, paste0(signature, ".rds")) + if (!file.exists(context_path)) { + saveRDS(training_context, context_path) + } + context_path + } + + selected_model_jobs <- function(run_dir, skip_model_ids = character()) { + models_state <- reactiveValuesToList(rv_training_models) + model_ids <- rv_training_models$CARET_MODEL_IDS + Filter(Negate(is.null), lapply(model_ids, function(id) { + if (id %in% skip_model_ids) return(NULL) + if (!isTRUE(input[[paste0("model_training_caret_models_", id, "_check")]])) return(NULL) + model_spec <- models_state[[paste0(id, "_model")]] + if (is.null(model_spec)) return(NULL) + model_name <- models_state[[paste0(id, "_name")]] + model_label <- if (!is.null(names(model_name)) && nzchar(names(model_name)[1])) { + names(model_name)[1] + } else { + as.character(model_name[1]) + } + job_id <- paste0(id, "-", digest::digest(paste(id, Sys.time(), runif(1)), algo = "xxhash32")) + job_dir <- file.path(run_dir, job_id) + dir.create(job_dir, recursive = TRUE, showWarnings = FALSE) + list( + job_id = job_id, + model_id = id, + model_label = model_label, + model_list = model_spec, + job_dir = job_dir + ) + })) + } + + write_job_config <- function(job, context_path) { + config_path <- file.path(job$job_dir, "config.rds") + result_path <- file.path(job$job_dir, "result.rds") + status_path <- file.path(job$job_dir, "status.rds") + config <- list( + context_path = context_path, + model_id = job$model_id, + model_label = job$model_label, + model_list = job$model_list, + config_path = config_path, + result_path = result_path, + status_path = status_path + ) + saveRDS(config, config_path) + saveRDS(list(status = "queued", step = "queued", updated_at = Sys.time()), status_path) + assign(job$job_id, config, envir = job_configs) + config + } + + start_job <- function(job_id) { + if (!exists(job_id, envir = job_configs, inherits = FALSE)) return(FALSE) + config <- get(job_id, envir = job_configs) + proc <- callr::r_bg( + func = caret_job_worker, + args = list(config$config_path), + stdout = file.path(dirname(config$config_path), "stdout.log"), + stderr = file.path(dirname(config$config_path), "stderr.log"), + supervise = TRUE + ) + assign(job_id, proc, envir = job_processes) + update_job(job_id, status = "running", step = "training", started_at = Sys.time(), error = "") + TRUE + } + + start_queued_jobs <- function() { + jobs <- get_jobs() + if (!NROW(jobs)) return(invisible(NULL)) + running <- sum(jobs$status == "running", na.rm = TRUE) + available <- max(0L, max_concurrent_jobs() - running) + if (!available) return(invisible(NULL)) + to_start <- head(jobs$job_id[jobs$status == "queued"], available) + for (job_id in to_start) start_job(job_id) + sync_training_state() + invisible(NULL) + } + + merge_job_results <- function() { + results <- mget(ls(job_results), envir = job_results, inherits = FALSE) + results <- results[!vapply(results, is.null, logical(1))] + if (!length(results)) return(invisible(NULL)) + + models_list <- lapply(results, `[[`, "models") + names(models_list) <- NULL + models <- do.call(c, models_list) + class(models) <- unique(c("caretList", class(models))) + rv_training_results$models <- models + + tuned <- do.call(c, lapply(results, `[[`, "tuned_parameters")) + rv_training_results$tuned_parameters <- tuned + + rv_training_results$control_parameters <- results[[1]]$control_parameters + rv_training_results$model_safe_name_map <- results[[1]]$model_safe_name_map + + train_metrics <- do.call(rbind, lapply(results, `[[`, "train_metrics_df")) + class(train_metrics) <- unique(c("Rautomlmetric", class(train_metrics))) + rv_training_results$train_metrics_df <- train_metrics + + test_specifics <- do.call(rbind, lapply(results, function(x) x$test_metrics_objs$specifics)) + test_all <- do.call(rbind, lapply(results, function(x) x$test_metrics_objs$all)) + test_roc <- do.call(rbind, lapply(results, function(x) x$test_metrics_objs$roc_df)) + test_metrics <- list( + specifics = test_specifics, + all = test_all, + roc_df = test_roc, + positive_cat = results[[1]]$test_metrics_objs$positive_cat + ) + class(test_metrics) <- c("Rautomlmetric2", "list") + rv_training_results$test_metrics_objs <- test_metrics + + post_list <- lapply(results, `[[`, "post_model_metrics_objs") + names(post_list) <- NULL + post_metrics <- do.call(c, post_list) + rv_training_results$post_model_metrics_objs <- post_metrics + invisible(NULL) + } + + maybe_build_ensemble <- function() { + request <- ensemble_request() + if (is.null(request)) return(invisible(NULL)) + + jobs <- get_jobs() + target_jobs <- jobs[jobs$job_id %in% request$job_ids, , drop = FALSE] + if (!NROW(target_jobs)) { + ensemble_request(NULL) + return(invisible(NULL)) + } + if (any(target_jobs$status %in% c("queued", "running", "paused"), na.rm = TRUE)) { + return(invisible(NULL)) + } + + if (is.null(rv_training_results$models) || length(rv_training_results$models) < 2L) { + notify( + label("caret_jobs_ensemble_need_two", "At least two completed models are required to build an ensemble."), + type = "warning", + duration = 8 + ) + ensemble_request(NULL) + return(invisible(NULL)) + } + + if (inherits(rv_training_results$models, "caretEnsemble")) { + ensemble_request(NULL) + return(invisible(NULL)) + } + + completed_job_ids <- target_jobs$job_id[target_jobs$status == "completed"] + completed_job_ids <- completed_job_ids[vapply( + completed_job_ids, + exists, + logical(1), + envir = job_results, + inherits = FALSE + )] + target_results <- if (length(completed_job_ids)) { + mget(completed_job_ids, envir = job_results, inherits = FALSE) + } else { + list() + } + target_models <- do.call(c, lapply(target_results, `[[`, "models")) + if (is.null(target_models) || length(target_models) < 2L) { + notify( + label("caret_jobs_ensemble_need_two", "At least two completed models are required to build an ensemble."), + type = "warning", + duration = 8 + ) + ensemble_request(NULL) + return(invisible(NULL)) + } + class(target_models) <- unique(c("caretList", class(target_models))) + + notify( + label("caret_jobs_ensemble_building", "Building ensemble from completed models..."), + type = "message", + duration = 5 + ) + + ensemble_models <- tryCatch({ + Rautoml::create_ensemble( + all.models = target_models, + ctrl = request$train_control, + metric = request$metric + ) + }, error = function(e) { + notify( + paste(label("caret_jobs_ensemble_failed", "Ensemble training failed:"), e$message), + type = "error", + duration = 10 + ) + return(NULL) + }) + + if (is.null(ensemble_models)) { + ensemble_request(NULL) + return(invisible(NULL)) + } + + rv_training_results$models <- ensemble_models + rv_training_models$ensemble_trained_model <- c(ensemble = "ensemble") + rv_training_models$all_trained_models <- c( + stats::setNames(names(target_models), gsub("\\.", " ", names(target_models))), + c(ensemble = "ensemble") + ) + + ensemble_test_df <- rv_ml_ai$preprocessed$test_df + name_map <- rv_training_results$model_safe_name_map + if (is.null(name_map) && length(target_results)) { + name_map <- target_results[[1]]$model_safe_name_map + } + if (!is.null(name_map) && is.data.frame(ensemble_test_df)) { + idx <- match(names(ensemble_test_df), name_map$original) + valid <- !is.na(idx) + names(ensemble_test_df)[valid] <- name_map$safe[idx[valid]] + } + + ensemble_train_metrics <- tryCatch({ + Rautoml::extract_summary( + ensemble_models, + summary_fun = Rautoml::student_t_summary + ) + }, error = function(e) NULL) + if (!is.null(ensemble_train_metrics) && NROW(ensemble_train_metrics)) { + ensemble_rows <- ensemble_train_metrics + if ("model" %in% names(ensemble_rows)) { + ensemble_rows <- ensemble_rows[tolower(as.character(ensemble_rows$model)) == "ensemble", , drop = FALSE] + } else if (!is.null(rownames(ensemble_rows))) { + ensemble_rows <- ensemble_rows[tolower(rownames(ensemble_rows)) == "ensemble", , drop = FALSE] + } + if (!NROW(ensemble_rows)) { + ensemble_rows <- ensemble_train_metrics + } + if (!is.null(rv_training_results$train_metrics_df) && NROW(rv_training_results$train_metrics_df)) { + ensemble_train_metrics <- rbind(rv_training_results$train_metrics_df, ensemble_rows) + } + class(ensemble_train_metrics) <- unique(c("Rautomlmetric", class(ensemble_train_metrics))) + rv_training_results$train_metrics_df <- ensemble_train_metrics + } + + ensemble_test_metrics <- tryCatch({ + Rautoml::boot_estimates_multiple( + models = ensemble_models, + df = ensemble_test_df, + outcome_var = rv_ml_ai$outcome, + problem_type = rv_ml_ai$task, + nreps = 100, + model_name = "ensemble", + type = "prob", + report = request$metric, + summary_fun = Rautoml::student_t_summary, + save_model = TRUE, + model_folder = file.path(app_username, "models"), + recipe_folder = file.path(app_username, "recipes"), + preprocesses = rv_ml_ai$preprocessed + ) + }, error = function(e) { + notify( + paste(label("caret_jobs_ensemble_metrics_failed", "Ensemble metrics failed:"), e$message), + type = "warning", + duration = 10 + ) + return(NULL) + }) + if (!is.null(ensemble_test_metrics) && NROW(ensemble_test_metrics$all)) { + current_test_metrics <- rv_training_results$test_metrics_objs + test_metrics <- list( + specifics = rbind(current_test_metrics$specifics, ensemble_test_metrics$specifics), + all = rbind(current_test_metrics$all, ensemble_test_metrics$all), + roc_df = rbind(current_test_metrics$roc_df, ensemble_test_metrics$roc_df), + positive_cat = current_test_metrics$positive_cat + ) + if (is.null(test_metrics$positive_cat)) { + test_metrics$positive_cat <- ensemble_test_metrics$positive_cat + } + class(test_metrics) <- c("Rautomlmetric2", "list") + rv_training_results$test_metrics_objs <- test_metrics + } + + ensemble_post_metrics <- tryCatch({ + Rautoml::post_model_metrics( + models = ensemble_models, + outcome = rv_ml_ai$outcome, + df = ensemble_test_df, + task = rv_ml_ai$task + ) + }, error = function(e) NULL) + if (!is.null(ensemble_post_metrics)) { + rv_training_results$post_model_metrics_objs <- ensemble_post_metrics + } + + notify( + label("caret_jobs_ensemble_ready", "Ensemble model is ready."), + type = "message", + duration = 5 + ) + ensemble_request(NULL) + ensemble_build_scheduled(FALSE) + invisible(TRUE) + } + + schedule_ensemble_build <- function() { + request <- ensemble_request() + if (is.null(request) || isTRUE(ensemble_build_scheduled())) return(invisible(NULL)) + + jobs <- get_jobs() + target_jobs <- jobs[jobs$job_id %in% request$job_ids, , drop = FALSE] + if (!NROW(target_jobs)) { + ensemble_request(NULL) + return(invisible(NULL)) + } + if (any(target_jobs$status %in% c("queued", "running", "paused"), na.rm = TRUE)) { + return(invisible(NULL)) + } + + ensemble_build_scheduled(TRUE) + session$onFlushed(function() { + later::later(function() { + isolate({ + ensemble_build_scheduled(FALSE) + maybe_build_ensemble() + }) + }, delay = 0.5) + }, once = TRUE) + invisible(TRUE) + } + + poll_jobs <- function() { + jobs <- get_jobs() + if (!NROW(jobs)) return(invisible(NULL)) + + new_completion <- FALSE + + for (job_id in jobs$job_id[jobs$status == "running"]) { + proc <- if (exists(job_id, envir = job_processes, inherits = FALSE)) { + get(job_id, envir = job_processes) + } else { + NULL + } + config <- get(job_id, envir = job_configs) + if (!is.null(proc) && proc$is_alive()) { + status <- tryCatch(suppressWarnings(readRDS(config$status_path)), error = function(e) NULL) + result <- tryCatch(suppressWarnings(readRDS(config$result_path)), error = function(e) NULL) + if (!is.null(status) && identical(status$status, "failed")) { + msg <- if (!is.null(status$message)) status$message else label("caret_jobs_status_failed", "Failed") + if (!is.null(result$error)) msg <- result$error + update_job(job_id, status = "failed", step = "failed", finished_at = Sys.time(), error = msg) + next + } + if (!is.null(status) && identical(status$status, "completed") && !is.null(result) && is.null(result$error)) { + assign(job_id, result, envir = job_results) + update_job(job_id, status = "completed", step = "ready", finished_at = Sys.time(), error = "") + new_completion <- TRUE + next + } + current_step <- jobs$step[jobs$job_id == job_id][[1]] + status_step <- status$step + if (identical(status_step, "queued") && identical(current_step, "training")) { + next + } + if (!is.null(status_step) && !identical(status_step, current_step)) { + update_job(job_id, step = status_step) + } + next + } + if (is.null(proc)) next + + status <- tryCatch(suppressWarnings(readRDS(config$status_path)), error = function(e) NULL) + result <- tryCatch(suppressWarnings(readRDS(config$result_path)), error = function(e) NULL) + exit_status <- proc$get_exit_status() + + if (!is.null(status) && identical(status$status, "completed") && !is.null(result) && is.null(result$error)) { + assign(job_id, result, envir = job_results) + update_job(job_id, status = "completed", step = "ready", finished_at = Sys.time(), error = "") + new_completion <- TRUE + } else { + msg <- if (!is.null(status$message)) status$message else paste("Process exited with status", exit_status) + if (!is.null(result$error)) msg <- result$error + update_job(job_id, status = "failed", step = "failed", finished_at = Sys.time(), error = msg) + } + } + + if (new_completion) { + merge_job_results() + } + start_queued_jobs() + schedule_ensemble_build() + invisible(NULL) + } + + observeEvent(input$model_training_apply, { + req(!is.null(rv_current$working_df)) + req(!is.null(rv_ml_ai$preprocessed)) + req(isTRUE(rv_ml_ai$at_least_one_model)) + + if (isTRUE(input$model_training_setup_include_ensemble_check)) { + notify( + label("caret_jobs_ensemble_pending", "The async queue will train the selected base models first, then build the ensemble."), + type = "message", + duration = 8 + ) + } + + run_id <- format(Sys.time(), "%Y%m%d%H%M%S") + run_dir <- file.path(app_username, ".caret_jobs", run_id) + dir.create(run_dir, recursive = TRUE, showWarnings = FALSE) + dir.create(file.path(app_username, "models"), recursive = TRUE, showWarnings = FALSE) + dir.create(file.path(app_username, "recipes"), recursive = TRUE, showWarnings = FALSE) + dir.create(file.path(app_username, "outputs"), recursive = TRUE, showWarnings = FALSE) + dir.create(file.path(app_username, ".log_files"), recursive = TRUE, showWarnings = FALSE) + + selected_groups <- input$feature_engineering_perform_partition_group + has_groups <- !is.null(selected_groups) && length(selected_groups) > 0 && !any(selected_groups %in% "") + if (isTRUE(has_groups)) { + if (isTRUE(!is.null(rv_ml_ai$fold_index))) { + rv_train_control_caret$index <- Rautoml::create_grouped_index( + rv_ml_ai$fold_index, + k = rv_train_control_caret$number + ) + } else { + rv_train_control_caret$index <- NULL + } + } + + train_control <- reactiveValuesToList(rv_train_control_caret) + + current_jobs <- get_jobs() + active_model_ids <- if (NROW(current_jobs)) { + current_jobs$model_id[current_jobs$status %in% c("queued", "running", "paused")] + } else { + character() + } + selected_input_ids <- rv_training_models$CARET_MODEL_IDS[vapply(rv_training_models$CARET_MODEL_IDS, function(id) { + isTRUE(input[[paste0("model_training_caret_models_", id, "_check")]]) + }, logical(1))] + jobs <- selected_model_jobs(run_dir, skip_model_ids = active_model_ids) + + if (!length(jobs)) { + notify( + label("caret_jobs_no_new_models", "The selected models are already in the training queue or results panel."), + type = "message" + ) + clear_model_selection(selected_input_ids) + return(invisible(NULL)) + } + + skipped_count <- sum(selected_input_ids %in% active_model_ids) + if (skipped_count > 0) { + notify( + label("caret_jobs_duplicate_skipped", "Some selected models were already in the queue and were not added again."), + type = "message" + ) + } + + rerun_model_ids <- vapply(jobs, `[[`, character(1), "model_id") + clear_completed_model_results(rerun_model_ids) + if (NROW(current_jobs)) { + current_jobs <- current_jobs[!( + current_jobs$status == "completed" & + current_jobs$model_id %in% rerun_model_ids + ), , drop = FALSE] + } + + job_rows <- lapply(jobs, function(job) { + data.frame( + job_id = job$job_id, + model_id = job$model_id, + model_label = job$model_label, + status = "queued", + step = "queued", + started_at = as.POSIXct(NA), + finished_at = as.POSIXct(NA), + error = "", + result_path = file.path(job$job_dir, "result.rds"), + config_path = file.path(job$job_dir, "config.rds"), + stringsAsFactors = FALSE + ) + }) + set_jobs(rbind(current_jobs, do.call(rbind, job_rows))) + sync_training_state() + clear_model_selection(selected_input_ids) + + target_job_ids <- vapply(jobs, `[[`, character(1), "job_id") + if (isTRUE(input$model_training_setup_include_ensemble_check)) { + ensemble_request(list( + job_ids = target_job_ids, + train_control = train_control, + metric = input$model_training_setup_eval_metric + )) + } else { + ensemble_request(NULL) + ensemble_build_scheduled(FALSE) + } + + session$onFlushed(function() { + later::later(function() { + isolate({ + current <- get_jobs() + if (!NROW(current)) return(invisible(NULL)) + queued_ids <- current$job_id[ + current$job_id %in% target_job_ids & + current$status %in% c("queued", "paused") + ] + if (!length(queued_ids)) return(invisible(NULL)) + context_signature <- training_context_signature(train_control) + training_context <- build_training_context(train_control) + context_path <- write_training_context_path(context_signature, training_context) + for (job in jobs) { + if (job$job_id %in% queued_ids) write_job_config(job, context_path) + } + start_queued_jobs() + }) + }, delay = 0) + }, once = TRUE) + }, ignoreInit = TRUE) + + observeEvent(input$caret_job_action, { + action <- input$caret_job_action$action + job_id <- input$caret_job_action$job_id + jobs <- get_jobs() + if (!NROW(jobs)) return(invisible(NULL)) + + if (identical(action, "clear_completed")) { + jobs <- jobs[jobs$status != "completed", , drop = FALSE] + set_jobs(jobs) + sync_training_state(jobs) + return(invisible(NULL)) + } + + if (!(job_id %in% jobs$job_id)) return(invisible(NULL)) + + status <- jobs$status[jobs$job_id == job_id][[1]] + if (action == "pause") { + if (identical(status, "running") && exists(job_id, envir = job_processes, inherits = FALSE)) { + proc <- get(job_id, envir = job_processes) + if (proc$is_alive()) proc$kill() + } + update_job(job_id, status = "paused", finished_at = Sys.time()) + } else if (action == "stop") { + if (identical(status, "running") && exists(job_id, envir = job_processes, inherits = FALSE)) { + proc <- get(job_id, envir = job_processes) + if (proc$is_alive()) proc$kill() + } + update_job(job_id, status = "stopped", finished_at = Sys.time()) + } else if (action == "resume") { + update_job(job_id, status = "queued", step = "queued", started_at = as.POSIXct(NA), finished_at = as.POSIXct(NA), error = "") + } else if (action == "clear") { + jobs <- jobs[jobs$job_id != job_id, , drop = FALSE] + set_jobs(jobs) + sync_training_state(jobs) + } + + poll_jobs() + }, ignoreInit = TRUE) + + observe({ + jobs <- get_jobs() + if (NROW(jobs) && any(jobs$status %in% c("queued", "running"))) { + invalidateLater(2000, session) + poll_jobs() + } + }) + + output$caret_job_queue_panel <- renderUI({ + jobs <- get_jobs() + if (!NROW(jobs)) return(NULL) + + count <- function(status) sum(jobs$status == status, na.rm = TRUE) + rows <- lapply(seq_len(nrow(jobs)), function(i) { + job <- jobs[i, , drop = FALSE] + status <- job$status[[1]] + + tags$div( + class = "cmp-row", + tags$div(class = "cmp-num", paste0(i, ".")), + tags$div(class = "cmp-name", job$model_label), + tags$div( + class = "cmp-status", + tags$span(class = "cmp-sdot", style = paste0("background:", status_color(status), ";")), + tags$span(class = "cmp-slabel", job_status_label(job)) + ), + job_stepper(job), + tags$div(class = "cmp-action", job_actions(job)) + ) + }) + + tags$div( + id = "caret-model-progress", + class = "cmp-visible", + tags$div( + class = "cmp-header", + tags$div(class = "cmp-title", label("caret_jobs_progress_title", "Training queue")), + tags$div( + class = "cmp-counts", + tags$span(tags$span(class = "cmp-count-dot", style = "background:#2196f3;"), paste(count("running"), label("caret_jobs_count_running", "running"))), + tags$span("\u2022"), + tags$span(tags$span(class = "cmp-count-dot", style = "background:#9aa3a8;"), paste(count("queued"), label("caret_jobs_count_queued", "queued"))), + tags$span("\u2022"), + tags$span(tags$span(class = "cmp-count-dot", style = "background:#f6a100;"), paste(count("paused"), label("caret_jobs_count_paused", "paused"))), + tags$span("\u2022"), + tags$span(tags$span(class = "cmp-count-dot", style = "background:#4cae4c;"), paste(count("completed"), label("caret_jobs_count_completed", "completed"))), + if (count("completed") > 0) { + action_button("completed", "clear_completed", label("caret_jobs_clear_completed", "Clear completed"), "btn btn-xs btn-default") + } + ) + ), + tags$div(class = "cmp-list", rows), + tags$div( + class = "cmp-footer", + tags$i(class = "fa fa-info-circle"), + paste0(" ", label("caret_jobs_footer_note", "Completed models remain available for comparison and deployment.")) + ) + ) + }) + outputOptions(output, "caret_job_queue_panel", suspendWhenHidden = FALSE) +} diff --git a/server/caret_job_worker.R b/server/caret_job_worker.R new file mode 100644 index 0000000..7a5a5b9 --- /dev/null +++ b/server/caret_job_worker.R @@ -0,0 +1,209 @@ +caret_job_worker <- function(config_path) { + config <- readRDS(config_path) + if (!is.null(config$context_path)) { + config <- c(readRDS(config$context_path), config) + } + setwd(config$app_dir) + + status_path <- config$status_path + result_path <- config$result_path + + write_status <- function(status, step = status, message = NULL) { + saveRDS( + list( + status = status, + step = step, + message = message, + updated_at = Sys.time() + ), + status_path + ) + } + + rename_columns <- function(df, name_map) { + if (is.null(df) || !is.data.frame(df)) return(df) + matches <- match(names(df), name_map$original) + renamed <- !is.na(matches) + names(df)[renamed] <- name_map$safe[matches[renamed]] + df + } + + safe_name_map <- function(nms) { + data.frame( + original = nms, + safe = make.names(nms, unique = TRUE), + stringsAsFactors = FALSE + ) + } + + prepare_model_safe_names <- function(config) { + if (is.null(config$train_df) || !is.data.frame(config$train_df)) return(config) + + model_map <- safe_name_map(names(config$train_df)) + config$model_safe_name_map <- model_map + config$outcome_original <- config$outcome + + config$train_df <- rename_columns(config$train_df, model_map) + config$test_df <- rename_columns(config$test_df, model_map) + + outcome_idx <- match(config$outcome, model_map$original) + if (!is.na(outcome_idx)) { + config$outcome <- model_map$safe[[outcome_idx]] + } + if (!is.null(config$outcome) && config$outcome %in% names(config$train_df)) { + config$model_formula <- reformulate( + termlabels = setdiff(names(config$train_df), config$outcome), + response = config$outcome + ) + } + + if (!is.null(config$preprocessed)) { + for (nm in c("train_df", "train_dfdf", "test_df")) { + if (!is.null(config$preprocessed[[nm]]) && is.data.frame(config$preprocessed[[nm]])) { + config$preprocessed[[nm]] <- rename_columns(config$preprocessed[[nm]], model_map) + } + } + if (!is.null(config$preprocessed$original_df) && is.data.frame(config$preprocessed$original_df)) { + raw_map <- safe_name_map(names(config$preprocessed$original_df)) + config$raw_safe_name_map <- raw_map + config$preprocessed$original_df <- rename_columns(config$preprocessed$original_df, raw_map) + } + } + + config + } + + write_status("running", "training") + + tryCatch({ + suppressPackageStartupMessages({ + library(Rautoml) + library(caret) + library(caretEnsemble) + }) + + if (!is.null(config$seed) && !is.na(config$seed)) { + set.seed(config$seed) + } + + if (isTRUE(config$use_cluster)) { + Rautoml::start_cluster() + on.exit(try(Rautoml::stop_cluster(), silent = TRUE), add = TRUE) + } + + config <- prepare_model_safe_names(config) + + models <- Rautoml::train_caret_models( + df = config$train_df, + model_form = config$model_formula, + ctrl = config$train_control, + model_list = config$model_list, + metric = config$metric + ) + + write_status("running", "evaluating") + + tuned_parameters <- Rautoml::get_tuned_params(models) + control_parameters <- Rautoml::get_ctl_params( + models = models, + items = names(config$train_control) + ) + train_metrics_df <- Rautoml::extract_summary( + models, + summary_fun = Rautoml::student_t_summary + ) + + Rautoml::save_rautoml_csv( + object = train_metrics_df, + name = "training_performance_metrics", + dataset_id = config$dataset_id, + session_name = config$session_id, + timestamp = Sys.time(), + output_dir = file.path(config$app_username, "outputs") + ) + + test_metrics_objs <- Rautoml::boot_estimates_multiple( + models = models, + df = config$test_df, + outcome_var = config$outcome, + problem_type = config$task, + nreps = 100, + model_name = NULL, + type = "prob", + report = config$metric, + summary_fun = Rautoml::student_t_summary, + save_model = TRUE, + model_folder = file.path(config$app_username, "models"), + recipe_folder = file.path(config$app_username, "recipes"), + preprocesses = config$preprocessed + ) + + Rautoml::save_boot_estimates( + boot_list = test_metrics_objs, + dataset_id = config$dataset_id, + session_name = config$session_id, + timestamp = Sys.time(), + output_dir = file.path(config$app_username, "outputs"), + sub_dir = "test_metrics" + ) + + Rautoml::create_model_logs( + df_name = config$dataset_id, + session_name = config$session_id, + outcome = config$outcome, + framework = "Caret", + train_result = test_metrics_objs$all, + timestamp = Sys.time(), + path = file.path(config$app_username, ".log_files") + ) + + post_model_metrics_objs <- Rautoml::post_model_metrics( + models = models, + outcome = config$outcome, + df = config$test_df, + task = config$task + ) + + write_status("running", "saving") + + Rautoml::save_post_metrics_plots( + metric_list = post_model_metrics_objs, + dataset_id = config$dataset_id, + session_name = config$session_id, + timestamp = Sys.time(), + output_dir = file.path(config$app_username, "outputs") + ) + + saveRDS( + list( + model_id = config$model_id, + model_label = config$model_label, + models = models, + tuned_parameters = tuned_parameters, + control_parameters = control_parameters, + train_metrics_df = train_metrics_df, + test_metrics_objs = test_metrics_objs, + post_model_metrics_objs = post_model_metrics_objs, + model_safe_name_map = config$model_safe_name_map, + raw_safe_name_map = config$raw_safe_name_map, + completed_at = Sys.time() + ), + result_path + ) + + write_status("completed", "ready") + invisible(TRUE) + }, error = function(e) { + write_status("failed", "failed", conditionMessage(e)) + saveRDS( + list( + model_id = config$model_id, + model_label = config$model_label, + error = conditionMessage(e), + failed_at = Sys.time() + ), + result_path + ) + stop(e) + }) +} diff --git a/server/compare_trained_caret_models.R b/server/compare_trained_caret_models.R index 9b8633d..1b38c0b 100644 --- a/server/compare_trained_caret_models.R +++ b/server/compare_trained_caret_models.R @@ -1,28 +1,46 @@ #### ---- Compare model metrics ----------------------------------- #### model_training_caret_train_metrics_server = function() { - - - # Fire on button click AND when train_metrics_df is set after training completes - # (so inner outputs get registered even on first run in a fresh session) - observeEvent(list(input$model_training_apply, rv_training_results$train_metrics_df), { + + ## Hoisted out of observeEvent — nested observers accumulate on every fire + observe({ + req(!is.null(rv_training_results$tuned_parameters)) + req(!is.null(rv_training_results$control_parameters)) + output$model_training_caret_train_tuned_parameters = renderUI({ + txt = capture.output(str(rv_training_results$tuned_parameters)) + pre(paste(txt, collapse = "\n")) + }) + output$model_training_caret_train_training_control = renderUI({ + txt = capture.output(str(rv_training_results$control_parameters)) + pre(paste(txt, collapse = "\n")) + }) + }) + + ## Flag to ensure the SHAP Apply observer is only registered once. + ## Without this, observeEvent(train_metrics_df) re-registers it on every + ## model completion → progress bar fires N times for N completed models. + shap_apply_registered <- reactiveVal(FALSE) + + clean_model_label <- function(model_names) { + vapply(model_names, function(model_name) { + display_name <- gsub("\\.", " ", model_name) + parts <- strsplit(display_name, "\\s+")[[1]] + if ( + length(parts) >= 3 && + parts[[1]] %in% rv_training_models$CARET_MODEL_IDS && + grepl("^[[:xdigit:]]{8}$", parts[[2]]) + ) { + return(paste(parts[-c(1, 2)], collapse = " ")) + } + display_name + }, character(1), USE.NAMES = FALSE) + } + + # Fire only when results are available after training completes + observeEvent(rv_training_results$train_metrics_df, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(!is.null(rv_training_results$train_metrics_df))) { - - observe({ - req(!is.null(rv_training_results$tuned_parameters)) - req(!is.null(rv_training_results$control_parameters)) - output$model_training_caret_train_tuned_parameters = renderUI({ - txt = capture.output(str(rv_training_results$tuned_parameters)) - pre(paste(txt, collapse = "\n")) - }) - - output$model_training_caret_train_training_control = renderUI({ - txt = capture.output(str(rv_training_results$control_parameters)) - pre(paste(txt, collapse = "\n")) - }) - }) ## Training data output$model_training_caret_train_metrics_plot = renderPlot({ @@ -314,7 +332,7 @@ model_training_caret_train_metrics_server = function() { # Section header + ALL DOWNLOAD BUTTON model_section = list( - h3(model_name, style = "margin-top:30px; color:#2c3e50;"), + h3(clean_model_label(model_name), style = "margin-top:30px; color:#2c3e50;"), downloadBttn( paste0("download_all_", model_name), label = get_rv_labels("download_plots"), @@ -383,7 +401,7 @@ model_training_caret_train_metrics_server = function() { output[[down_id]] <- downloadHandler( filename = function() { - paste0(my_model, "_ALL_PLOTS_", Sys.Date(), ".zip") + paste0(clean_model_label(my_model), "_ALL_PLOTS_", Sys.Date(), ".zip") }, content = function(file) { @@ -398,7 +416,7 @@ model_training_caret_train_metrics_server = function() { p <- post_model_metrics_objs[[my_model]][[plot_name]] if (!is.null(p)) { - f <- paste0(my_model, "_", plot_name, ".png") + f <- paste0(clean_model_label(my_model), "_", plot_name, ".png") png(f, width = 1200, height = 900) print(p) dev.off() @@ -446,14 +464,14 @@ model_training_caret_train_metrics_server = function() { temp_models = names(rv_training_models$all_trained_models) ## FIXME: The names should align if (inherits(rv_training_results$models, "caretEnsemble")) { - temp_models = c(temp_models, "ensemble") - fixed_names = gsub("\\.", " ", temp_models) + model_values = c(gsub("\\.", " ", names(rv_training_results$models$models)), "ensemble") + temp_models = stats::setNames(model_values, clean_model_label(model_values)) } else { fixed_names = gsub("\\.", " ", names(rv_training_results$models)) + temp_models = temp_models[temp_models %in% fixed_names] } - temp_models = temp_models[temp_models %in% fixed_names] - temp_selected = temp_models + temp_selected = unname(temp_models) temp_labs = get_rv_labels("model_training_caret_test_metrics_trained_models_shap_ph") if (isTRUE(input$model_training_caret_more_options_shap_check=="Select models")) { empty_lab = "" @@ -524,18 +542,28 @@ model_training_caret_train_metrics_server = function() { } }) - observeEvent(input$model_training_caret_test_metrics_trained_shap_apply, { - req(!is.null(rv_training_results$post_model_metrics_objs)) - req(!is.null(rv_training_models$all_trained_models)) - req(!is.null(rv_training_results$test_metrics_objs)) - req(!is.null(rv_training_models$all_trained_models)) - req(!is.null(input$model_training_caret_test_metrics_trained_models_shap)) - req(!is.null(input$model_training_caret_test_metrics_trained_models_options)) - req(isTRUE(length(input$model_training_caret_test_metrics_trained_models_options)>0)) + if (!isolate(shap_apply_registered())) { + shap_apply_registered(TRUE) + observeEvent(input$model_training_caret_test_metrics_trained_shap_apply, { + req(!is.null(rv_training_results$post_model_metrics_objs)) + req(!is.null(rv_training_models$all_trained_models)) + req(!is.null(rv_training_results$test_metrics_objs)) + req(!is.null(input$model_training_caret_test_metrics_trained_models_shap)) + req(!is.null(input$model_training_caret_test_metrics_trained_models_options)) + req(isTRUE(length(input$model_training_caret_test_metrics_trained_models_options)>0)) + progress_started <- FALSE + close_metrics_progress <- function() { + if (isTRUE(progress_started)) { + progress_started <<- FALSE + close_progress_bar(att_new_obj=model_metrics_caret_pb) + } + } + on.exit(close_metrics_progress(), add = TRUE) if (((isTRUE(input$model_training_caret_test_metrics_trained_models_options!="") | isTRUE(length(input$model_training_caret_test_metrics_trained_models_options)>0)) & isTRUE(!is.null(input$model_training_caret_test_metrics_trained_models_options))) | isTRUE(input$model_training_caret_test_metrics_trained_shap_switch_check)) { if (isTRUE(input$model_training_caret_test_metrics_trained_models_options!="") | isTRUE(length(input$model_training_caret_test_metrics_trained_models_options)>0)) { - + start_progress_bar(id="model_metrics_caret_pb", att_new_obj=model_metrics_caret_pb, text=get_rv_labels("model_metrics_apply_progress_bar")) + progress_started <- TRUE rv_training_results$test_metrics_objs_filtered = tryCatch({ Rautoml::extract_more_metrics( @@ -720,11 +748,18 @@ model_training_caret_train_metrics_server = function() { } if (isTRUE(input$model_training_caret_test_metrics_trained_shap_switch_check)) { + shap_test_df <- rv_ml_ai$preprocessed$test_df + name_map <- rv_training_results$model_safe_name_map + if (!is.null(name_map) && is.data.frame(shap_test_df)) { + idx <- match(names(shap_test_df), name_map$original) + valid <- !is.na(idx) + names(shap_test_df)[valid] <- name_map$safe[idx[valid]] + } rv_training_results$test_metrics_objs_shap = tryCatch({ Rautoml::compute_shap( models=rv_training_results$models , model_names=gsub("\\ ", ".", input$model_training_caret_test_metrics_trained_models_shap) - , newdata=rv_ml_ai$preprocessed$test_df + , newdata=shap_test_df , response=rv_ml_ai$outcome , task=rv_ml_ai$task , nsim=50 @@ -734,22 +769,27 @@ model_training_caret_train_metrics_server = function() { ) }, error = function(e) { shinyalert::shinyalert("Error: ", paste0(get_rv_labels("test_metrics_objs_shap_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_metrics_caret_pb) + close_metrics_progress() return(NULL) }) - if (is.null(rv_training_results$test_metrics_objs_shap)) return() - - + if (is.null(rv_training_results$test_metrics_objs_shap)) { + close_metrics_progress() + return() + } + rv_training_results$shap_plots = tryCatch({ plot(rv_training_results$test_metrics_objs_shap) }, error=function(e){ shinyalert::shinyalert("Error: ", paste0(get_rv_labels("test_metrics_objs_shap_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_metrics_caret_pb) + close_metrics_progress() return(NULL) }) - - if (is.null(rv_training_results$shap_plots)) return() + + if (is.null(rv_training_results$shap_plots)) { + close_metrics_progress() + return() + } ## Save SHAP objects and plots save_shap = tryCatch({ @@ -947,7 +987,7 @@ model_training_caret_train_metrics_server = function() { ) - close_progress_bar(att_new_obj=model_metrics_caret_pb) + close_metrics_progress() } else { rv_training_results$test_metrics_objs_shap = NULL @@ -961,7 +1001,7 @@ model_training_caret_train_metrics_server = function() { output$model_training_caret_test_metrics_shap_values_varimp_ui = NULL output$model_training_caret_test_metrics_shap_values_varfreq_ui = NULL output$model_training_caret_test_metrics_shap_values_vardep_ui = NULL - close_progress_bar(att_new_obj=model_metrics_caret_pb) + close_metrics_progress() } } else { rv_training_results$test_metrics_objs_filtered = NULL @@ -980,12 +1020,13 @@ model_training_caret_train_metrics_server = function() { output$model_training_caret_test_metrics_shap_values_varimp_ui = NULL output$model_training_caret_test_metrics_shap_values_varfreq_ui = NULL output$model_training_caret_test_metrics_shap_values_vardep_ui = NULL - close_progress_bar(att_new_obj=model_metrics_caret_pb) + close_metrics_progress() } ## FIXME: Best way to reset SHAP values - rv_training_results$test_metrics_objs_shap = NULL - }) + rv_training_results$test_metrics_objs_shap = NULL + }, ignoreInit = TRUE) + } } else { output$model_training_caret_train_metrics_plot = NULL diff --git a/server/deploy_trained_caret_models.R b/server/deploy_trained_caret_models.R index da13b35..a1bf0ae 100644 --- a/server/deploy_trained_caret_models.R +++ b/server/deploy_trained_caret_models.R @@ -1,6 +1,8 @@ #### ---- Deploy trained model ------------------------------------- #### deploy_trained_caret_models = function() { + deploy_observers_registered <- reactiveVal(FALSE) + observeEvent({list(input$manage_data_apply, input$model_training_apply)}, { req(!is.null(rv_current$working_df)) req(!is.null(rv_current$dataset_id)) @@ -39,6 +41,11 @@ deploy_trained_caret_models = function() { ) }) + ## Register nested observers only once — prevents duplicate deploys + ## when manage_data_apply or model_training_apply fires multiple times. + if (!isolate(deploy_observers_registered())) { + deploy_observers_registered(TRUE) + ## Models in summary table observeEvent(input$deploy_trained_caret_models_select_session, { output$deploy_trained_caret_models_select_model = renderUI({ @@ -158,26 +165,20 @@ deploy_trained_caret_models = function() { if (isTRUE(d_check)) { u = rv_deployed_models[[m]]$url d = rv_deployed_models[[m]]$docs - if (Rautoml::check_api_connection(d)) { - df$url = u - df$api = d - df$status = "Deployed" - } else { + connected <- FALSE + for (.attempt in 1:5) { + if (Rautoml::check_api_connection(d)) { connected <- TRUE; break } Sys.sleep(3) - if (Rautoml::check_api_connection(d)) { - df$url = u - df$api = d - df$status = "Deployed" - } else { - df$url = "" - df$api = "" - df$status = "Stopped" - } + } + if (connected) { + df$url = u; df$api = d; df$status = "Deployed" + } else { + df$url = ""; df$api = ""; df$status = "Stopped" } } else { - df$url = "" - df$api = "" - df$status = "Stopped" + df$url = "" + df$api = "" + df$status = "Stopped" } deployed_df[[m]] = df } @@ -234,21 +235,15 @@ deploy_trained_caret_models = function() { if (isTRUE(d_check)) { u = rv_deployed_models[[info$id]]$url d = rv_deployed_models[[info$id]]$docs - if (Rautoml::check_api_connection(d)) { - display$url[i] = u - display$api[i] = d - display$status[i] = "Deployed" - } else { + connected <- FALSE + for (.attempt in 1:5) { + if (Rautoml::check_api_connection(d)) { connected <- TRUE; break } Sys.sleep(3) - if (Rautoml::check_api_connection(d)) { - display$url[i] = u - display$api[i] = d - display$status[i] = "Deployed" - } else { - display$url[i] = "" - display$api[i] = "" - display$status[i] = "Stopped" - } + } + if (connected) { + display$url[i] = u; display$api[i] = d; display$status[i] = "Deployed" + } else { + display$url[i] = ""; display$api[i] = ""; display$status[i] = "Stopped" } } else { display$url[i] = "" @@ -278,6 +273,8 @@ deploy_trained_caret_models = function() { }, server = FALSE) }, ignoreInit = TRUE) + } ## end deploy_observers_registered guard + ## Output objects output$deploy_trained_caret_models_box_ui = renderUI({ req(NROW(rv_deploy_models$trained_models_table)>0) diff --git a/server/feature_engineering.R b/server/feature_engineering.R index cd7cef3..f4c41df 100644 --- a/server/feature_engineering.R +++ b/server/feature_engineering.R @@ -25,35 +25,35 @@ feature_engineering_perform_preprocess_server = function() { observe({ if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(length(input$modelling_framework_choices)>0)) { - + ## Data partitioning output$feature_engineering_perform_partition = renderUI({ - + selectInput("feature_engineering_perform_partition" - , label = get_rv_labels("feature_engineering_perform_partition") + , label = get_rv_labels("feature_engineering_perform_partition") , choices = get_named_choices(input_choices_file, input$change_language,"feature_engineering_perform_partition_choices") , selected = "single" , multiple=FALSE ) }) - - ## Longitudinal data partitioning + + ## Longitudinal data partitioning output$feature_engineering_perform_partition_group = renderUI({ - req(input$feature_engineering_perform_partition=="group") + req(input$feature_engineering_perform_partition=="group") selectInput("feature_engineering_perform_partition_group" - , label = get_rv_labels("feature_engineering_perform_partition_group") + , label = get_rv_labels("feature_engineering_perform_partition_group") , choices = rv_ml_ai$predictors , selected = NULL , multiple=TRUE ) }) - ## Stratify by outcome + ## Stratify by outcome output$feature_engineering_perform_partition_group_strata = renderUI({ - req(input$feature_engineering_perform_partition_group!="") + req(input$feature_engineering_perform_partition_group!="") materialSwitch( inputId = "feature_engineering_perform_partition_group_strata_check", - label = get_rv_labels("feature_engineering_perform_partition_group_strata_check"), + label = get_rv_labels("feature_engineering_perform_partition_group_strata_check"), status = "success", right = TRUE, value = FALSE @@ -66,7 +66,7 @@ feature_engineering_perform_preprocess_server = function() { HTML("", get_rv_labels("feature_engineering_perform_preprocess"), ": ") , materialSwitch( inputId = "feature_engineering_perform_preprocess_check", - label = get_rv_labels("feature_engineering_perform_preprocess_check"), + label = get_rv_labels("feature_engineering_perform_preprocess_check"), status = "success", right = TRUE, value = TRUE @@ -76,17 +76,17 @@ feature_engineering_perform_preprocess_server = function() { } else { output$feature_engineering_perform_preprocess = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_preprocess_check" , value=FALSE) - + output$feature_engineering_perform_partition = NULL updateSelectInput(session, "feature_engineering_perform_partition", selected="") } } else { output$feature_engineering_perform_preprocess = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_preprocess_check" , value=FALSE) - + output$feature_engineering_perform_partition = NULL updateSelectInput(session, "feature_engineering_perform_partition", selected="") - + output$feature_engineering_perform_partition_group = NULL updateSelectInput(session, "feature_engineering_perform_partition_group", selected="") } @@ -98,19 +98,19 @@ feature_engineering_perform_preprocess_server = function() { ##### ---- Impute missing values ------------------------ #### feature_engineering_impute_missing_server = function() { - + observe({ if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(length(input$modelling_framework_choices)>0)) { if (isTRUE(input$feature_engineering_perform_preprocess_check)) { - + ## Missing values input rv_current$missing_prop_impute = missing_prop(rv_current$working_df)#, return_exact=TRUE) if (isTRUE(NROW(rv_current$missing_prop_impute)>0)) { output$feature_engineering_perform_missing_impute = renderUI({ materialSwitch( inputId = "feature_engineering_perform_missing_impute_check", - label = get_rv_labels("feature_engineering_perform_missing_impute_check"), + label = get_rv_labels("feature_engineering_perform_missing_impute_check"), status = "success", right = TRUE, value = TRUE @@ -121,23 +121,23 @@ feature_engineering_impute_missing_server = function() { updateMaterialSwitch(session , inputId="feature_engineering_perform_missing_impute_check" , value=FALSE) } - + ## Feature engineering steps output$feature_engineering_perform_fe_steps = renderUI({ materialSwitch( inputId = "feature_engineering_perform_fe_steps_check", - label = get_rv_labels("feature_engineering_perform_fe_steps_check"), + label = get_rv_labels("feature_engineering_perform_fe_steps_check"), status = "success", right = TRUE, value = TRUE ) }) - + ## Correlated predictors output$feature_engineering_perform_corr_steps = renderUI({ materialSwitch( inputId = "feature_engineering_perform_corr_steps_check", - label = get_rv_labels("feature_engineering_perform_corr_steps_check"), + label = get_rv_labels("feature_engineering_perform_corr_steps_check"), status = "success", right = TRUE, value = TRUE @@ -148,7 +148,7 @@ feature_engineering_impute_missing_server = function() { output$feature_engineering_perform_pca_steps = renderUI({ materialSwitch( inputId = "feature_engineering_perform_pca_steps_check", - label = get_rv_labels("feature_engineering_perform_pca_steps_check"), + label = get_rv_labels("feature_engineering_perform_pca_steps_check"), status = "success", right = TRUE, value = FALSE @@ -160,7 +160,7 @@ feature_engineering_impute_missing_server = function() { output$feature_engineering_perform_upsample_steps = renderUI({ materialSwitch( inputId = "feature_engineering_perform_upsample_steps_check", - label = get_rv_labels("feature_engineering_perform_upsample_steps_check"), + label = get_rv_labels("feature_engineering_perform_upsample_steps_check"), status = "success", right = TRUE, value = TRUE @@ -170,20 +170,20 @@ feature_engineering_impute_missing_server = function() { output$feature_engineering_perform_upsample_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_upsample_steps_check" , value=FALSE) } - + } else { output$feature_engineering_perform_missing_impute = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_missing_impute_check" , value=FALSE) - + output$feature_engineering_perform_fe_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_fe_steps_check" , value=FALSE) - + output$feature_engineering_perform_corr_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_corr_steps_check" , value=FALSE) - + output$feature_engineering_perform_pca_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_pca_steps_check" , value=FALSE) - + output$feature_engineering_perform_upsample_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_upsample_steps_check" , value=FALSE) } @@ -194,31 +194,31 @@ feature_engineering_impute_missing_server = function() { updateMaterialSwitch(session , inputId="feature_engineering_perform_fe_steps_check" , value=FALSE) output$feature_engineering_perform_corr_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_corr_steps_check" , value=FALSE) - + output$feature_engineering_perform_pca_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_pca_steps_check" , value=FALSE) - + output$feature_engineering_perform_upsample_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_upsample_steps_check" , value=FALSE) } } else { output$feature_engineering_perform_missing_impute = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_missing_impute_check" , value=FALSE) - + output$feature_engineering_perform_fe_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_fe_steps_check" , value=FALSE) - + output$feature_engineering_perform_corr_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_corr_steps_check" , value=FALSE) - + output$feature_engineering_perform_pca_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_pca_steps_check" , value=FALSE) - + output$feature_engineering_perform_upsample_steps = NULL updateMaterialSwitch(session , inputId="feature_engineering_perform_upsample_steps_check" , value=FALSE) } }) - + observe({ if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(length(input$modelling_framework_choices)>0)) { @@ -227,7 +227,7 @@ feature_engineering_impute_missing_server = function() { empty_lab = "" names(empty_lab) = get_rv_labels("impute_missing_options_ph") selectInput("feature_engineering_impute_missing_impute" - , label = NULL#get_rv_labels("impute_missing_options") + , label = NULL#get_rv_labels("impute_missing_options") , choices = c(empty_lab, get_named_choices(input_choices_file, input$change_language,"impute_missing_options_choices")) , selected = "omit" , multiple=FALSE @@ -236,7 +236,7 @@ feature_engineering_impute_missing_server = function() { } else { output$feature_engineering_impute_missing_impute = NULL updateSelectInput(session, "feature_engineering_impute_missing_impute", selected="") - + } if (isTRUE(input$feature_engineering_perform_upsample_steps_check) & isTRUE(input$feature_engineering_perform_preprocess_check)) { @@ -272,20 +272,20 @@ feature_engineering_impute_missing_server = function() { } else { output$feature_engineering_impute_missing_impute = NULL updateSelectInput(session, "feature_engineering_impute_missing_impute", selected="") - + output$feature_engineering_perform_upsample_steps_choices = NULL updateSelectInput(session, "feature_engineering_perform_upsample_steps_choices", selected="") - + output$feature_engineering_perform_corr_steps_value = NULL updateSliderInput(session, "feature_engineering_perform_corr_steps_value", value = NULL) } } else { output$feature_engineering_impute_missing_imputes = NULL updateSelectInput(session, "feature_engineering_impute_missing_impute", selected="") - + output$feature_engineering_perform_upsample_steps_choices = NULL updateSelectInput(session, "feature_engineering_perform_upsample_steps_choices", selected="") - + output$feature_engineering_perform_corr_steps_value = NULL updateSliderInput(session, "feature_engineering_perform_corr_steps_value", value = NULL) } @@ -304,10 +304,10 @@ feature_engineering_impute_missing_server = function() { , label = get_rv_labels("feature_engineering_apply")) }) } else { - output$feature_engineering_apply = NULL + output$feature_engineering_apply = NULL } } else { - output$feature_engineering_apply = NULL + output$feature_engineering_apply = NULL } }) @@ -329,7 +329,7 @@ feature_engineering_impute_missing_server = function() { strata = NULL } } else { - group = NULL + group = NULL } partition_objs = tryCatch({ @@ -345,18 +345,18 @@ feature_engineering_impute_missing_server = function() { return(NULL) }) - + # rv_ml_ai$predictors = setdiff(colnames(rv_current$working_df), input$feature_engineering_perform_partition_group) if (is.null(partition_objs)) return() - - + + rv_ml_ai$split = partition_objs$split rv_ml_ai$train_df = partition_objs$train_df rv_ml_ai$test_df = partition_objs$test_df rv_ml_ai$fold_index = partition_objs$index - + start_progress_bar(id="feature_engineering_perform_preprocess_pb", att_new_obj=feature_engineering_perform_preprocess_pb, text=get_rv_labels("feature_engineering_perform_preprocess_pb")) - + if (isTRUE(input$feature_engineering_perform_preprocess_check)) { rv_ml_ai$preprocessed = tryCatch({ Rautoml::preprocess( @@ -378,7 +378,7 @@ feature_engineering_impute_missing_server = function() { close_progress_bar(att_new_obj=feature_engineering_perform_preprocess_pb) return(NULL) }) - + if (is.null(rv_ml_ai$preprocessed)) return() } else { @@ -387,10 +387,10 @@ feature_engineering_impute_missing_server = function() { df = rv_ml_ai$train_df , model_form = rv_ml_ai$model_formula , outcome_var = rv_ml_ai$outcome - , corr = 0 - , impute = FALSE - , perform_fe = FALSE - , perform_pca = FALSE + , corr = 0 + , impute = FALSE + , perform_fe = FALSE + , perform_pca = FALSE , up_sample = FALSE , task = rv_ml_ai$task , df_test = rv_ml_ai$test_df @@ -400,19 +400,19 @@ feature_engineering_impute_missing_server = function() { close_progress_bar(att_new_obj=feature_engineering_perform_preprocess_pb) return(NULL) }) - + if (is.null(rv_ml_ai$preprocessed)) return() - } - + } + shinyalert::shinyalert("Done!", get_rv_labels("feature_engineering_apply_success"), type = "success") - + close_progress_bar(att_new_obj=feature_engineering_perform_preprocess_pb) - + rv_ml_ai$feature_engineering_preprocessed_log = rv_ml_ai$preprocessed$preprocess_steps output$feature_engineering_preprocessed_log_ui = renderUI({ p( - + HTML(paste0("", get_rv_labels("feature_engineering_preprocessed_log"), "")) ) }) diff --git a/server/location_modal.R b/server/location_modal.R index e2fb5b4..9a0ff7d 100644 --- a/server/location_modal.R +++ b/server/location_modal.R @@ -32,7 +32,13 @@ location_modal_server <- function(USER) { params = list(USER$username)) DBI::dbDisconnect(con) country_set <- nrow(row) > 0 && !is.na(row$country[1]) && nzchar(trimws(row$country[1])) - if (!country_set) showModal(country_modal_ui()) + if (!country_set) { + modal_ui <- country_modal_ui() + session$onFlushed(function() { + waiter::waiter_hide() + showModal(modal_ui) + }, once = TRUE) + } }) # Save country on submit @@ -40,12 +46,24 @@ location_modal_server <- function(USER) { req(isTRUE(USER$logged_in)) chosen <- input$user_country if (is.null(chosen) || !nzchar(chosen) || chosen == "--- Select ---") return() - con <- DBI::dbConnect(RSQLite::SQLite(), 'users_db/users.sqlite') - DBI::dbExecute(con, - "UPDATE users SET country = ? WHERE username = ?", - params = list(chosen, USER$username)) - DBI::dbDisconnect(con) - removeModal() + tryCatch({ + con <- DBI::dbConnect(RSQLite::SQLite(), 'users_db/users.sqlite') + on.exit(DBI::dbDisconnect(con), add = TRUE) + rows <- DBI::dbExecute(con, + "UPDATE users SET country = ? WHERE username = ?", + params = list(chosen, USER$username)) + message(sprintf("Country saved for user '%s': %s (%s row(s) updated)", USER$username, chosen, rows)) + removeModal() + ## Reveal the dashboard using the same content-ready logic as login + ## (no hardcoded delay), plus modal-specific cleanup. + hide_waiter_after_paint(" + $('.modal-backdrop').remove(); + $('body').removeClass('modal-open').css('padding-right', ''); + ") + }, error = function(e) { + message(sprintf("Country save failed for user '%s': %s", USER$username, conditionMessage(e))) + shinyalert::shinyalert("Error", paste0(get_rv_labels("general_error_alert"), "\n", conditionMessage(e)), type = "error") + }) }) # Log page visits using the sidebar tab input (server-side, no JS needed) diff --git a/server/model_training_caret_models.R b/server/model_training_caret_models.R index 64fabb8..ab703c5 100644 --- a/server/model_training_caret_models.R +++ b/server/model_training_caret_models.R @@ -720,7 +720,7 @@ model_training_caret_models_ridge_server = function() { , selectInput("model_training_caret_models_ridge_advance_alpha" , get_rv_labels("model_training_caret_models_ridge_advance_alpha") , choices = 0 # seq(0.1, 1, length.out=10) - , selected = 1 + , selected = 0 , multiple = FALSE ) , actionButton("ridge_advance_control_apply_save" @@ -1214,4 +1214,3 @@ model_training_caret_models_naive_bayes_server = function() { } - diff --git a/server/model_training_setup.R b/server/model_training_setup.R index 4a0cbbc..e4d1bd8 100644 --- a/server/model_training_setup.R +++ b/server/model_training_setup.R @@ -3,6 +3,9 @@ model_training_setup_server = function() { + output$model_training_setup_presetup <- renderUI({ NULL }) + outputOptions(output, "model_training_setup_presetup", suspendWhenHidden = FALSE) + observeEvent(input$feature_engineering_apply, { if (isTRUE(!is.null(rv_current$working_df))) { diff --git a/server/research_questions.R b/server/research_questions.R index 7f44714..e2b4f50 100644 --- a/server/research_questions.R +++ b/server/research_questions.R @@ -1,7 +1,7 @@ ##### ---- Generate research question ------------------ #### generate_research_questions_choices = function() { - + observeEvent(input$manage_data_apply, { if (isTRUE(!is.null(rv_current$working_df))) { output$generate_research_questions_outcome = renderUI({ @@ -14,7 +14,7 @@ generate_research_questions_choices = function() { }) } }) - + observe({ if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(length(input$generate_research_questions_outcome)>0)) { @@ -87,13 +87,13 @@ generate_research_questions_api_token = function() { , HTML(paste0("", get_rv_labels("generate_research_questions_api_token"), "")) , helpText(paste0(get_rv_labels("generate_research_questions_api_token_ht")), " ", a(get_rv_labels("generate_research_questions_api_token_ht_h"), href="https://aistudio.google.com/app/apikey", target="_blank")) , maskedPasswordInput("generate_research_questions_api_token" - , label = NULL + , label = NULL , value = "" , width = "100%" , placeholder = get_rv_labels("generate_research_questions_api_token_ph") ) ) - }) + }) output$generate_research_questions_api_token_apply = renderUI({ actionBttn("generate_research_questions_api_token_apply" , inline=TRUE @@ -113,7 +113,7 @@ generate_research_questions_api_token = function() { ##### ---- Store API Token ------------------ #### generate_research_questions_api_store = function() { - + ## Store observeEvent(input$generate_research_questions_api_token_apply, { if (!isTRUE(Rautoml::check_api("GEMINE_API_KEY"))) { @@ -127,18 +127,18 @@ generate_research_questions_api_store = function() { } } }) - + ## Reset observeEvent(input$generate_research_questions_reset_api, { if (isTRUE(isTRUE(input$generate_research_questions_choices=="yes"))) { if (isTRUE(Rautoml::check_api("GEMINE_API_KEY")) | isTRUE(rv_current$api_stored_success)) { - Rautoml::unset_api("GEMINE_API_KEY") + Rautoml::unset_api("GEMINE_API_KEY") shinyalert::shinyalert("", get_rv_labels("api_reset_success"), type = "success", inputId="api_reset_success") rv_current$api_stored_success = FALSE output$generate_research_questions_apply = NULL output$generate_research_questions_models = NULL updateRadioButtons(session, "generate_research_questions_choices", selected=character(0)) - + output$generate_research_questions_additional = NULL output$generate_research_questions_additional_analysis_ui = NULL # updateMaterialSwitch(session, inputId="generate_research_questions_additional_analysis", value = FALSE) @@ -153,25 +153,25 @@ generate_research_questions_additional = function() { observe({ if (isTRUE(isTRUE(input$generate_research_questions_choices=="yes"))) { if (isTRUE(Rautoml::check_api("GEMINE_API_KEY")) | isTRUE(rv_current$api_stored_success)) { - + output$generate_research_questions_models = renderUI({ p( hr() , HTML(paste0("", get_rv_labels("generate_research_questions_models"), "")) , helpText(get_rv_labels("generate_research_questions_models_ht1"), " ", a(get_rv_labels("generate_research_questions_models_ht2"), href="https://ai.google.dev/gemini-api/docs/models/gemini", target="_blank")) , textInput("generate_research_questions_models" - , label = NULL + , label = NULL , value = "" , width = "100%" , placeholder = "e.g., 3.5-flash" ) ) - }) + }) output$generate_research_questions_apply = renderUI({ div( - style = "display: flex; gap: 10px; align-items: center;" + style = "display: flex; gap: 10px; align-items: center;" , actionBttn("generate_research_questions_apply" , inline=TRUE , block = FALSE @@ -189,14 +189,14 @@ generate_research_questions_additional = function() { } else { output$generate_research_questions_apply = NULL output$generate_research_questions_models = NULL - + } } else { output$generate_research_questions_apply = NULL output$generate_research_questions_models = NULL } }) - + observeEvent(input$generate_research_questions_apply, { if (isTRUE(isTRUE(input$generate_research_questions_choices=="yes"))) { if (isTRUE(Rautoml::check_api("GEMINE_API_KEY"))) { @@ -207,11 +207,11 @@ generate_research_questions_additional = function() { , HTML("", get_rv_labels("generate_research_questions_additional"), ": ") ) }) - + output$generate_research_questions_additional_analysis_ui = renderUI({ materialSwitch( inputId = "generate_research_questions_additional_analysis", - label = get_rv_labels("generate_research_questions_additional_analysis"), + label = get_rv_labels("generate_research_questions_additional_analysis"), status = "success", right = TRUE ) @@ -229,8 +229,8 @@ generate_research_questions_additional = function() { } }) - - + + } @@ -276,7 +276,7 @@ generate_research_questions_gemini = function() { ) ) }) - + close_progress_bar(att_new_obj=generate_research_questions_outcome_pb) rv_generative_ai$history = research_question_chat$history output$generate_research_questions_gemini = renderUI({ @@ -296,7 +296,7 @@ generate_research_questions_gemini = function() { if (isTRUE(isTRUE(input$generate_research_questions_choices=="yes"))) { if (isTRUE(Rautoml::check_api("GEMINE_API_KEY"))) { if (isTRUE(input$generate_research_questions_additional_analysis)) { - + start_progress_bar(id="generate_research_questions_additional_analysis_pb", att_new_obj=generate_research_questions_additional_analysis_pb, text=get_rv_labels("generate_research_questions_additional_analysis_pb")) # showPageSpinner() analysis_prompt = get_prompts("generate_research_questions_additional_analysis") @@ -315,7 +315,7 @@ generate_research_questions_gemini = function() { ) ) }) - + close_progress_bar(att_new_obj=generate_research_questions_additional_analysis_pb) output$generate_research_question_gemini_suggest_analysis = renderUI({ p(br() @@ -327,7 +327,7 @@ generate_research_questions_gemini = function() { # hidePageSpinner() } - + } } }) diff --git a/server/setup_models.R b/server/setup_models.R index ab03b2b..7abc758 100644 --- a/server/setup_models.R +++ b/server/setup_models.R @@ -1,20 +1,27 @@ #### ---- AI/ML UIs ---------------------------- #### setup_models_ui = function() { - - ## Session name - observeEvent(input$manage_data_apply, { + + ## Session name — watch working_df directly so there is no timing race + ## between manage_data_apply firing and working_df being set by select_data. + ## Only re-render when the input is empty — preserves value if already filled, + ## preventing setup_models_analysis_apply's drop_variables() from wiping it. + observe({ if (isTRUE(!is.null(rv_current$working_df))) { - output$setup_models_analysis_session_name = renderUI({ - textInput("setup_models_analysis_session_name" - , label = get_rv_labels("setup_models_analysis_session_name") - , value = "" - , width = NULL - , placeholder = get_rv_labels("setup_models_analysis_session_name_ph") - ) - }) + existing <- isolate(input$setup_models_analysis_session_name) + if (is.null(existing) || !nzchar(existing)) { + output$setup_models_analysis_session_name = renderUI({ + textInput("setup_models_analysis_session_name" + , label = get_rv_labels("setup_models_analysis_session_name") + , value = "" + , width = NULL + , placeholder = get_rv_labels("setup_models_analysis_session_name_ph") + ) + }) + outputOptions(output, "setup_models_analysis_session_name", suspendWhenHidden = FALSE) + } } else { output$setup_models_analysis_session_name = NULL - updateTextInput(session , "setup_models_analysis_session_name", value="") + updateTextInput(session, "setup_models_analysis_session_name", value="") } }) diff --git a/server/train_caret_models.R b/server/train_caret_models.R index 4bf29f4..b6d81e4 100644 --- a/server/train_caret_models.R +++ b/server/train_caret_models.R @@ -1,23 +1,69 @@ +source("server/caret_job_manager.R", local = TRUE) + #### ---- Train all models ----------------------------------- #### model_training_caret_train_all_server = function() { - + ## Check hyperparameter list - + param_values <- function(value) { + if (is.null(value)) return(NULL) + if (is.factor(value)) value <- as.character(value) + if (is.atomic(value)) { + value <- value[!is.na(value)] + if (is.character(value)) value <- value[nzchar(value)] + if (is.character(value) && length(value)) { + numeric_value <- suppressWarnings(as.numeric(value)) + if (!anyNA(numeric_value)) value <- numeric_value + } + } + value + } + + merge_param_set <- function(param_set = NULL, defaults = NULL) { + param_names <- unique(c(names(defaults), names(param_set))) + if (!length(param_names)) return(NULL) + stats::setNames(lapply(param_names, function(param_name) { + value <- param_values(param_set[[param_name]]) + if (length(value)) return(value) + param_values(defaults[[param_name]]) + }), param_names) + } + + param_set_ready <- function(param_set) { + !is.null(param_set) && + length(param_set) > 0 && + all(vapply(param_set, function(value) length(param_values(value)) > 0, logical(1))) + } + + setup_caret_safe <- function(model, param = FALSE, param_set = NULL, defaults = NULL) { + if (!isTRUE(param)) { + return(Rautoml::setup_caret(model, param = FALSE, param_set = NULL)) + } + param_set <- merge_param_set(param_set, defaults) + if (!param_set_ready(param_set)) { + return(Rautoml::setup_caret(model, param = FALSE, param_set = NULL)) + } + Rautoml::setup_caret(model, param = TRUE, param_set = param_set) + } + + glmnet_lambda_grid <- function() { + c(seq(0.001, 0.1, length.out = 10), seq(0.1, 2, by = 0.1), seq(2, 5, 0.5), seq(5, 25, 1)) + } + ### LM/GLM observeEvent(input$ols_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_ols_check)) { if (rv_ml_ai$task=="Regression") { - rv_training_models$ols_param = TRUE + rv_training_models$ols_param = TRUE } else { rv_training_models$ols_param = FALSE } } } } - + }) ### RF @@ -25,64 +71,64 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_rf_check)) { - rv_training_models$rf_param = TRUE + rv_training_models$rf_param = TRUE } } } - + }) - + ### GBM observeEvent(input$gbm_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_gbm_check)) { - rv_training_models$gbm_param = TRUE + rv_training_models$gbm_param = TRUE } } } }) - + ### xgbTree observeEvent(input$xgbTree_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_xgbTree_check)) { - rv_training_models$xgbTree_param = TRUE + rv_training_models$xgbTree_param = TRUE } } } }) - + ### xgbLinear observeEvent(input$xgbLinear_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_xgbLinear_check)) { - rv_training_models$xgbLinear_param = TRUE + rv_training_models$xgbLinear_param = TRUE } } } }) - + ### svmRadial observeEvent(input$svmRadial_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_svmRadial_check)) { - rv_training_models$svmRadial_param = TRUE + rv_training_models$svmRadial_param = TRUE } } } }) - + ### svmLinear observeEvent(input$svmLinear_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_svmLinear_check)) { - rv_training_models$svmLinear_param = TRUE + rv_training_models$svmLinear_param = TRUE } } } @@ -94,7 +140,7 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_svmPoly_check)) { - rv_training_models$svmPoly_param = TRUE + rv_training_models$svmPoly_param = TRUE } } } @@ -106,19 +152,19 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_glmnet_check)) { - rv_training_models$glmnet_param = TRUE + rv_training_models$glmnet_param = TRUE } } } }) - + ### lasso observeEvent(input$lasso_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_lasso_check)) { - rv_training_models$lasso_param = TRUE + rv_training_models$lasso_param = TRUE } } } @@ -130,7 +176,7 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_ridge_check)) { - rv_training_models$ridge_param = TRUE + rv_training_models$ridge_param = TRUE } } } @@ -142,7 +188,7 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_knn_check)) { - rv_training_models$knn_param = TRUE + rv_training_models$knn_param = TRUE } } } @@ -154,7 +200,7 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_nnet_check)) { - rv_training_models$nnet_param = TRUE + rv_training_models$nnet_param = TRUE } } } @@ -165,7 +211,7 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_avNNet_check)) { - rv_training_models$avNNet_param = TRUE + rv_training_models$avNNet_param = TRUE } } } @@ -176,19 +222,19 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_pls_check)) { - rv_training_models$pls_param = TRUE + rv_training_models$pls_param = TRUE } } } }) - + ### rpart observeEvent(input$rpart_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_rpart_check)) { - rv_training_models$rpart_param = TRUE + rv_training_models$rpart_param = TRUE } } } @@ -199,92 +245,125 @@ model_training_caret_train_all_server = function() { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_mlpWeightDecayML_check)) { - rv_training_models$mlpWeightDecayML_param = TRUE + rv_training_models$mlpWeightDecayML_param = TRUE } } } }) - + ### naive_bayes observeEvent(input$naive_bayes_advance_control_apply_save, { if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { if (isTRUE(input$model_training_caret_models_naive_bayes_check)) { - rv_training_models$naive_bayes_param = TRUE + rv_training_models$naive_bayes_param = TRUE } } } }) - ## Check selected models - observe({ - if (isTRUE(!is.null(rv_current$working_df))) { - if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { - + ## Build model specs — fires on preprocessing complete OR any advance option save. + ## Does NOT depend on checkbox inputs so checkbox ticks are instant (fast observer). + observeEvent( + list( + rv_ml_ai$preprocessed, + ## Re-run once the model names become available (they are set as a + ## side-effect of the checkbox UIs rendering, slightly after + ## `preprocessed`). Without these, the observer can fire before + ## `ols_name` is set, hit the req() gate below, abort, and never + ## rebuild -> specs stay NULL -> clicking Train creates no jobs and + ## no progress panel. Names are only READ here, never written, so + ## there is no self-trigger loop. + rv_training_models$ols_name, + rv_training_models$rf_name, + rv_training_models$gbm_name, + rv_training_models$xgbTree_name, + rv_training_models$xgbLinear_name, + rv_training_models$svmRadial_name, + rv_training_models$svmLinear_name, + rv_training_models$svmPoly_name, + rv_training_models$glmnet_name, + rv_training_models$lasso_name, + rv_training_models$ridge_name, + rv_training_models$knn_name, + rv_training_models$nnet_name, + rv_training_models$avNNet_name, + rv_training_models$pls_name, + rv_training_models$gam_name, + rv_training_models$rpart_name, + rv_training_models$treebag_name, + rv_training_models$mlpWeightDecayML_name, + rv_training_models$naive_bayes_name, + input$ols_advance_control_apply_save, + input$rf_advance_control_apply_save, + input$gbm_advance_control_apply_save, + input$xgbTree_advance_control_apply_save, + input$xgbLinear_advance_control_apply_save, + input$svmRadial_advance_control_apply_save, + input$svmLinear_advance_control_apply_save, + input$svmPoly_advance_control_apply_save, + input$glmnet_advance_control_apply_save, + input$lasso_advance_control_apply_save, + input$ridge_advance_control_apply_save, + input$knn_advance_control_apply_save, + input$nnet_advance_control_apply_save, + input$avNNet_advance_control_apply_save, + input$pls_advance_control_apply_save, + input$rpart_advance_control_apply_save, + input$mlpWeightDecayML_advance_control_apply_save, + input$naive_bayes_advance_control_apply_save + ), + { + req(!is.null(rv_current$working_df)) + req(!is.null(rv_ml_ai$preprocessed)) + req(!is.null(rv_training_models$ols_name)) + { + ## LM/GLM - if (isTRUE(input$model_training_caret_models_ols_check)) { + if (!is.null(rv_training_models$ols_name)) { if (isTRUE(rv_ml_ai$preprocessed$outcome_nlevels>2)) { param_set = list(intercept=as.numeric(input$model_training_caret_models_ols_advance_decay)) } else { param_set=list(intercept=input$model_training_caret_models_ols_advance_intercept) } - rv_training_models$ols_model = Rautoml::setup_caret( + rv_training_models$ols_model = setup_caret_safe( rv_training_models$ols_name , param=rv_training_models$ols_param , param_set=param_set ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$ols_model = NULL } - + ## RF - if (isTRUE(input$model_training_caret_models_rf_check)) { - rv_training_models$rf_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$rf_name)) { + rv_training_models$rf_model = setup_caret_safe( rv_training_models$rf_name , param=rv_training_models$rf_param - , param_set=list( - mtry=as.numeric(input$model_training_caret_models_rf_advance_params_mtry) - ) + , param_set=list(mtry=as.numeric(input$model_training_caret_models_rf_advance_params_mtry)) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$rf_model = NULL } ## GBM - if (isTRUE(input$model_training_caret_models_gbm_check)) { - if (isTRUE(!is.null(input$model_training_caret_models_gbm_advance_shrinkage))) { - shrinkage = input$model_training_caret_models_gbm_advance_shrinkage - shrinkage = seq(shrinkage[1], shrinkage[2], length.out=20) - } else { - shrinkage = input$model_training_caret_models_gbm_advance_shrinkage - } - rv_training_models$gbm_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$gbm_name)) { + shrinkage = input$model_training_caret_models_gbm_advance_shrinkage + if (!is.null(shrinkage)) shrinkage = seq(shrinkage[1], shrinkage[2], length.out=20) + rv_training_models$gbm_model = setup_caret_safe( rv_training_models$gbm_name , param=rv_training_models$gbm_param , param_set=list( n.trees=as.numeric(input$model_training_caret_models_gbm_advance_n.trees) - , interaction.depth = as.numeric(input$model_training_caret_models_gbm_advance_interaction.depth) - , n.minobsinnode = as.numeric(input$model_training_caret_models_gbm_advance_n.minobsinnode) - , shrinkage = shrinkage + , interaction.depth=as.numeric(input$model_training_caret_models_gbm_advance_interaction.depth) + , n.minobsinnode=as.numeric(input$model_training_caret_models_gbm_advance_n.minobsinnode) + , shrinkage=shrinkage ) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$gbm_model = NULL } ## xgbTree - if (isTRUE(input$model_training_caret_models_xgbTree_check)) { - if (isTRUE(!is.null(input$model_training_caret_models_xgbTree_advance_eta))) { - eta = input$model_training_caret_models_xgbTree_advance_eta - eta = seq(eta[1], eta[2], length.out=20) - } else { - eta = input$model_training_caret_models_xgbTree_advance_eta - } - rv_training_models$xgbTree_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$xgbTree_name)) { + eta = input$model_training_caret_models_xgbTree_advance_eta + if (!is.null(eta)) eta = seq(eta[1], eta[2], length.out=20) + rv_training_models$xgbTree_model = setup_caret_safe( rv_training_models$xgbTree_name , param=rv_training_models$xgbTree_param , param_set=list( @@ -297,21 +376,13 @@ model_training_caret_train_all_server = function() { , subsample=as.numeric(input$model_training_caret_models_xgbTree_advance_subsample) ) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$xgbTree_model = NULL } - ## xgbLinear - if (isTRUE(input$model_training_caret_models_xgbLinear_check)) { - if (isTRUE(!is.null(input$model_training_caret_models_xgbLinear_advance_eta))) { - eta = input$model_training_caret_models_xgbLinear_advance_eta - eta = seq(eta[1], eta[2], length.out=20) - } else { - eta = input$model_training_caret_models_xgbLinear_advance_eta - } - rv_training_models$xgbLinear_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$xgbLinear_name)) { + eta = input$model_training_caret_models_xgbLinear_advance_eta + if (!is.null(eta)) eta = seq(eta[1], eta[2], length.out=20) + rv_training_models$xgbLinear_model = setup_caret_safe( rv_training_models$xgbLinear_name , param=rv_training_models$xgbLinear_param , param_set=list( @@ -321,138 +392,96 @@ model_training_caret_train_all_server = function() { , eta=eta ) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$xgbLinear_model = NULL } ## svmRadial - if (isTRUE(input$model_training_caret_models_svmRadial_check)) { - if (isTRUE(!is.null(input$model_training_caret_models_svmRadial_advance_sigma))) { - sigma = input$model_training_caret_models_svmRadial_advance_sigma - sigma = seq(sigma[1], sigma[2], length.out=20) - } else { - sigma = input$model_training_caret_models_svmRadial_advance_sigma - } - rv_training_models$svmRadial_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$svmRadial_name)) { + sigma = input$model_training_caret_models_svmRadial_advance_sigma + if (!is.null(sigma)) sigma = seq(sigma[1], sigma[2], length.out=20) + rv_training_models$svmRadial_model = setup_caret_safe( rv_training_models$svmRadial_name , param=rv_training_models$svmRadial_param - , param_set=list( - C=as.numeric(input$model_training_caret_models_svmRadial_advance_C) - , sigma=sigma - ) + , param_set=list(C=as.numeric(input$model_training_caret_models_svmRadial_advance_C), sigma=sigma) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$svmRadial_model = NULL } ## svmLinear - if (isTRUE(input$model_training_caret_models_svmLinear_check)) { - rv_training_models$svmLinear_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$svmLinear_name)) { + rv_training_models$svmLinear_model = setup_caret_safe( rv_training_models$svmLinear_name , param=rv_training_models$svmLinear_param - , param_set=list( - C=as.numeric(input$model_training_caret_models_svmLinear_advance_C) - ) + , param_set=list(C=as.numeric(input$model_training_caret_models_svmLinear_advance_C)) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$svmLinear_model = NULL } - ## svmPoly - if (isTRUE(input$model_training_caret_models_svmPoly_check)) { - if (isTRUE(!is.null(input$model_training_caret_models_svmPoly_advance_scale))) { - scale_ = input$model_training_caret_models_svmPoly_advance_scale - scale_ = seq(scale_[1], scale_[2], length.out=20) - } else { - scale_ = input$model_training_caret_models_svmPoly_advance_scale - } - rv_training_models$svmPoly_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$svmPoly_name)) { + scale_ = input$model_training_caret_models_svmPoly_advance_scale + if (!is.null(scale_)) scale_ = seq(scale_[1], scale_[2], length.out=20) + rv_training_models$svmPoly_model = setup_caret_safe( rv_training_models$svmPoly_name , param=rv_training_models$svmPoly_param , param_set=list( degree=as.numeric(input$model_training_caret_models_svmPoly_advance_degree) - , C = as.numeric(input$model_training_caret_models_svmPoly_advance_C) + , C=as.numeric(input$model_training_caret_models_svmPoly_advance_C) , scale=scale_ ) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$svmPoly_model = NULL } - ## glmnet - if (isTRUE(input$model_training_caret_models_glmnet_check)) { - rv_training_models$glmnet_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$glmnet_name)) { + rv_training_models$glmnet_model = setup_caret_safe( rv_training_models$glmnet_name , param=rv_training_models$glmnet_param , param_set=list( - alpha=as.numeric(input$model_training_caret_models_glmnet_advance_alpha) - , lambda = c(seq(0.001, 0.1, length.out=10), seq(0.1, 2, by =0.1) , seq(2, 5, 0.5) , seq(5, 25, 1)) + alpha=input$model_training_caret_models_glmnet_advance_alpha + , lambda=glmnet_lambda_grid() ) + , defaults=list(alpha=seq(0.1, 1, length.out = 10), lambda=glmnet_lambda_grid()) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$glmnet_model = NULL } - ## lasso - if (isTRUE(input$model_training_caret_models_lasso_check)) { + if (!is.null(rv_training_models$lasso_name)) { rv_training_models$lasso_param = TRUE - rv_training_models$lasso_model = Rautoml::setup_caret( + rv_training_models$lasso_model = setup_caret_safe( rv_training_models$lasso_name - , param=TRUE#rv_training_models$lasso_param + , param=TRUE , param_set=list( - alpha=as.numeric(input$model_training_caret_models_lasso_advance_alpha) - , lambda = c(seq(0.001, 0.1, length.out=10), seq(0.1, 2, by =0.1) , seq(2, 5, 0.5) , seq(5, 25, 1)) + alpha=input$model_training_caret_models_lasso_advance_alpha + , lambda=glmnet_lambda_grid() ) + , defaults=list(alpha=1, lambda=glmnet_lambda_grid()) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$lasso_model = NULL } - ## ridge - if (isTRUE(input$model_training_caret_models_ridge_check)) { + if (!is.null(rv_training_models$ridge_name)) { rv_training_models$ridge_param = TRUE - rv_training_models$ridge_model = Rautoml::setup_caret( + rv_training_models$ridge_model = setup_caret_safe( rv_training_models$ridge_name - , param=TRUE#rv_training_models$ridge_param + , param=TRUE , param_set=list( - alpha=as.numeric(input$model_training_caret_models_ridge_advance_alpha) - , lambda = c(seq(0.001, 0.1, length.out=10), seq(0.1, 2, by =0.1) , seq(2, 5, 0.5) , seq(5, 25, 1)) + alpha=input$model_training_caret_models_ridge_advance_alpha + , lambda=glmnet_lambda_grid() ) + , defaults=list(alpha=0, lambda=glmnet_lambda_grid()) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$ridge_model = NULL } - ## knn - if (isTRUE(input$model_training_caret_models_knn_check)) { - rv_training_models$knn_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$knn_name)) { + rv_training_models$knn_model = setup_caret_safe( rv_training_models$knn_name , param=rv_training_models$knn_param - , param_set=list( - k=as.numeric(input$model_training_caret_models_knn_advance_k) - ) + , param_set=list(k=as.numeric(input$model_training_caret_models_knn_advance_k)) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$knn_model = NULL } - ## nnet - if (isTRUE(input$model_training_caret_models_nnet_check)) { - rv_training_models$nnet_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$nnet_name)) { + rv_training_models$nnet_model = setup_caret_safe( rv_training_models$nnet_name , param=rv_training_models$nnet_param , param_set=list( @@ -460,123 +489,73 @@ model_training_caret_train_all_server = function() { , decay=as.numeric(input$model_training_caret_models_nnet_advance_decay) ) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$nnet_model = NULL } - ## treebag - if (isTRUE(input$model_training_caret_models_treebag_check)) { + if (!is.null(rv_training_models$treebag_name)) { rv_training_models$treebag_trained_model = rv_training_models$treebag_name - rv_training_models$treebag_model = Rautoml::setup_caret( - rv_training_models$treebag_name - , param=FALSE - , param_set=NULL - ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$treebag_model = NULL + rv_training_models$treebag_model = setup_caret_safe(rv_training_models$treebag_name, param=FALSE, param_set=NULL) } ## avNNet - if (isTRUE(input$model_training_caret_models_avNNet_check)) { - rv_training_models$avNNet_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$avNNet_name)) { + rv_training_models$avNNet_model = setup_caret_safe( rv_training_models$avNNet_name , param=rv_training_models$avNNet_param , param_set=list( - bag = input$model_training_caret_models_avNNet_advance_bag + bag=input$model_training_caret_models_avNNet_advance_bag , size=as.numeric(input$model_training_caret_models_avNNet_advance_size) , decay=as.numeric(input$model_training_caret_models_avNNet_advance_decay) ) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$avNNet_model = NULL } ## pls - if (isTRUE(input$model_training_caret_models_pls_check)) { - rv_training_models$pls_model = Rautoml::setup_caret( + if (!is.null(rv_training_models$pls_name)) { + rv_training_models$pls_model = setup_caret_safe( rv_training_models$pls_name , param=rv_training_models$pls_param - , param_set=list( - ncomp=as.numeric(input$model_training_caret_models_pls_advance_ncomp) - ) + , param_set=list(ncomp=as.numeric(input$model_training_caret_models_pls_advance_ncomp)) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$pls_model = NULL } - ## gam - if (isTRUE(input$model_training_caret_models_gam_check)) { + if (!is.null(rv_training_models$gam_name)) { rv_training_models$gam_trained_model = rv_training_models$gam_name - rv_training_models$gam_model = Rautoml::setup_caret( - rv_training_models$gam_name - , param=FALSE - , param_set=NULL - ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$gam_model = NULL + rv_training_models$gam_model = setup_caret_safe(rv_training_models$gam_name, param=FALSE, param_set=NULL) } ## rpart - if (isTRUE(input$model_training_caret_models_rpart_check)) { + if (!is.null(rv_training_models$rpart_name)) { cp_ = input$model_training_caret_models_rpart_advance_cp - if (!is.null(cp_)) { - cp_ = runif(cp_, n=20) - } - rv_training_models$rpart_model = Rautoml::setup_caret( + if (!is.null(cp_)) cp_ = runif(cp_, n=20) + rv_training_models$rpart_model = setup_caret_safe( rv_training_models$rpart_name , param=rv_training_models$rpart_param - , param_set=list( - cp=cp_ - ) + , param_set=list(cp=cp_) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$rpart_model = NULL } - + ## mlpWeightDecayML - if (isTRUE(input$model_training_caret_models_mlpWeightDecayML_check)) { + if (!is.null(rv_training_models$mlpWeightDecayML_name)) { layer1_ = input$model_training_caret_models_mlpWeightDecayML_advance_layer1 - if (!is.null(layer1_)) { - layer1_ = floor(runif(layer1_, n=20)) - } + if (!is.null(layer1_)) layer1_ = floor(runif(layer1_, n=20)) layer2_ = input$model_training_caret_models_mlpWeightDecayML_advance_layer2 - if (!is.null(layer2_)) { - layer2_ = floor(runif(layer2_, n=20)) - } + if (!is.null(layer2_)) layer2_ = floor(runif(layer2_, n=20)) layer3_ = input$model_training_caret_models_mlpWeightDecayML_advance_layer3 - if (!is.null(layer3_)) { - layer3_ = floor(runif(layer3_, n=20)) - } + if (!is.null(layer3_)) layer3_ = floor(runif(layer3_, n=20)) decay_ = input$model_training_caret_models_mlpWeightDecayML_advance_decay - if (!is.null(decay_)) { - decay_ = runif(decay_, n=20) - } - rv_training_models$mlpWeightDecayML_model = Rautoml::setup_caret( + if (!is.null(decay_)) decay_ = runif(decay_, n=20) + rv_training_models$mlpWeightDecayML_model = setup_caret_safe( rv_training_models$mlpWeightDecayML_name , param=rv_training_models$mlpWeightDecayML_param - , param_set=list( - layer1=layer1_ - , layer2=layer2_ - , layer3=layer3_ - , decay = decay_ - ) + , param_set=list(layer1=layer1_, layer2=layer2_, layer3=layer3_, decay=decay_) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$mlpWeightDecayML_model = NULL } - - + + ## naive_bayes - if (isTRUE(input$model_training_caret_models_naive_bayes_check)) { + if (!is.null(rv_training_models$naive_bayes_name)) { laplace_ = input$model_training_caret_models_naive_bayes_advance_laplace if (!is.null(laplace_)) { laplace_ = runif(laplace_, n=20) @@ -586,58 +565,118 @@ model_training_caret_train_all_server = function() { adjust_ = runif(adjust_, n=20) } usekernel_ = input$model_training_caret_models_naive_bayes_advance_usekernel - rv_training_models$naive_bayes_model = Rautoml::setup_caret( + rv_training_models$naive_bayes_model = setup_caret_safe( rv_training_models$naive_bayes_name , param=rv_training_models$naive_bayes_param - , param_set=list( - laplace=laplace_ - , adjust=adjust_ - , usekernel=usekernel_ - ) + , param_set=list(laplace=laplace_, adjust=adjust_, usekernel=usekernel_) ) - rv_ml_ai$at_least_one_model = TRUE - } else { - rv_training_models$naive_bayes_model = NULL } - ## Track models for PB rv_training_models$CARET_MODEL_IDS = gsub("_model$", "", grep("(? 0; + $('#train_apply_wrap').css('display', anyChecked ? 'block' : 'none'); + } + $(document).on('change', SEL, refreshTrainBtn); + $(document).on('shiny:value', function(e) { + if (e.name === 'model_training_apply') { setTimeout(refreshTrainBtn, 0); } + }); + })(); + ") + + ## After feature engineering fires, pre-warm all model checkbox/advance outputs + ## so navigating to Train model does not trigger 40+ sequential round-trips. + observeEvent(input$feature_engineering_apply, { + req(!is.null(rv_ml_ai$preprocessed)) + later::later(function() { + # Model IDs — match the keys used in model_training_caret_models.R + all_ids <- c("ols","rf","gbm","xgbTree","xgbLinear","svmRadial", + "svmLinear","svmPoly","glmnet","lasso","ridge","knn", + "nnet","treebag","avNNet","pls","gam","rpart", + "mlpWeightDecayML","naive_bayes") + no_advance <- c("treebag", "gam") # these have no advance options panel + ols_special <- "ols" # ols uses a different suffix + + check_ids <- paste0("model_training_caret_models_", all_ids, "_check") + adv_std <- paste0("model_training_caret_models_", + setdiff(all_ids, c(no_advance, ols_special)), + "_advance_params") + adv_ols <- "model_training_caret_models_ols_advance_intercept" + + for (id in c(check_ids, adv_std, adv_ols)) { + tryCatch( + outputOptions(output, id, suspendWhenHidden = FALSE), + error = function(e) NULL + ) } - } + }, delay = 0.25) + }, ignoreInit = TRUE) + + observe({ + req(!is.null(rv_ml_ai$preprocessed)) + all_ids <- c("ols","rf","gbm","xgbTree","xgbLinear","svmRadial", + "svmLinear","svmPoly","glmnet","lasso","ridge","knn", + "nnet","treebag","avNNet","pls","gam","rpart", + "mlpWeightDecayML","naive_bayes") + any_checked <- any(vapply(all_ids, function(id) { + isTRUE(input[[paste0("model_training_caret_models_", id, "_check")]]) + }, logical(1))) + rv_ml_ai$at_least_one_model <- any_checked }) ## Train model action - observe({ - output$model_training_apply = renderUI({ - if (isTRUE(!is.null(rv_current$working_df))) { - if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { - if (isTRUE(rv_ml_ai$at_least_one_model)) { - p(br() - , actionBttn("model_training_apply" - , inline=TRUE - , block = FALSE - , color = "success" - , label = get_rv_labels("model_training_apply") - ) - ) + output$model_training_apply = renderUI({ + if (isTRUE(!is.null(rv_current$working_df))) { + if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { + button_label <- if (isTRUE(rv_training_results$training_busy) || isTRUE(rv_training_results$training_completed)) { + add_label <- tryCatch(as.character(get_rv_labels("caret_jobs_add_selected")), error = function(e) NULL) + if (is.null(add_label) || !length(add_label) || is.na(add_label[[1]]) || !nzchar(add_label[[1]])) { + "Add selected models to queue" + } else { + add_label[[1]] } - } + } else { + get_rv_labels("model_training_apply") + } + ## Always rendered but hidden; the client-side handler above shows it + ## instantly when a model checkbox is ticked (no server round-trip). + div(id = "train_apply_wrap", style = "display:none;" + , p(br() + , actionBttn("model_training_apply" + , inline=TRUE + , block = FALSE + , color = "success" + , label = button_label + ) + ) + ) } - }) + } }) ## Model list - observe({ - output$model_training_caret_models_ui = renderUI({ + output$model_training_caret_models_ui = renderUI({ if (isTRUE(!is.null(rv_current$working_df))) { if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { p(br() @@ -738,354 +777,24 @@ model_training_caret_train_all_server = function() { ) } } - }) }) - - ## Train models - observeEvent(input$model_training_apply, { - start_progress_bar <- function(id, att_new_obj, text) { - rv_training_results$training_busy <- TRUE - rv_training_results$training_completed <- FALSE - } - close_progress_bar <- function(att_new_obj) { - if (!isTRUE(rv_training_results$training_busy)) return(invisible(NULL)) - rv_training_results$training_busy <- FALSE - session$sendCustomMessage("caretModelProgressComplete", list( - success = isTRUE(rv_training_results$training_completed) - )) - } - - if (isTRUE(!is.null(rv_current$working_df))) { - if (isTRUE(!is.null(rv_ml_ai$preprocessed))) { - if (isTRUE(rv_ml_ai$at_least_one_model)) { - - start_progress_bar(id="model_training_caret_pb", att_new_obj=model_training_caret_pb, text=get_rv_labels("model_training_apply_progress_bar")) - - models_state <- reactiveValuesToList(rv_training_models) - all_model_params <- do.call(c, Filter(Negate(is.null), lapply(rv_training_models$CARET_MODEL_IDS, function(id) { - models_state[[paste0(id, "_model")]] - }))) - set.seed(rv_ml_ai$seed_value) - - rv_training_results$training_completed = FALSE - - if (isTRUE(input$model_training_setup_start_clusters_check)) { - Rautoml::start_cluster() - } - - if (isTRUE(input$feature_engineering_perform_partition_group!="") & isTRUE(!is.null(input$feature_engineering_perform_partition_group))) { - if (isTRUE(!is.null(rv_ml_ai$fold_index))) { - k = rv_train_control_caret$number - print(k) - rv_train_control_caret$index = Rautoml::create_grouped_index(rv_ml_ai$fold_index, k = rv_train_control_caret$number) - } else { - rv_train_control_caret$index = NULL - } - } - print(rv_train_control_caret$index) - - rv_training_results$models = tryCatch({ - Rautoml::train_caret_models( - df=rv_ml_ai$preprocessed$train_df - , model_form=rv_ml_ai$model_formula - , ctrl=reactiveValuesToList(rv_train_control_caret) - , model_list=all_model_params - , metric=input$model_training_setup_eval_metric - ) - }, error = function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("model_training_error"), "\n", e$message), type = "error") - if (isTRUE(input$model_training_setup_start_clusters_check)) Rautoml::stop_cluster() - close_progress_bar(att_new_obj=model_training_caret_pb) - return(NULL) - }) - - - if (isTRUE(input$model_training_setup_start_clusters_check)) { - Rautoml::stop_cluster() - } - - - if (isTRUE(is.null(rv_training_results$models))) return() - - if (isTRUE(input$model_training_setup_include_ensemble_check)) { - rv_training_results$models = tryCatch({ - Rautoml::create_ensemble( - all.models = rv_training_results$models - , ctrl=reactiveValuesToList(rv_train_control_caret) - , metric=input$model_training_setup_eval_metric - ) - }, error = function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("model_training_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_training_caret_pb) - return(NULL) - }) - } - - rv_training_results$training_completed = TRUE - rv_ml_ai$at_least_one_model = FALSE - for (cb in rv_training_models$CARET_MODEL_IDS) { - updatePrettyCheckbox(session, - inputId = paste0("model_training_caret_models_", cb, "_check"), - value = FALSE) - } - -## rv_training_models$ols_model = NULL -## rv_training_models$rf_model = NULL -## rv_training_models$gbm_model = NULL -## rv_training_models$xgbTree_model = NULL -## rv_training_models$xgbLinear_model = NULL -## rv_training_models$svmRadial_model = NULL -## rv_training_models$svmLinear_model = NULL -## rv_training_models$svmPoly_model = NULL -## rv_training_models$glmnet_model = NULL -## rv_training_models$lasso_model = NULL -## rv_training_models$ridge_model = NULL -## rv_training_models$knn_model = NULL -## rv_training_models$nnet_model = NULL -## -## rv_train_control_caret$method = "cv" -## rv_train_control_caret$number = 5 -## rv_train_control_caret$repeats = NA -## rv_train_control_caret$search = "grid" -## rv_train_control_caret$verboseIter = FALSE -## rv_train_control_caret$savePredictions = FALSE -## rv_train_control_caret$classProbs = TRUE -## - - if (isTRUE(is.null(rv_training_results$models))) return() - - rv_training_results$tuned_parameters = tryCatch({ - Rautoml::get_tuned_params(rv_training_results$models) - }, error=function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("model_train_metrics_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_training_caret_pb) - return(NULL) - }) - - if (is.null(rv_training_results$tuned_parameters)) return() - - rv_training_results$control_parameters = tryCatch({ - Rautoml::get_ctl_params(models=rv_training_results$models - , items=names(reactiveValuesToList(rv_train_control_caret)) - ) - }, error=function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("model_train_metrics_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_training_caret_pb) - return(NULL) - }) - - if (is.null(rv_training_results$control_parameters)) return() - - rv_training_results$train_metrics_df=tryCatch({ - Rautoml::extract_summary(rv_training_results$models, summary_fun=Rautoml::student_t_summary) - }, error = function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("model_train_metrics_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_training_caret_pb) - return(NULL) - }) - - - if (is.null(rv_training_results$train_metrics_df)) return() - - ## Save training performance metrics locally - - save_training = tryCatch({ - Rautoml::save_rautoml_csv(object=rv_training_results$train_metrics_df - , name="training_performance_metrics" - , dataset_id=rv_ml_ai$dataset_id - , session_name=rv_ml_ai$session_id - , timestamp=Sys.time() - , output_dir=paste0(app_username, "/outputs") - ) - invisible(TRUE) - }, error=function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("general_error_alert"), "\n", e$message), type = "error") - return(NULL) - }) - - if (is.null(save_training)) { - close_progress_bar(att_new_obj=model_training_caret_pb) - return() - } - - ## Test metrics - rv_training_results$test_metrics_objs=tryCatch({ - Rautoml::boot_estimates_multiple( - models=rv_training_results$models - , df=rv_ml_ai$preprocessed$test_df - , outcome_var=rv_ml_ai$outcome - , problem_type=rv_ml_ai$task - , nreps=100 - , model_name=NULL - , type="prob" - , report= input$model_training_setup_eval_metric - , summary_fun=Rautoml::student_t_summary - , save_model = TRUE - , model_folder = paste0(app_username, "/models") - , recipe_folder = paste0(app_username, "/recipes") - , preprocesses = rv_ml_ai$preprocessed - ) - }, error = function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("model_test_metrics_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_training_caret_pb) - return(NULL) - }) - - if (is.null(rv_training_results$test_metrics_objs)) return() - - ## Save test performance metrics - - save_test = tryCatch({ - Rautoml::save_boot_estimates(boot_list=rv_training_results$test_metrics_objs - , dataset_id=rv_ml_ai$dataset_id - , session_name=rv_ml_ai$session_id - , timestamp=Sys.time() - , output_dir=paste0(app_username, "/outputs") - , sub_dir="test_metrics" - ) - invisible(TRUE) - }, error=function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("general_error_alert"), "\n", e$message), type = "error") - return(NULL) - }) - - if (is.null(save_test)) { - close_progress_bar(att_new_obj=model_training_caret_pb) - return() - } - - ## Generate logs - save_logs = tryCatch({ - Rautoml::create_model_logs( - df_name=rv_ml_ai$dataset_id - , session_name=rv_ml_ai$session_id - , outcome=rv_ml_ai$outcome - , framework=input$modelling_framework_choices - , train_result=rv_training_results$test_metrics_objs$all - , timestamp=Sys.time() - , path=paste0(app_username, "/.log_files") - ) - invisible(TRUE) - }, error=function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("general_error_alert"), "\n", e$message), type = "error") - return(NULL) - }) - - if (is.null(save_logs)) { - close_progress_bar(att_new_obj=model_training_caret_pb) - return() - } - - - ## More metrics - ### Post metrics - rv_training_results$post_model_metrics_objs=tryCatch({ - Rautoml::post_model_metrics( - models=rv_training_results$models - , outcome=rv_ml_ai$outcome - , df=rv_ml_ai$preprocessed$test_df - , task=rv_ml_ai$task - ) - }, error = function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("model_post_metrics_error"), "\n", e$message), type = "error") - close_progress_bar(att_new_obj=model_training_caret_pb) - return(NULL) - }) - - if (is.null(rv_training_results$post_model_metrics_objs)) return() - - ## Save post model objects - save_post = tryCatch({ - Rautoml::save_post_metrics_plots(metric_list=rv_training_results$post_model_metrics_objs - , dataset_id=rv_ml_ai$dataset_id - , session_name=rv_ml_ai$session_id - , timestamp=Sys.time() - , output_dir=paste0(app_username, "/outputs") - ) - invisible(TRUE) - }, error=function(e) { - shinyalert::shinyalert("Error: ", paste0(get_rv_labels("general_error_alert"), "\n", e$message), type = "error") - return(NULL) - }) - - if (is.null(save_post)) { - close_progress_bar(att_new_obj=model_training_caret_pb) - return() - } - - close_progress_bar(att_new_obj=model_training_caret_pb) - } else { - rv_training_results$models = NULL - rv_training_results$train_metrics_df = NULL - rv_training_results$test_metrics_objs = NULL - rv_training_results$post_model_metrics_objs = NULL - rv_training_results$tuned_parameters = NULL - rv_training_results$control_parameters = NULL - - close_progress_bar(att_new_obj=model_training_caret_pb) - } - } else { - rv_training_results$models = NULL - rv_training_results$train_metrics_df = NULL - rv_training_results$test_metrics_objs = NULL - rv_training_results$post_model_metrics_objs = NULL - rv_training_results$tuned_parameters = NULL - rv_training_results$control_parameters = NULL - close_progress_bar(att_new_obj=model_training_caret_pb) - } - } else { - rv_training_results$models = NULL - rv_training_results$train_metrics_df = NULL - rv_training_results$test_metrics_objs = NULL - rv_training_results$post_model_metrics_objs = NULL - rv_training_results$tuned_parameters = NULL - rv_training_results$control_parameters = NULL - close_progress_bar(att_new_obj=model_training_caret_pb) - } - }) - - ## Reactive label outputs for the progress panel (reads from labelling file, updates on language change) - output$cmp_panel_title_ui <- renderUI({ get_rv_labels("cmp_panel_title") }) - output$cmp_footer_ui <- renderUI({ - tagList(tags$i(class = "fa fa-info-circle"), paste0(" ", get_rv_labels("cmp_footer_note"))) - }) - output$cmp_labels_json <- renderUI({ - tags$div( - id = "cmp-labels-data", - style = "display:none!important;position:absolute;height:0;overflow:hidden;", - `data-word-training` = get_rv_labels("cmp_word_training"), - `data-word-completed` = get_rv_labels("cmp_word_completed"), - `data-status-training` = get_rv_labels("cmp_status_training"), - `data-status-completed` = get_rv_labels("cmp_status_completed"), - `data-status-stopped` = get_rv_labels("cmp_status_stopped"), - `data-badge-done` = get_rv_labels("cmp_badge_done"), - `data-badge-failed` = get_rv_labels("cmp_badge_failed") - ) - }) - outputOptions(output, "cmp_panel_title_ui", suspendWhenHidden = FALSE) - outputOptions(output, "cmp_footer_ui", suspendWhenHidden = FALSE) - outputOptions(output, "cmp_labels_json", suspendWhenHidden = FALSE) - - ## Provide selected model names as JSON for the JS click handler on the progress panel - output$caret_selected_models_json <- renderUI({ - models_state <- reactiveValuesToList(rv_training_models) - models <- Filter(Negate(is.null), lapply(rv_training_models$CARET_MODEL_IDS, function(id) { - if (!isTRUE(input[[paste0("model_training_caret_models_", id, "_check")]])) return(NULL) - nm <- models_state[[paste0(id, "_name")]] - if (is.null(nm)) return(NULL) - disp <- if (!is.null(names(nm)) && nzchar(names(nm)[1])) names(nm)[1] else as.character(nm[1]) - list(name = disp) - })) - models_json <- if (length(models) > 0) as.character(jsonlite::toJSON(models, auto_unbox = TRUE)) else "[]" - tags$div( - id = "caret-selected-models-data", - style = "display:none!important;position:absolute;height:0;overflow:hidden;", - `data-models` = models_json + outputOptions(output, "model_training_caret_models_ui", suspendWhenHidden = FALSE) + outputOptions(output, "model_training_apply", suspendWhenHidden = FALSE) + + caret_job_manager_server( + input = input, + output = output, + session = session, + rv_current = rv_current, + rv_ml_ai = rv_ml_ai, + rv_training_models = rv_training_models, + rv_train_control_caret = rv_train_control_caret, + rv_training_results = rv_training_results, + app_username = app_username, + get_rv_labels = get_rv_labels ) - }) - outputOptions(output, "caret_selected_models_json", suspendWhenHidden = FALSE) -## observe({ + ## observe({ ## req(!isTRUE(rv_training_results$training_completed), isTRUE(!is.null(rv_training_results$training_completed))) ## req(isTRUE(!is.null(rv_current$working_df))) ## req(isTRUE(!is.null(rv_ml_ai$preprocessed))) @@ -1117,6 +826,6 @@ model_training_caret_train_all_server = function() { ## rv_training_models$ridge_model = NULL ## rv_training_models$knn_model = NULL ## rv_training_models$nnet_model = NULL -## +## ## }) } diff --git a/static_files/labelling_file.xlsx b/static_files/labelling_file.xlsx index b496b8a..7ae6cf1 100644 Binary files a/static_files/labelling_file.xlsx and b/static_files/labelling_file.xlsx differ diff --git a/ui.R b/ui.R index 5e99a25..0f834e7 100644 --- a/ui.R +++ b/ui.R @@ -16,10 +16,10 @@ source(paste0(getwd(), "/ui/tooltip.R")) # Load UI function before deploy_model_ui() source("ui/deploy_model_ui.R") -#Load Headertag -source(paste0(getwd(), "/ui/login_credentials.R")) - -source(paste0(getwd(), "/ui/headertag.R")) +#Load Headertag +source(paste0(getwd(), "/ui/login_credentials.R")) + +source(paste0(getwd(), "/ui/headertag.R")) #Load App Theme source(paste0(getwd(), "/ui/appTheme.R")) #Load Header @@ -43,12 +43,12 @@ fluidPage( useShinyjs(), useWaiter(), - waiterShowOnLoad( - color = "#FFF", - html = spin_loaders(id = 2, style="width:56px;height:56px;color:#7BC148;"), - logo= "WWW/aphrc.png"), - - shiny::tags$head( + waiterShowOnLoad( + color = "#FFF", + html = spin_loaders(id = 2, style="width:56px;height:56px;color:#7BC148;"), + logo= "WWW/aphrc.png"), + + shiny::tags$head( tags$link( rel = "stylesheet", type = "text/css", @@ -106,4 +106,3 @@ fluidPage( div(footer) ) )) - \ No newline at end of file diff --git a/ui/mod_quant_anonymization.R b/ui/mod_quant_anonymization.R index f6d1fce..f938889 100644 --- a/ui/mod_quant_anonymization.R +++ b/ui/mod_quant_anonymization.R @@ -2,14 +2,14 @@ mod_quant_anon_ui <- function(id) { ns <- shiny::NS(id) - + # Precompute namespaced IDs used in JS strings ns_right_panel <- ns("right-panel") ns_main_tabs <- ns("main_tabs") ns_remove_ids <- ns("remove_ids") # must exist in identifier_selector output ns_remove_inline <- ns("remove_ids_inline") ns_method <- ns("method") - + # ACE IDs ns_r_ace <- ns("r_code_ace") ns_stata_ace <- ns("stata_code_ace") @@ -17,28 +17,28 @@ mod_quant_anon_ui <- function(id) { ns_copy_r <- ns("copy_r") ns_copy_st <- ns("copy_stata") ns_copy_py <- ns("copy_py") - + ns_dashboard <- ns("dashboard") - + # Hidden translation “tokens” for JS js_i18n_tokens <- shiny::tags$div( style = "display:none;", shiny::tags$span(id = ns("js_copy_txt"), shiny::textOutput(ns("quant_anon_js_copy_txt"), container = shiny::span)), shiny::tags$span(id = ns("js_copied_txt"), shiny::textOutput(ns("quant_anon_js_copied_txt"), container = shiny::span)) ) - + shiny::div( id = ns("anon_root"), class = "anon-root", shiny::tagList( shinyjs::useShinyjs(), - + shiny::tags$head( shiny::tags$link( rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/font-awesome/6.5.0/css/all.min.css" ), - + shiny::tags$script(shiny::HTML(sprintf(" function copyAce(editorId, btnId, nsPrefix) { var ed = ace.edit(editorId); @@ -66,52 +66,52 @@ mod_quant_anon_ui <- function(id) { } "))) ), - + js_i18n_tokens, - + shiny::div( id = ns_dashboard, class = "anon-dashboard", style = "display:block; padding:20px;", - + shiny::tabsetPanel( id = ns_main_tabs, - + # -------------------------- DASHBOARD TAB ------------------------------- shiny::tabPanel( shiny::uiOutput(ns("quant_anon_tab_dashboard")), - + shiny::fluidRow( # ---------- LEFT PANEL ---------- shiny::column( width = 4, id = ns("left-panel"), - + # Step 0 shiny::wellPanel( shiny::uiOutput(ns("quant_anon_step0_title_ui")), - + shiny::div( style = "padding:8px; border:1px solid #eee; border-radius:6px;", shiny::uiOutput(ns("quant_anon_step0_use_platform_title_ui")), shiny::br(), shiny::uiOutput(ns("platform_dataset_picker")), - + shiny::actionButton( ns("use_platform_data"), label = NULL, # Server controls label with updateActionButton() class = "btn btn-success btn-block" ), - + shiny::tags$small( style = "display:block; margin-top:6px; color:#666;", shiny::uiOutput(ns("quant_anon_step0_hint_ui")) ) ), - + shiny::tags$hr(), shiny::textOutput(ns("n_obs_text")) ), - + # Step 1 shiny::wellPanel( shiny::div( @@ -128,32 +128,32 @@ mod_quant_anon_ui <- function(id) { ), shiny::uiOutput(ns("identifier_selector")) ), - + # Step 2 shiny::wellPanel( shiny::uiOutput(ns("quant_anon_step2_title_ui")), shiny::uiOutput(ns("bucket_ui")) ), - + # Step 3 shiny::wellPanel( shiny::uiOutput(ns("quant_anon_step3_title_ui")), - + shiny::selectInput( ns_method, label = NULL, # server sets label via updateSelectInput() choices = character(0), selected = NULL ), - + shiny::uiOutput(ns("extra_input")), - + # IMPORTANT: compare against stable code shiny::conditionalPanel( condition = sprintf("input['%s'] == 'generalization'", ns_method), shiny::uiOutput(ns("quant_anon_generalization_tips_ui")) ), - + shiny::fluidRow( shiny::column( 4, @@ -167,7 +167,7 @@ mod_quant_anon_ui <- function(id) { 4, shiny::actionButton( ns("undo"), - label = NULL, + label = NULL, class = "btn btn-warning btn-block" ) ), @@ -180,24 +180,24 @@ mod_quant_anon_ui <- function(id) { ) ) ), - + # Advisor shiny::wellPanel( shiny::uiOutput(ns("quant_anon_advisor_title_ui")), - + shiny::selectInput( ns("advisor_var"), - label = NULL, # + label = NULL, # choices = NULL, selectize = TRUE ), - + shiny::actionButton( ns("advisor_run"), label = NULL, # server controls class = "btn btn-info btn-block" ), - + shiny::tags$hr(), shiny::uiOutput(ns("quant_anon_overall_hist_ui")), shiny::plotOutput(ns("advisor_dist"), height = "220px"), @@ -207,43 +207,43 @@ mod_quant_anon_ui <- function(id) { shiny::tableOutput(ns("advisor_table")), shiny::plotOutput(ns("advisor_plot"), height = "220px") ), - + # Downloads / Report shiny::wellPanel( shiny::uiOutput(ns("quant_anon_downloads_title_ui")), - + shiny::uiOutput(ns("download_btn_csv_ui")), shiny::uiOutput(ns("download_btn_excel_ui")), shiny::uiOutput(ns("download_btn_dta_ui")), shiny::uiOutput(ns("download_btn_report_ui")), - + shiny::actionButton( ns("view_report"), label = NULL, class = "btn btn-default btn-block" ), - + shiny::conditionalPanel( condition = sprintf("input['%s'] == 'anonymizecoordinates'", ns_method), shiny::uiOutput(ns("quant_anon_coords_download_note_ui")) ), - + shiny::tags$hr(), shiny::uiOutput(ns("k_report")), shiny::tags$hr(), - + shiny::uiOutput(ns("quant_anon_steps_log_title_ui")), shiny::verbatimTextOutput(ns("step_log"), placeholder = TRUE) ) ) ), - + # ---------- RIGHT PANEL ---------- shiny::column( width = 8, id = ns_right_panel, shiny::div( class = "right-containers", - + # === Container 1: Data Preview / Map === shiny::div( class = "right-box", @@ -253,13 +253,13 @@ mod_quant_anon_ui <- function(id) { ), shiny::div( class = "right-body", - + # IMPORTANT: compare against stable code shiny::conditionalPanel( condition = sprintf("input['%s'] == 'anonymizecoordinates'", ns_method), leaflet::leafletOutput(ns("geo_map"), height = "420px") ), - + shiny::conditionalPanel( condition = sprintf("input['%s'] != 'anonymizecoordinates'", ns_method), shiny::div( @@ -270,7 +270,7 @@ mod_quant_anon_ui <- function(id) { ) ) ), - + # === Container 2: Risk Assessment === shiny::div( class = "right-box", @@ -313,16 +313,16 @@ mod_quant_anon_ui <- function(id) { ) ) ), - + # ----------------------------- CODES TAB --------------------------------- shiny::tabPanel( shiny::uiOutput(ns("quant_anon_tab_codes")), - + shiny::fluidRow( shiny::column( width = 4, shiny::uiOutput(ns("quant_anon_r_code_hdr_ui")), - + shinyAce::aceEditor( outputId = ns_r_ace, mode = "r", @@ -330,7 +330,7 @@ mod_quant_anon_ui <- function(id) { readOnly = TRUE, height = "400px" ), - + shiny::actionButton( ns_copy_r, label = NULL, # server controls if desired; or keep static @@ -338,19 +338,19 @@ mod_quant_anon_ui <- function(id) { onclick = sprintf("copyAce('%s','%s','%s')", ns_r_ace, ns_copy_r, ns("x")) ) ), - + shiny::column( width = 4, shiny::uiOutput(ns("quant_anon_stata_code_hdr_ui")), - + shinyAce::aceEditor( outputId = ns_stata_ace, - mode = "stata", + mode = "plain_text", theme = "chrome", readOnly = TRUE, height = "400px" ), - + shiny::actionButton( ns_copy_st, label = NULL, @@ -358,11 +358,11 @@ mod_quant_anon_ui <- function(id) { onclick = sprintf("copyAce('%s','%s','%s')", ns_stata_ace, ns_copy_st, ns("x")) ) ), - + shiny::column( width = 4, shiny::uiOutput(ns("quant_anon_python_code_hdr_ui")), - + shinyAce::aceEditor( outputId = ns_py_ace, mode = "python", @@ -370,7 +370,7 @@ mod_quant_anon_ui <- function(id) { readOnly = TRUE, height = "400px" ), - + shiny::actionButton( ns_copy_py, label = NULL, @@ -380,7 +380,7 @@ mod_quant_anon_ui <- function(id) { ) ) ), - + # -------------------------- DESCRIPTIONS TAB ---------------------------- shiny::tabPanel( shiny::uiOutput(ns("quant_anon_tab_descriptions")), @@ -391,4 +391,3 @@ mod_quant_anon_ui <- function(id) { ) ) } - diff --git a/ui/research_questions_ui.R b/ui/research_questions_ui.R index 922df91..cfdcb15 100644 --- a/ui/research_questions_ui.R +++ b/ui/research_questions_ui.R @@ -14,7 +14,7 @@ research_questions_ui = function() { , uiOutput("generate_research_questions_additional_analysis_ui") ) , column(width = 9 - , htmlOutput("generate_research_questions_gemini") + , htmlOutput("generate_research_questions_gemini") , htmlOutput("generate_research_question_gemini_suggest_analysis") ) ) diff --git a/ui/train_all_model_ui.R b/ui/train_all_model_ui.R index 3073e16..38387da 100644 --- a/ui/train_all_model_ui.R +++ b/ui/train_all_model_ui.R @@ -2,6 +2,15 @@ train_all_model_ui = function() { tabItem(tabName = "trainModel", tags$head( tags$style(HTML(" + /* ---- Prevent Shiny recalculating opacity on training outputs ---- */ + #caret_job_queue_panel.recalculating, + #caret_job_queue_panel .recalculating, + #model_training_caret_models_ui.recalculating, + #model_training_apply.recalculating, + #model_training_caret_train_metrics.recalculating { + opacity: 1 !important; + } + /* ---- Model Training Progress Panel ---- */ #caret-model-progress { display: none; @@ -19,6 +28,7 @@ train_all_model_ui = function() { display: flex; justify-content: space-between; align-items: center; + min-height: 44px; background: #bde0a3; border-bottom: 1px solid #7bc148; } @@ -33,6 +43,8 @@ train_all_model_ui = function() { display: flex; align-items: center; gap: 10px; + min-height: 24px; + white-space: nowrap; } .cmp-count-dot { display: inline-block; @@ -47,10 +59,11 @@ train_all_model_ui = function() { } .cmp-row { display: grid; - grid-template-columns: 26px minmax(160px, 220px) 130px 1fr 55px 80px; + grid-template-columns: 28px minmax(180px, 260px) 170px minmax(560px, 1fr) 170px; align-items: center; gap: 12px; padding: 7px 0; + min-height: 43px; border-bottom: 1px solid #f2f7ec; } .cmp-row:last-child { @@ -66,6 +79,9 @@ train_all_model_ui = function() { font-size: 14px; font-weight: 500; color: #1a1a1a; + overflow: hidden; + text-overflow: ellipsis; + white-space: nowrap; } .cmp-status { font-size: 13px; @@ -73,6 +89,7 @@ train_all_model_ui = function() { align-items: center; gap: 6px; color: #444; + min-width: 0; } .cmp-sdot { display: inline-block; @@ -82,84 +99,90 @@ train_all_model_ui = function() { background: #2196f3; flex-shrink: 0; } - .cmp-bar-wrap { - height: 8px; - background: #e5eedd; - border-radius: 4px; - overflow: hidden; + .cmp-steps { + display: grid; + grid-template-columns: repeat(5, minmax(90px, 1fr)); + gap: 6px; + align-items: center; + min-width: 560px; } - .cmp-bar { - height: 100%; - border-radius: 4px; - background: #7bc148; - width: 0; - background-size: 28px 28px; - transition: width 0.4s ease; + .cmp-step { + display: flex; + align-items: center; + gap: 5px; + min-width: 0; + color: #9aa3a8; + font-size: 12px; + white-space: nowrap; } - .cmp-bar.cmp-running { - width: 70%; - background-image: repeating-linear-gradient( - -45deg, - #7bc148 0, #7bc148 10px, - #a3d46e 10px, #a3d46e 20px - ); - animation: cmpSlide 0.9s linear infinite; + .cmp-step-icon { + width: 18px; + height: 18px; + border-radius: 50%; + border: 1px solid #c7d1d5; + display: inline-flex; + align-items: center; + justify-content: center; + flex-shrink: 0; + background: #fff; + font-size: 10px; + } + .cmp-step-label { + overflow: hidden; + text-overflow: ellipsis; + } + .cmp-step.is-done { + color: #3f8f3f; } - .cmp-bar.cmp-done { - width: 100% !important; - background-image: none; + .cmp-step.is-done .cmp-step-icon { background: #4cae4c; - animation: none; + border-color: #4cae4c; + color: #fff; } - .cmp-bar.cmp-error { - width: 100% !important; - background-image: none; - background: #d9534f; - animation: none; + .cmp-step.is-current { + color: #1f5f8f; + font-weight: 700; } - @keyframes cmpSlide { - from { background-position: 0 0; } - to { background-position: 28px 0; } + .cmp-step.is-current .cmp-step-icon { + background: #2196f3; + border-color: #2196f3; + color: #fff; } - .cmp-pct { - font-size: 13px; - color: #666; - text-align: right; + .cmp-step.is-paused { + color: #a66b00; } - .cmp-badge-done { - padding: 3px 8px; - border: 1px solid #6eb15c; - border-radius: 4px; - font-size: 11px; - font-weight: 700; - color: #245a24; - background: #f1f8ee; - letter-spacing: 0.04em; - display: inline-block; - cursor: pointer; - transition: background 0.15s, color 0.15s; + .cmp-step.is-paused .cmp-step-icon { + background: #f6a100; + border-color: #f6a100; + color: #fff; + } + .cmp-step.is-stopped { + color: #555; } - .cmp-badge-done:hover { - background: #6eb15c; + .cmp-step.is-stopped .cmp-step-icon { + background: #777; + border-color: #777; color: #fff; } - .cmp-badge-error { - padding: 3px 8px; - border: 1px solid #d9534f; - border-radius: 4px; - font-size: 11px; - font-weight: 700; - color: #8b2f2b; - background: #fff3f2; - letter-spacing: 0.04em; - display: inline-block; - cursor: pointer; - transition: background 0.15s, color 0.15s; + .cmp-step.is-failed { + color: #a94442; } - .cmp-badge-error:hover { + .cmp-step.is-failed .cmp-step-icon { background: #d9534f; + border-color: #d9534f; color: #fff; } + .cmp-action { + display: flex; + gap: 5px; + justify-content: flex-start; + flex-wrap: wrap; + min-width: 150px; + min-height: 28px; + } + .cmp-action .btn { + min-width: 46px; + } .cmp-footer { padding: 6px 15px; font-size: 12px; @@ -167,142 +190,14 @@ train_all_model_ui = function() { border-top: 1px solid #e6f0d8; background: #fff; } - ")), - tags$script(HTML(" - (function () { - // Read a label from the hidden labels div (falls back to key if not found) - function lbl(key) { - var el = document.getElementById('cmp-labels-data'); - return el ? (el.getAttribute('data-' + key) || key) : key; - } - - function cmpInit(models) { - var panel = document.getElementById('caret-model-progress'); - if (!panel || !models || !models.length) return; - - var list = panel.querySelector('.cmp-list'); - list.innerHTML = ''; - - models.forEach(function (m, i) { - var row = document.createElement('div'); - row.className = 'cmp-row'; - row.innerHTML = - '
' + (i + 1) + '.
' + - '
' + (m.name || '') + '
' + - '
' + lbl('status-training') + '
' + - '
' + - '
—
' + - '
'; - list.appendChild(row); - }); - - panel.querySelector('#cmp-count-training').textContent = models.length + ' ' + lbl('word-training'); - panel.querySelector('#cmp-count-done').textContent = '0 ' + lbl('word-completed'); - panel.classList.add('cmp-visible'); - } - - function cmpComplete(success) { - var panel = document.getElementById('caret-model-progress'); - if (!panel) return; - - var rows = panel.querySelectorAll('.cmp-row'); - var n = rows.length; - - rows.forEach(function (row) { - var bar = row.querySelector('.cmp-bar'); - var sdot = row.querySelector('.cmp-sdot'); - var slabel = row.querySelector('.cmp-slabel'); - var pct = row.querySelector('.cmp-pct-val'); - var action = row.querySelector('.cmp-action'); - - bar.classList.remove('cmp-running'); - - if (success) { - bar.classList.add('cmp-done'); - sdot.style.background = '#4cae4c'; - slabel.textContent = lbl('status-completed'); - pct.textContent = '100%'; - action.innerHTML = '
' + lbl('badge-done') + '
'; - } else { - bar.classList.add('cmp-error'); - sdot.style.background = '#d9534f'; - slabel.textContent = lbl('status-stopped'); - pct.textContent = ''; - action.innerHTML = '
' + lbl('badge-failed') + '
'; - } - }); - - if (success) { - panel.querySelector('#cmp-count-training').textContent = '0 ' + lbl('word-training'); - panel.querySelector('#cmp-count-done').textContent = n + ' ' + lbl('word-completed'); - } - } - - // On button click: read pre-computed model list from hidden div and show panel - document.addEventListener('click', function (e) { - var btn = e.target.closest && e.target.closest('#model_training_apply'); - if (!btn) return; - var dataEl = document.getElementById('caret-selected-models-data'); - if (!dataEl) return; - var models = []; - try { models = JSON.parse(dataEl.getAttribute('data-models') || '[]'); } catch (ex) {} - cmpInit(models); - }); - - Shiny.addCustomMessageHandler('caretModelProgressComplete', function (msg) { - cmpComplete(msg && msg.success === true); - }); - - // Click DONE or FAILED badge → dismiss that row, hide panel if empty - function dismissBadgeRow(selector) { - document.addEventListener('click', function (e) { - var badge = e.target.closest && e.target.closest(selector); - if (!badge) return; - var panel = document.getElementById('caret-model-progress'); - if (!panel) return; - var row = badge.closest('.cmp-row'); - if (row) row.remove(); - var remaining = panel.querySelectorAll('.cmp-row').length; - if (remaining === 0) { - panel.classList.remove('cmp-visible'); - } else { - panel.querySelector('#cmp-count-done').textContent = remaining + ' ' + lbl('word-completed'); - } - }); - } - dismissBadgeRow('.cmp-badge-done'); - dismissBadgeRow('.cmp-badge-error'); - })(); - ")) - ), - fluidRow( - conditionalPanel( - condition = "input.modelling_framework_choices == 'Caret'", - column(width = 12, - uiOutput("caret_selected_models_json"), - uiOutput("cmp_labels_json") - ), - column(width = 12, - div( - id = "caret-model-progress", - div(class = "cmp-header", - div(class = "cmp-title", uiOutput("cmp_panel_title_ui")), - div(class = "cmp-counts", - tags$span( - tags$span(class = "cmp-count-dot", style = "background:#2196f3;"), - tags$span(id = "cmp-count-training", "0 training") - ), - tags$span("•"), - tags$span( - tags$span(class = "cmp-count-dot", style = "background:#4cae4c;"), - tags$span(id = "cmp-count-done", "0 completed") - ) - ) - ), - div(class = "cmp-list"), - div(class = "cmp-footer", uiOutput("cmp_footer_ui")) - ) - ), + ")) + ), + fluidRow( + conditionalPanel( + condition = "input.modelling_framework_choices == 'Caret'", + column(width = 12, + uiOutput("caret_job_queue_panel") + ), column(width = 12, uiOutput("model_training_setup_presetup") ),