R/extractor.R

In bivarhr: Bivariate Hurdle Regression with Bayesian Model Averaging

#' Normalize character names by stripping BOM and NBSP
#'
#' Removes common problematic Unicode characters from a character
#' vector (Byte Order Mark and non-breaking spaces) and trims leading
#' and trailing whitespace.
#'
#' @param x Character vector (e.g., column names) to normalize.
#'
#' @return A character vector with BOM and non-breaking spaces removed
#'   and surrounding whitespace trimmed.
#'
#' @keywords internal

normalize_names <- function(x){
  x <- gsub("\uFEFF", "", x, perl = TRUE)   # BOM
  x <- gsub("\u00A0", " ", x,  perl = TRUE) # NBSP
  trimws(x)
}

#' Read CSV with automatic delimiter detection
#'
#' Attempts to read a CSV file using several strategies, trying to
#' infer whether the delimiter is a comma or a semicolon. It first
#' tries \code{readr::read_csv()}, optionally falls back to
#' \code{readr::read_csv2()} when a semicolon is detected or the first
#' attempt fails, and finally tries base \code{utils::read.csv()} as a
#' last resort.
#'
#' @param fp Character scalar; path to the CSV file.
#'
#' @return A data frame if a valid non-empty table could be read, or
#'   \code{NULL} if all attempts fail.
#'
#' @keywords internal

rc_auto <- function(fp){
  df <- try(readr::read_csv(fp, show_col_types = FALSE), silent = TRUE)
  ok <- is.data.frame(df) && ncol(df) > 0
  if (ok && nrow(df) > 0) return(df)
  
  first_line <- try(readLines(fp, n = 1L, warn = FALSE), silent = TRUE)
  has_semicolon <- !inherits(first_line, "try-error") && grepl(";", first_line, fixed = TRUE)
  
  if (!ok || has_semicolon) {
    df2 <- try(readr::read_csv2(fp, show_col_types = FALSE), silent = TRUE)
    if (is.data.frame(df2) && ncol(df2) > 0 && nrow(df2) > 0) return(df2)
  }
  
  sep <- if (has_semicolon) ";" else ","
  df3 <- try(utils::read.csv(fp, sep = sep, check.names = FALSE), silent = TRUE)
  if (is.data.frame(df3) && ncol(df3) > 0 && nrow(df3) > 0) return(df3)
  
  NULL
}

#' Read and consolidate BMA weight tables
#'
#' Searches for BMA weight CSV files produced by the Hurdle-NB model,
#' reads them using automatic delimiter detection, and returns a single
#' stacked data frame with normalized column names and a combo
#' identifier.
#'
#' @param dir_csv Character scalar; directory where BMA CSV files are
#'   expected (for example \code{"bma_weights_specC_ctrl*.csv"}).
#' @param dir_out Character scalar; output directory used during the
#'   experiment, which may contain BMA files or a fallback RDS object.
#' @param stop_if_empty Logical; if \code{TRUE}, an informative error
#'   is thrown when no valid BMA tables are found. If \code{FALSE}, a
#'   warning is issued and an empty tibble is returned.
#' @param verbose Logical; if \code{TRUE}, prints diagnostic messages
#'   about the search paths, files found, and detected ELPD column.
#'
#' @details
#' The function:
#' \itemize{
#'   \item Looks for CSV files matching the pattern
#'     \code{"bma_weights_specC_ctrl*.csv"} in \code{dir_csv}, and if
#'     none are found, searches recursively in \code{dir_out}.
#'   \item Reads each candidate file via \code{rc_auto()} and keeps only
#'     non-empty data frames.
#'   \item If no CSV files are usable, optionally falls back to an RDS
#'     file \code{"experimento_mejorado_all.rds"} under \code{dir_out}
#'     and tries to extract BMA tables from \code{allobj$bma}.
#'   \item Normalizes column names with \code{normalize_names()}, ensures
#'     a \code{combo} column exists, detects the ELPD column, and sorts
#'     rows by decreasing ELPD.
#' }
#'
#' @return A data frame with all BMA tables stacked and an added
#'   \code{combo_id} column (source identifier) and a \code{combo}
#'   column (control combo). If nothing is found and
#'   \code{stop_if_empty = FALSE}, an empty tibble is returned.
#'
#' @export

