R/io.R

In bivarhr: Bivariate Hurdle Regression with Bayesian Model Averaging

#' Export Results to an Excel Workbook
#'
#' Writes a named list of analysis results to a single \code{.xlsx}
#' workbook, one worksheet per result component, with basic formatting.
#' Requires the \pkg{openxlsx} package (listed under \code{Suggests}).
#'
#' @param results Named list containing analysis results.
#' @param output_path Full path for the output xlsx file.
#' @param verbose Logical; if TRUE, print progress messages.
#'
#' @return Invisible path to created file.
#'
#' @export
export_results_xlsx <- function(results, output_path, verbose = TRUE) {

  if (!requireNamespace("openxlsx", quietly = TRUE)) {
    stop("Package 'openxlsx' is required for export_results_xlsx(). Please install it.",
         call. = FALSE)
  }
  
  wb <- openxlsx::createWorkbook()
  
  write_sheet <- function(wb, sheet_name, df) {
    if (is.null(df) || !is.data.frame(df) || nrow(df) == 0) {
      df <- data.frame(info = "No data", stringsAsFactors = FALSE)
    }
    openxlsx::addWorksheet(wb, sheet_name)
    openxlsx::writeDataTable(wb, sheet_name, df)
    openxlsx::freezePane(wb, sheet_name, firstActiveRow = 2)
    openxlsx::setColWidths(wb, sheet_name, cols = seq_len(ncol(df)), widths = "auto")
    hdr_style <- openxlsx::createStyle(textDecoration = "bold")
    openxlsx::addStyle(wb, sheet_name, hdr_style, rows = 1, 
                       cols = seq_len(ncol(df)), gridExpand = TRUE)
  }
  
  format_numeric_cols <- function(wb, sheet_name, df, col_names) {
    if (is.null(df) || !is.data.frame(df) || nrow(df) == 0) return(invisible())
    cols_idx <- which(names(df) %in% col_names)
    if (length(cols_idx) == 0) return(invisible())
    num_style <- openxlsx::createStyle(numFmt = "0.000")
    openxlsx::addStyle(wb, sheet_name, num_style, 
                       rows = 2:(nrow(df) + 1), cols = cols_idx, gridExpand = TRUE)
  }
  
  if (!is.null(results$hurdle)) {
    write_sheet(wb, "Hurdle", results$hurdle)
    format_numeric_cols(wb, "Hurdle", results$hurdle, 
                        c("elpd", "elpd_se", "weight", "hs_tau0", "hs_slab_scale", "hs_slab_df"))
  }
  
  if (!is.null(results$te)) {
    write_sheet(wb, "TE", results$te)
    format_numeric_cols(wb, "TE", results$te, c("stat", "p_value", "q_value"))
  }
  
  if (!is.null(results$te_by_type)) {
    if (!is.null(results$te_by_type$counts)) {
      write_sheet(wb, "TE_COUNTS", results$te_by_type$counts)
      format_numeric_cols(wb, "TE_COUNTS", results$te_by_type$counts, 
                          c("stat", "p_value", "q_value"))
    }
    if (!is.null(results$te_by_type$rates)) {
      write_sheet(wb, "TE_RATES", results$te_by_type$rates)
      format_numeric_cols(wb, "TE_RATES", results$te_by_type$rates, 
                          c("stat", "p_value", "q_value"))
    }
    if (!is.null(results$te_by_type$binary)) {
      write_sheet(wb, "TE_BINARY", results$te_by_type$binary)
      format_numeric_cols(wb, "TE_BINARY", results$te_by_type$binary, 
                          c("stat", "p_value", "q_value"))
    }
  }
  
  if (!is.null(results$placebo)) {
    write_sheet(wb, "Placebo", results$placebo)
    format_numeric_cols(wb, "Placebo", results$placebo, 
                        c("elpd_orig", "elpd_perm", "diff"))
  }
  
  if (!is.null(results$tvarstar)) {
    write_sheet(wb, "TVARSTAR", results$tvarstar)
    format_numeric_cols(wb, "TVARSTAR", results$tvarstar, c("aic"))
  }
  
  if (!is.null(results$varx)) {
    write_sheet(wb, "VARX", results$varx)
    format_numeric_cols(wb, "VARX", results$varx, 
                        c("AIC", "BIC", "p_serial", "p_normal", "p_arch"))
  }
  
  if (!is.null(results$eba)) {
    write_sheet(wb, "EBA", results$eba)
  }
  
  if (!is.null(results$dbn_arcs)) {
    write_sheet(wb, "DBN_arcs", results$dbn_arcs)
  }
  
  if (!is.null(results$hmm)) {
    if (!is.null(results$hmm$counts_by_state)) {
      write_sheet(wb, "HMM_counts", results$hmm$counts_by_state)
    }
    if (!is.null(results$hmm$dwell_stats)) {
      write_sheet(wb, "HMM_dwell", results$hmm$dwell_stats)
    }
  }
  
  if (!is.null(results$sensemakr_I)) {
    write_sheet(wb, "Sensemakr_I", results$sensemakr_I)
  }
  
  if (!is.null(results$sensemakr_C)) {
    write_sheet(wb, "Sensemakr_C", results$sensemakr_C)
  }
  
  if (!is.null(results$oos)) {
    write_sheet(wb, "OOS", results$oos$table)
  }
  
  if (!is.null(results$ate)) {
    write_sheet(wb, "ATE", results$ate$last)
  }
  
  openxlsx::saveWorkbook(wb, output_path, overwrite = TRUE)
  
  if (verbose) message("Excel saved to: ", output_path)
  invisible(output_path)
}


