added format model data module

R/data_parser.R

@@ -520,7 +520,7 @@ load_maindata <- function(dat, project, over_write = FALSE, compare = FALSE, y =
   #' looad_maindata(dat = "pollockMainDataTable", project = "pollock2020")
   #' }
   #' 
-
+  
   # project name check
   stopifnot("Project name cannot contain spaces." = !grepl("\\s", project),
             "Project name cannot be empty." = !is_value_empty(project))
@@ -874,7 +874,7 @@ load_port <- function(dat, port_name, project, over_write = TRUE, compare = FALS
   } else {
     colnames(x)[port_name] <- "Port_Name"
   }
-
+  
   colnames(x)[grep("LON", colnames(x), ignore.case = TRUE)] <- "Port_Long"
   colnames(x)[grep("LAT", colnames(x), ignore.case = TRUE)] <- "Port_Lat"
 
@@ -987,59 +987,48 @@ load_aux <- function(dat, aux, name, over_write = TRUE, project = NULL) {
 
   if (any(colnames(aux) %in% colnames(dataset)) == FALSE) {
 
-    warning("No shared columns. Column names do not match between two data sets.")
-    check <- FALSE
+    stop("No shared columns. At least one column name must match between the auxiliary
+     and main datasets.")
   }
 
-  if (check == FALSE) {
+  #unique rows
+  aux <- unique_rows(aux)
+
+  # TODO: Use name_check() 
+  #unique column names
+  if(length(toupper(colnames(aux))) != length(unique(toupper(colnames(aux))))){
+    print('Duplicate case-insensitive column names found. Duplicate column names adjusted.')
+    colnames(aux)[which(duplicated(colnames(aux)))] <- 
+      paste0(colnames(aux)[which(duplicated(colnames(aux)))], '.1')
+  }
+
+  #empty variables
+  aux <- empty_vars(aux, remove = TRUE)
+
+  if (table_exists(paste0(project, name), project) == FALSE | over_write == TRUE) {
 
-    warning("Auxiliary table not saved.")
-    invisible(FALSE)
+    suppressWarnings(fishset_db <- DBI::dbConnect(RSQLite::SQLite(), 
+                                                  locdatabase(project = project)))
+    on.exit(DBI::dbDisconnect(fishset_db), add = TRUE)
 
-  } else {
+    DBI::dbWriteTable(fishset_db, 
+                      paste0(project, name, "AuxTable", 
+                             format(Sys.Date(), format = "%Y%m%d")), 
+                      aux, overwrite = over_write)
 
-    #unique rows
-    aux <- unique_rows(aux)
+    DBI::dbWriteTable(fishset_db, paste0(project, name, "AuxTable"), 
+                      aux, overwrite = over_write)
 
-    # TODO: Use name_check() 
-    #unique column names
-    if(length(toupper(colnames(aux))) != length(unique(toupper(colnames(aux))))){
-      print('Duplicate case-insensitive column names found. Duplicate column names adjusted.')
-      colnames(aux)[which(duplicated(colnames(aux)))] <- paste0(colnames(aux)[which(duplicated(colnames(aux)))], '.1')
-    }
+    load_aux_function <- list()
+    load_aux_function$functionID <- "load_aux"
+    load_aux_function$args <- list(deparse_name(dat), deparse_name(aux), name, 
+                                   over_write, project)
+    log_call(project, load_aux_function)
+
+    message("Auxiliary table saved to database.")
+    invisible(TRUE)
 
-    #empty variables
-    aux <- empty_vars(aux, remove = TRUE)
 
-    if (table_exists(paste0(project, name), project) == FALSE | over_write == TRUE) {
-
-      suppressWarnings(fishset_db <- DBI::dbConnect(RSQLite::SQLite(), 
-                                                    locdatabase(project = project)))
-      on.exit(DBI::dbDisconnect(fishset_db), add = TRUE)
-
-      DBI::dbWriteTable(fishset_db, 
-                        paste0(project, name, "AuxTable", 
-                               format(Sys.Date(), format = "%Y%m%d")), 
-                        aux, overwrite = over_write)
-
-      DBI::dbWriteTable(fishset_db, paste0(project, name, "AuxTable"), 
-                        aux, overwrite = over_write)
-
-      load_aux_function <- list()
-      load_aux_function$functionID <- "load_aux"
-      load_aux_function$args <- list(deparse_name(dat), deparse_name(aux), name, 
-                                     over_write, project)
-      log_call(project, load_aux_function)
-
-      message("Auxiliary table saved to database.")
-      invisible(TRUE)
-
-    } else {
-
-      warning(paste("Table not saved.", paste0(project, name), 
-                    "exists in database, and overwrite is FALSE."))
-      invisible(FALSE)
-    }
   }
 }
 

R/fishset_fit.R

@@ -87,7 +87,11 @@ fishset_fit <- function(project,
   design <- full_design_list[[model_name]]
 
   # Load model fit list and check fit_name input
-  full_fit_list <- unserialize_table(paste0(project, "ModelFit"), project)
+  full_fit_list <- tryCatch({
+    unserialize_table(paste0(project, "ModelFit"), project)
+  }, error = function(e) {
+    list()
+  })
 
   if (is_empty(fit_name)) {
     fit_name <- paste0(model_name, "_fit")

R/format_model_data.R

@@ -91,6 +91,7 @@ format_model_data <- function(project,
                               gridded_data = NULL, 
                               grid_var_name = NULL, 
                               grid_time_var = NULL, 
+                              main_time_var = NULL,
                               expectations = NULL, 
                               distance = TRUE,
                               distance_units = NULL,
@@ -149,10 +150,15 @@ format_model_data <- function(project,
       select_vars_combined <- c(select_vars_combined, aux_key)
     }
 
-    # Check if grid_time_var is in the dataset and add to columns to filter
-    if (!is_empty(grid_time_var) && !(grid_time_var %in% select_vars_combined)) {
-      column_check(dataset, grid_time_var)
-      select_vars_combined <- c(select_vars_combined, grid_time_var)
+    # Check if main_time_var (or grid_time_var) is in the dataset and add to columns to filter
+    if (!is_empty(grid_time_var)) {
+      # Determine which variable in the MAIN dataset represents time
+      target_main_time <- if(!is.null(main_time_var)) main_time_var else grid_time_var
+
+      if(!is_empty(target_main_time) && !(target_main_time %in% select_vars_combined)){
+        column_check(dataset, target_main_time)
+        select_vars_combined <- c(select_vars_combined, target_main_time)
+      }
     }
 
     dataset <- dataset %>% select(all_of(select_vars_combined))
@@ -258,27 +264,51 @@ format_model_data <- function(project,
 
   # Add aux data ----------------------------------------------------------------------------------
   if (!is_empty(aux_data)) {
+    # FIX: Stop execution if aux_data is present but aux_key is missing
+    if (is.null(aux_key) || aux_key == "") {
+      stop("Auxiliary data was selected, but the join key ('aux_key') is missing.
+           Please select a variable to join on.")
+    }
+
     # Load aux data and check the aux_key
     aux_df <- table_view(aux_data, project)
     column_check(aux_df, aux_key)
     df <- left_join(df, aux_df, by = aux_key)
   }
 
-  # Add gridded data ------------------------------------------------------------------------------
-  # Load gridded_data
+ # Add gridded data ------------------------------------------------------------------------------
   if(!is_empty(gridded_data)){
-    gridded_df <- table_view(gridded_data, project)
-    column_check(gridded_df, grid_time_var)
+    if (is.null(grid_var_name) || grid_var_name == "") {
+        stop("Gridded data selected, but 'New Variable Name' is missing.")
+    }
 
-    # Pivot to long format
+    gridded_df <- table_view(gridded_data, project)
+     column_check(gridded_df, grid_time_var) 
+
+   # Pivot to long format
     gridded_df <- gridded_df %>%
       pivot_longer(cols = -all_of(grid_time_var),
                    names_to = "zones",
                    values_to = grid_var_name)
+
+    # Join Logic
+    # Determine the name of the time variable in the MAIN dataset
+    time_col_main <- if(!is.null(main_time_var)) main_time_var else grid_time_var
 
-    df <- left_join(df,
-                    gridded_df,
-                    by = c("zones",grid_time_var))
+    # Construct the join vector
+    if (!is.null(grid_time_var) && is.null(time_col_main)) {
+        stop("Gridded data has a time variable, but no matching time variable was 
+             found in the main dataset.")
+    }
+
+    join_cond <- c("zones" = "zones")
+    if (!is.null(grid_time_var)) {
+        join_cond <- c(join_cond, setNames(grid_time_var, time_col_main))
+    }
+
+    df <- left_join(df, 
+                    gridded_df, 
+                    by = join_cond)
   }
 
   # Check NAs and impute --------------------------------------------------------------------------
@@ -342,7 +372,25 @@ format_model_data <- function(project,
   df <- df %>%
     rename(!!zone_id := zones)
   # Save settings
-  settings <- as.list(match.call())[-1]
+   settings <- list(
+    project = project,
+    name = name,
+    alt_name = alt_name,
+    zone_id = zone_id,        
+    unique_obs_id = unique_obs_id,
+    select_vars = select_vars,
+    aux_data = aux_data,
+    aux_key = aux_key,
+    gridded_data = gridded_data,
+    grid_var_name = grid_var_name,
+    grid_time_var = grid_time_var,
+    main_time_var = main_time_var,
+    expectations = expectations,
+    distance = distance,
+    distance_units = distance_units,
+    crs = crs,
+    impute = impute
+  )
   # Save data and settings as a list
   df_list <- list(tmp_name = df,
                   tmp_settings = settings)

inst/ShinyFiles/MainApp/modules/format_data/create_expectations_module.R

@@ -20,12 +20,13 @@
 #' @param rv_folderpath A reactive value containing the path to the project folder.
 #' @param rv_project_name A reactive value containing the current project name.
 #' @param rv_data A reactiveValues object containing the loaded data frames.
-#' @param shared_alt_names A reactiveVal passed from the main server to share alt matrix names.
+#' @param rv_shared_alt_names A reactiveVal passed from the main server to share alt matrix names.
+#' @param rv_shared_exp_names A reactiveVal passed from the main server to share exp matrix names.
 #'
 #' @return This module does not return a value but saves an expectations matrix
 #'         to the project's database.
 create_expectations_server <- function(id, rv_folderpath, rv_project_name, rv_data,
-                                       shared_alt_names = NULL){
+                                       rv_shared_alt_names = NULL, rv_shared_exp_names = NULL){
   moduleServer(id, function(input, output, session){
     ns <- session$ns
 
@@ -39,7 +40,7 @@ create_expectations_server <- function(id, rv_folderpath, rv_project_name, rv_da
       table_name <- paste0(project, "ExpectedCatch")
 
       exp_mats <- list() # Default empty list
-      
+
       if (table_exists(table_name, project)) {
         tryCatch({
           exp_mats <- unserialize_table(table_name, project)
@@ -52,20 +53,27 @@ create_expectations_server <- function(id, rv_folderpath, rv_project_name, rv_da
       # Update the reactive value
       rv_existing_matrix_data(exp_mats)
 
+
+
       # Update the remove dropdown
       mat_names <- names(exp_mats)[!names(exp_mats) %in%
                                      c('scale', 'units') &
                                      !grepl("_dummy|_settings", names(exp_mats))]
       updateSelectizeInput(session, "matrix_to_remove", choices = mat_names, selected = "")
 
+         # Update SHARED value (for the other module)
+      if (!is.null(rv_shared_exp_names)) {
+        rv_shared_exp_names(mat_names) 
+      }
+
     }
 
     # Instead of querying the DB for alt names, we listen to the shared list
     observe({
-      req(shared_alt_names)
+      req(rv_shared_alt_names)
 
       # Get the names directly from the shared reactive
-      current_names <- shared_alt_names()
+      current_names <- rv_shared_alt_names()
 
       # Update the dropdown immediately
       updateSelectizeInput(session, "alt_name_input", 

inst/ShinyFiles/MainApp/modules/format_data/define_alternatives_module.R

@@ -14,11 +14,11 @@
 #' @param id A character string that is unique to this module instance.
 #' @param rv_project_name A reactive value containing the current project name.
 #' @param rv_data A reactiveValues object containing the loaded data frames.
-#' @param shared_alt_names A reactiveVal passed from the main server to share alt matrix names.
+#' @param rv_shared_alt_names A reactiveVal passed from the main server to share alt matrix names.
 #'
 #' @return This module does not return a value.
 define_alt_server <- function(id, rv_folderpath, rv_project_name, rv_data, 
-                              shared_alt_names = NULL){
+                              rv_shared_alt_names = NULL){
   moduleServer(id, function(input, output, session){
     ns <- session$ns
 
@@ -55,8 +55,8 @@ define_alt_server <- function(id, rv_folderpath, rv_project_name, rv_data,
       rv_existing_matrix_names(just_names)
 
       # Update SHARED value (for the other module)
-      if (!is.null(shared_alt_names)) {
-        shared_alt_names(just_names) 
+      if (!is.null(rv_shared_alt_names)) {
+        rv_shared_alt_names(just_names) 
       }
 
       # Update removal dropdown