read_bma_all <- function(dir_csv, dir_out, stop_if_empty = TRUE, verbose = TRUE){
  if (verbose) {
    message(">> read_bma_all(): getwd() = ", getwd())
    message(">> dir_csv = ", dir_csv, " | existe = ", dir.exists(dir_csv))
  }
  
  pat <- utils::glob2rx("bma_weights_specC_ctrl*.csv")
  
  bma_files <- list.files(dir_csv, pattern = pat, full.names = TRUE)
  if (!length(bma_files)) {
    if (verbose) message(">> No CSV found in dir_csv; searching recursively in ", dir_out)
    bma_files <- list.files(dir_out, pattern = pat, full.names = TRUE, recursive = TRUE)
  }
  if (verbose) {
    message(">> Candidate files: ", length(bma_files))
    if (length(bma_files)) message("   Examples: ", paste(utils::head(bma_files, 3), collapse = " | "))
  }
  
  bma_tabs <- lapply(bma_files, rc_auto)
  names(bma_tabs) <- sub("^bma_weights_specC_ctrl(.*)\\.csv$", "\\1", basename(bma_files))
  bma_tabs <- Filter(function(x) is.data.frame(x) && nrow(x) > 0, bma_tabs)
  if (verbose) message(">> Valid CSV tables (with rows): ", length(bma_tabs))
  
  if (!length(bma_tabs)) {
    rds_path <- file.path(dir_out, "improved_experiment_all.rds")
    if (verbose) message(">> Attempting RDS fallback: ", rds_path, " | exists = ", file.exists(rds_path))
    if (file.exists(rds_path)) {
      allobj <- readRDS(rds_path)
      if (!is.null(allobj$bma) && length(allobj$bma)) {
        bma_tabs <- lapply(names(allobj$bma), function(tag) {
          tb <- try(allobj$bma[[tag]]$table, silent = TRUE)
          if (inherits(tb, "try-error") || is.null(tb) || !nrow(tb)) return(NULL)
          tb$combo <- tag
          tb
        })
        bma_tabs <- Filter(Negate(is.null), bma_tabs)
        names(bma_tabs) <- vapply(bma_tabs, function(tb) unique(tb$combo)[1], "")
      }
    }
  }
  
  if (!length(bma_tabs)) {
    msg <- paste0(
      "No BMA tables were found.\n",
      "- getwd(): ", getwd(), "\n",
      "- dir_csv: ", dir_csv, " (exists=", dir.exists(dir_csv), ")\n",
      "- Suggestion: print(dir_csv); list.files(dir_csv); ",
      "length(list.files(dir_csv, pattern=utils::glob2rx('bma_weights_specC_ctrl*.csv')))"
    )
    if (stop_if_empty) stop(msg) else {
      warning(msg)
      return(dplyr::tibble())
    }
  }
  
  bma_all <- dplyr::bind_rows(bma_tabs, .id = "combo_id")
  names(bma_all) <- normalize_names(names(bma_all))
  if (!"combo" %in% names(bma_all)) {
    bma_all$combo <- bma_all$combo_id
  }
  if (verbose) {
    message(">> bma_all: nrow=", nrow(bma_all), " ncol=", ncol(bma_all))
    message(">> Columns: ", paste(utils::head(names(bma_all), 20), collapse = " | "))
  }
  
  raw_names <- names(bma_all)
  norm <- tolower(gsub("[^a-z0-9]+", "", raw_names))
  candidates_norm <- c("elpd","elpdloo","estimate")
  hit_idx <- which(norm %in% candidates_norm)
  if (!length(hit_idx)) {
    hit_idx <- which(grepl("elpd", norm, fixed = TRUE))
  }
  if (!length(hit_idx)) {
    msg <- paste0("No ELPD column found in bma_all. Names =",
                  paste(raw_names, collapse = ", "))
    if (stop_if_empty) stop(msg) else {
      warning(msg)
      return(dplyr::tibble())
    }
  }
  elpd_col <- raw_names[hit_idx[1]]
  if (verbose) message(">> Using ELPD column: '", elpd_col, "'")
  
  bma_all <- bma_all %>%
    dplyr::mutate(elpd = suppressWarnings(as.numeric(.data[[elpd_col]]))) %>%
    dplyr::arrange(dplyr::desc(.data$elpd))
  
  bma_all
}

#' Add a worksheet to an Excel workbook with flexible content
#'
#' Convenience helper that adds a worksheet to a global workbook
#' object and writes either a single data frame, or a nested list of
#' objects (data frames or other structures) in a readable layout.
#'
#' @param name Character scalar; name of the worksheet to add.
#' @param df Either a data frame to write directly, or a list whose
#'   elements can be data frames, lists of data frames, or arbitrary
#'   R objects. Non-data-frame objects are written using the output of
#'   \code{str()}.
#'
#' @details
#' This function assumes that a global \code{wb} object exists (an
#' \pkg{openxlsx} workbook). When \code{df} is a list, it iterates over
#' list elements and writes labeled sections for each element and its
#' sub-elements.
#'
#' If \code{df} is \code{NULL}, a one-row data frame with the message
#' \code{"Sin datos"} is written.
#'
#' @return Invisibly returns \code{NULL}. The workbook \code{wb} is
#'   modified in place.
#'
#' @keywords internal

add_sheet <- function(name, df){
  openxlsx::addWorksheet(wb, name)
  if (is.null(df)) {
    openxlsx::writeData(wb, name, data.frame(info="No data")); return()
  }
  if (is.list(df) && !is.data.frame(df)) {
    r <- 1
    for (nm in names(df)) {
      openxlsx::writeData(wb, name, paste0("<< ", nm, " >>"), startRow = r, colNames = FALSE)
      r <- r + 1
      obj <- df[[nm]]
      if (is.data.frame(obj)) {
        openxlsx::writeDataTable(wb, name, obj, startRow = r); r <- r + nrow(obj) + 3
      } else if (is.list(obj) && all(sapply(obj, is.data.frame))) {
        for (subnm in names(obj)) {
          openxlsx::writeData(wb, name, paste0("  - ", subnm), startRow = r, colNames = FALSE); r <- r + 1
          openxlsx::writeDataTable(wb, name, obj[[subnm]], startRow = r); r <- r + nrow(obj[[subnm]]) + 2
        }
      } else {
        tmp <- capture.output(str(obj))
        openxlsx::writeData(wb, name, tmp, startRow = r, colNames = FALSE)
        r <- r + length(tmp) + 2
      }
    }
  } else {
    openxlsx::writeDataTable(wb, name, df)
  }
}