#' Export Analysis Results
#'
#' Exports analysis results to Excel and/or CSV format.
#'
#' @param results Named list containing analysis results. Expected components
#'   include: hurdle, te, te_by_type (list with counts/rates/binary), placebo,
#'   tvarstar, varx, eba, dbn_arcs, hmm, sensemakr_I, sensemakr_C, oos, ate.
#' @param output_dir Directory path for output files. Created if it does not exist.
#' @param format Character; output format. One of "xlsx", "csv", or "both".
#' @param verbose Logical; if TRUE, print progress messages.
#'
#' @return Invisible path to output directory.
#'
#' @export
#'
#' @examples
#' results <- list(
#'   hurdle = data.frame(model = "test", elpd = -100),
#'   te = data.frame(dir = "I->C", stat = 0.5, p_value = 0.01)
#' )
#'
#' # CSV export uses only imported packages and always works:
#' export_results(results, tempdir(), format = "csv", verbose = FALSE)
#'
#' # Excel export additionally requires the 'openxlsx' package:
#' if (requireNamespace("openxlsx", quietly = TRUE)) {
#'   export_results(results, tempdir(), format = "xlsx", verbose = FALSE)
#' }
export_results <- function(results, output_dir, format = "xlsx", verbose = TRUE) {
  
  format <- match.arg(format, c("xlsx", "csv", "both"))
  
  if (!dir.exists(output_dir)) {
    dir.create(output_dir, recursive = TRUE)
  }
  
  if (format %in% c("xlsx", "both")) {
    xlsx_path <- file.path(output_dir, "results_summary.xlsx")
    export_results_xlsx(results, xlsx_path, verbose = verbose)
  }
  
  if (format %in% c("csv", "both")) {
    
    if (!requireNamespace("readr", quietly = TRUE)) {
      stop("Package 'readr' required for CSV export. Install with: install.packages('readr')")
    }
    
    write_csv_safe <- function(df, path) {
      if (!is.null(df) && is.data.frame(df) && nrow(df) > 0) {
        readr::write_csv(df, path)
      }
    }
    
    write_csv_safe(results$hurdle, file.path(output_dir, "summary_hurdle.csv"))
    write_csv_safe(results$te, file.path(output_dir, "summary_te.csv"))
    
    if (!is.null(results$te_by_type)) {
      write_csv_safe(results$te_by_type$counts, 
                     file.path(output_dir, "summary_te_counts.csv"))
      write_csv_safe(results$te_by_type$rates, 
                     file.path(output_dir, "summary_te_rates.csv"))
      write_csv_safe(results$te_by_type$binary, 
                     file.path(output_dir, "summary_te_binary.csv"))
    }
    
    write_csv_safe(results$placebo, file.path(output_dir, "summary_placebo.csv"))
    write_csv_safe(results$tvarstar, file.path(output_dir, "summary_tvarstar.csv"))
    write_csv_safe(results$varx, file.path(output_dir, "summary_varx.csv"))
    write_csv_safe(results$eba, file.path(output_dir, "summary_eba.csv"))
    write_csv_safe(results$dbn_arcs, file.path(output_dir, "summary_dbn_arcs.csv"))
    
    if (!is.null(results$hmm)) {
      write_csv_safe(results$hmm$counts_by_state, 
                     file.path(output_dir, "summary_hmm_counts.csv"))
      write_csv_safe(results$hmm$dwell_stats, 
                     file.path(output_dir, "summary_hmm_dwell.csv"))
    }
    
    write_csv_safe(results$sensemakr_I, file.path(output_dir, "summary_sensemakr_I.csv"))
    write_csv_safe(results$sensemakr_C, file.path(output_dir, "summary_sensemakr_C.csv"))
    
    if (!is.null(results$oos)) {
      write_csv_safe(results$oos$table, file.path(output_dir, "summary_oos.csv"))
    }
    
    if (!is.null(results$ate)) {
      write_csv_safe(results$ate$last, file.path(output_dir, "summary_ate.csv"))
    }
    
    if (verbose) message("CSVs saved to: ", output_dir)
  }
  
  invisible(output_dir)
}


#' Load Saved Results from Directory
#'
#' Loads previously saved .rds result files from a specified directory.
#'
#' @param dir_out Directory containing saved .rds files.
#' @param which Character vector specifying which results to load. Valid options:
#'   "varx", "tsdyn", "bma", "dbn", "hmm", "sensemakr", "synth".
#'   Default loads all available.
#' @param verbose Logical; if TRUE, print messages about loaded files.
#'
#' @return Named list of loaded objects. Components not found are NULL.
#'
#' @export
#'
#' @examples
#' \donttest{
#' # 1. Create a temporary directory (CRAN safe)
#' tmp_dir <- file.path(tempdir(), "test_results")
#' dir.create(tmp_dir, showWarnings = FALSE)
#' 
#' # 2. Create dummy data files matching the names expected by the function
#' saveRDS(list(aic = 100), file.path(tmp_dir, "varx_fit.rds"))
#' saveRDS(list(model = "BMA"), file.path(tmp_dir, "best_fit_bma.rds"))
#' 
#' # 3. Load the results (this will now work correctly)
#' results <- load_saved_results(tmp_dir, which = c("varx", "bma"))
#' 
#' # 4. Clean up
#' unlink(tmp_dir, recursive = TRUE)
#' }
load_saved_results <- function(dir_out, 
                               which = c("varx", "tsdyn", "bma", "dbn", 
                                         "hmm", "sensemakr", "synth"),
                               verbose = TRUE) {
  
  if (!dir.exists(dir_out)) {
    stop("Directory does not exist: ", dir_out)
  }
  
  file_map <- c(
    varx = "varx_fit.rds",
    tsdyn = "tsdyn_res.rds",
    bma = "best_fit_bma.rds",
    dbn = "dbn_fit.rds",
    hmm = "hmm_fit.rds",
    sensemakr = "sensemakr_res.rds",
    synth = "synth_bsts_res.rds",
    scalers = "scalers_continuas.rds",
    all = "experimento_mejorado_all.rds"
  )
  
  results <- list()
  loaded <- character(0)
  not_found <- character(0)
  
  for (nm in which) {
    if (nm %in% names(file_map)) {
      fpath <- file.path(dir_out, file_map[[nm]])
      if (file.exists(fpath)) {
        results[[nm]] <- readRDS(fpath)
        loaded <- c(loaded, nm)
      } else {
        results[[nm]] <- NULL
        not_found <- c(not_found, nm)
      }
    }
  }
  
  if (verbose) {
    if (length(loaded) > 0) {
      message("Loaded: ", paste(loaded, collapse = ", "))
    }
    if (length(not_found) > 0) {
      message("Not found: ", paste(not_found, collapse = ", "))
    }
  }
  
  results
}