R/00_internal_helpers.R

In tinyarray: Expression Data Analysis and Visualization

.tinyarray_lazy_factory <- function(pkg, fun) {
  force(pkg)
  force(fun)
  cached <- NULL
  function(...) {
    if (is.null(cached)) {
      if (!requireNamespace(pkg, quietly = TRUE)) {
        stop("Package \"", pkg, "\" needed for this function to work.", call. = FALSE)
      }
      cached <<- getExportedValue(pkg, fun)
    }
    call <- match.call()
    call[[1L]] <- quote(.tinyarray_lazy_target)
    eval(
      call,
      envir = list2env(
        list(.tinyarray_lazy_target = cached),
        parent = parent.frame()
      )
    )
  }
}

.tinyarray_register_lazy_functions <- function() {
  ns <- environment(.tinyarray_register_lazy_functions)
  lazy_map <- list(
    dplyr = c("arrange", "case_when", "desc", "distinct", "inner_join", "mutate"),
    ggplot2 = c(
      "aes", "aes_string", "after_stat", "coord_flip", "element_blank",
      "element_line", "element_rect", "element_text", "facet_grid",
      "geom_bar", "geom_boxplot", "geom_density", "geom_histogram",
      "geom_hline", "geom_point", "geom_tile", "geom_vline", "ggplot",
      "ggsave", "labs", "scale_color_manual", "scale_fill_gradient2",
      "scale_fill_manual", "scale_x_continuous", "scale_x_discrete",
      "scale_y_continuous", "stat_boxplot", "stat_ellipse", "theme",
      "theme_bw", "theme_classic", "theme_light", "theme_void", "unit",
      "ylim"
    ),
    Hmisc = c("rcorr"),
    limma = c("contrasts.fit", "eBayes", "lmFit", "makeContrasts", "topTable"),
    patchwork = c("plot_layout", "plot_spacer", "wrap_plots"),
    pheatmap = c("pheatmap"),
    stringr = c(
      "str_detect", "str_extract", "str_remove", "str_remove_all",
      "str_split", "str_starts", "str_sub", "str_to_lower", "str_to_upper",
      "str_wrap"
    ),
    survival = c("Surv", "coxph", "survdiff", "survfit"),
    survminer = c("ggsurvplot", "surv_cutpoint"),
    tibble = c("rownames_to_column", "tibble")
  )
  for (pkg in names(lazy_map)) {
    for (fun in lazy_map[[pkg]]) {
      assign(fun, .tinyarray_lazy_factory(pkg, fun), envir = ns)
    }
  }
  invisible(TRUE)
}

.tinyarray_register_lazy_functions()

.tinyarray_has_pkgs <- function(...) {
  pkgs <- unlist(list(...), use.names = FALSE)
  if (!length(pkgs)) {
    return(TRUE)
  }
  all(vapply(pkgs, requireNamespace, logical(1), quietly = TRUE))
}

.tinyarray_prepare_group_list <- function(group_list, arg = "group_list", min_levels = 2L) {
  if (!is.factor(group_list)) {
    group_list <- suppressWarnings(factor(group_list, levels = unique(group_list)))
  } else {
    group_list <- droplevels(group_list)
  }
  if (nlevels(group_list) < min_levels) {
    stop(arg, " must contain at least ", min_levels, " groups", call. = FALSE)
  }
  group_list
}

.tinyarray_prepare_group_list_safe <- function(group_list, arg = "group_list", min_levels = 2L) {
  tryCatch(
    .tinyarray_prepare_group_list(group_list, arg = arg, min_levels = min_levels),
    error = function(e) {
      warning(conditionMessage(e), call. = FALSE)
      NULL
    }
  )
}

.tinyarray_order_columns_by_group <- function(exp, group_list) {
  ord <- order(group_list, seq_along(group_list))
  list(
    exp = exp[, ord, drop = FALSE],
    group_list = group_list[ord]
  )
}

.tinyarray_safe_heatmap_clusters <- function(nrow_value,
                                             ncol_value,
                                             cluster_rows = TRUE,
                                             cluster_cols = TRUE) {
  list(
    cluster_rows = isTRUE(cluster_rows) && isTRUE(nrow_value > 1L),
    cluster_cols = isTRUE(cluster_cols) && isTRUE(ncol_value > 1L)
  )
}

.tinyarray_safe_heatmap_breaks <- function(mat, n_breaks = 100L) {
  n_breaks <- max(2L, as.integer(n_breaks)[1L])
  vals <- as.numeric(mat)
  vals <- vals[is.finite(vals)]
  if (!length(vals)) {
    return(seq(0, 1, length.out = n_breaks))
  }
  rng <- range(vals)
  if (!is.finite(rng[1L]) || !is.finite(rng[2L])) {
    return(seq(0, 1, length.out = n_breaks))
  }
  if (identical(rng[1L], rng[2L])) {
    delta <- if (rng[1L] == 0) 0.5 else max(abs(rng[1L]) * 0.01, .Machine$double.eps)
    rng <- c(rng[1L] - delta, rng[2L] + delta)
  }
  seq(rng[1L], rng[2L], length.out = n_breaks)
}

.tinyarray_bundle_plots <- function(...) {
  plots <- list(...)
  plots <- plots[!vapply(plots, is.null, logical(1))]
  if (!length(plots)) {
    return(NULL)
  }
  if (length(plots) == 1L) {
    return(plots[[1L]])
  }
  patchwork::wrap_plots(plots) + patchwork::plot_layout(guides = "collect")
}

.tinyarray_geo_drop_redundant_columns <- function(pd,
                                                  drop_url = TRUE,
                                                  drop_characteristics = FALSE) {
  if (!is.data.frame(pd)) {
    pd <- as.data.frame(pd, stringsAsFactors = FALSE, check.names = FALSE)
  }
  if (!ncol(pd)) {
    return(pd[, , drop = FALSE])
  }
  keep <- rep(TRUE, ncol(pd))
  if (isTRUE(drop_characteristics)) {
    # Drop the raw GEOquery characteristics columns, but keep the derived
    # `something:ch1` columns that carry the cleaned sample annotations.
    keep <- keep & !grepl("^characteristics_ch1(\\.|$)", colnames(pd), ignore.case = TRUE)
  }

  if (drop_url) {
    urlish <- vapply(
      pd,
      function(x) {
        non_na <- as.character(x)
        non_na <- non_na[!is.na(non_na) & nzchar(non_na)]
        length(non_na) > 0L && all(grepl("^(https?|ftp)://|^www\\.", non_na, ignore.case = TRUE))
      },
      logical(1)
    )
    keep[urlish] <- FALSE
  }

  if (!any(keep)) {
    return(pd[, 0, drop = FALSE])
  }

  pd[, keep, drop = FALSE]
}

.tinyarray_pvalue_column <- function(adjust = FALSE) {
  if (adjust) "padj" else "P.value"
}

.tinyarray_orgdb_for_species <- function(species) {
  species <- tolower(species)
  if (species == "human") {
    pkg <- "org.Hs.eg.db"
    kegg <- "hsa"
  } else if (species == "mouse") {
    pkg <- "org.Mm.eg.db"
    kegg <- "mmu"
  } else if (species == "rat") {
    pkg <- "org.Rn.eg.db"
    kegg <- "rno"
  } else {
    stop("species should be one of human, mouse, rat", call. = FALSE)
  }
  if (!requireNamespace(pkg, quietly = TRUE)) {
    stop("Package \"", pkg, "\" needed for this function to work.", call. = FALSE)
  }
  list(pkg = pkg, kegg = kegg, orgdb = getExportedValue(pkg, pkg))
}

.tinyarray_require_clusterProfiler <- function() {
  if (!requireNamespace("clusterProfiler", quietly = TRUE)) {
    stop(
      "Package \"clusterProfiler\" needed for this function to work. ",
      "Please install it by install.packages('clusterProfiler') or ",
      "BiocManager::install('clusterProfiler')",
      call. = FALSE
    )
  }
  invisible(TRUE)
}

.tinyarray_dedup_by_key <- function(df, key) {
  if (!key %in% colnames(df)) {
    stop("column `", key, "` not found", call. = FALSE)
  }
  df <- df[!is.na(df[[key]]), , drop = FALSE]
  df <- df[!duplicated(df[[key]]), , drop = FALSE]
  df
}

.tinyarray_pick_probe_symbol_columns <- function(x) {
  if (is.null(x)) {
    return(NULL)
  }
  nms <- names(x)
  if (is.null(nms)) {
    nms <- rep("", ncol(x))
  }
  norm <- tolower(gsub("[^a-z0-9]+", "", nms))
  probe_candidates <- c("probe_id", "probeid", "idref", "id", "probe", "probesetid")
  symbol_candidates <- c("symbol", "symbols", "genesymbol", "genename", "genes")

  probe_idx <- which(norm %in% probe_candidates)
  symbol_idx <- which(norm %in% symbol_candidates)

  if (length(probe_idx) && length(symbol_idx)) {
    return(c(probe_idx[1L], symbol_idx[1L]))
  }
  if (length(probe_idx) && ncol(x) >= 2L) {
    other <- setdiff(seq_len(ncol(x)), probe_idx[1L])
    if (length(other)) {
      return(c(probe_idx[1L], other[1L]))
    }
  }
  if (length(symbol_idx) && ncol(x) >= 2L) {
    other <- setdiff(seq_len(ncol(x)), symbol_idx[1L])
    if (length(other)) {
      return(c(other[1L], symbol_idx[1L]))
    }
  }
  if (ncol(x) >= 2L) {
    return(1:2)
  }
  NULL
}

.tinyarray_standardize_probe_symbol_table <- function(x) {
  if (is.null(x)) {
    return(NULL)
  }
  if (!is.data.frame(x)) {
    x <- as.data.frame(x, stringsAsFactors = FALSE)
  }
  cols <- .tinyarray_pick_probe_symbol_columns(x)
  if (is.null(cols) || length(cols) < 2L) {
    stop("annotation table must have at least 2 columns", call. = FALSE)
  }
  x <- x[, cols[1:2], drop = FALSE]
  colnames(x) <- c("probe_id", "symbol")
  x$probe_id <- as.character(x$probe_id)
  x$symbol <- as.character(x$symbol)
  keep <- !is.na(x$probe_id) & nzchar(x$probe_id) &
    !is.na(x$symbol) & nzchar(x$symbol)
  x <- x[keep, , drop = FALSE]
  x <- unique(x)
  rownames(x) <- NULL
  x
}

.tinyarray_ensembl_annotation_table <- function(exp, species = "human") {
  org <- .tinyarray_orgdb_for_species(species)
  ensembl_ids <- unique(as.character(rownames(exp)))
  anno <- AnnotationDbi::select(
    org$orgdb,
    keys = ensembl_ids,
    columns = c("SYMBOL", "GENETYPE"),
    keytype = "ENSEMBL"
  )
  anno <- anno[!is.na(anno$ENSEMBL) & nzchar(anno$ENSEMBL) &
                 !is.na(anno$SYMBOL) & nzchar(anno$SYMBOL), ,
               drop = FALSE]
  anno$ENSEMBL <- as.character(anno$ENSEMBL)
  anno$SYMBOL <- as.character(anno$SYMBOL)
  anno$GENETYPE <- as.character(anno$GENETYPE)
  unique(anno)
}

.tinyarray_read_cache <- function(file, object = NULL) {
  tryCatch(
    readRDS(file),
    error = function(rds_error) {
      cache_env <- new.env(parent = emptyenv())
      loaded <- tryCatch(
        load(file, envir = cache_env),
        error = function(load_error) {
          stop("Unable to read cache file as RDS or RData: ", file, call. = FALSE)
        }
      )
      if (!is.null(object)) {
        candidates <- unique(as.character(object))
        found <- candidates[candidates %in% loaded]
        if (!length(found)) {
          stop(
            "Cached object `", paste(candidates, collapse = "`, `"),
            "` not found in ", file,
            call. = FALSE
          )
        }
        return(get(found[[1L]], envir = cache_env, inherits = FALSE))
      }
      if (length(loaded) == 1L) {
        return(get(loaded, envir = cache_env, inherits = FALSE))
      }
      mget(loaded, envir = cache_env, inherits = FALSE)
    }
  )
}

.tinyarray_collapse_mean_rows <- function(exp, groups) {
  exp <- as.matrix(exp)
  keep <- !is.na(groups) & groups != ""
  if (!any(keep)) {
    return(exp[0, , drop = FALSE])
  }
  groups <- as.character(groups[keep])
  exp <- exp[keep, , drop = FALSE]
  split_idx <- split(seq_along(groups), factor(groups, levels = unique(groups)))
  collapsed <- t(vapply(split_idx, function(idx) {
    colMeans(exp[idx, , drop = FALSE], na.rm = TRUE)
  }, numeric(ncol(exp))))
  rownames(collapsed) <- names(split_idx)
  collapsed
}

.tinyarray_kegg_term_cache <- new.env(parent = emptyenv())

.tinyarray_resolve_orgdb <- function(OrgDb) {
  if (is.character(OrgDb) && length(OrgDb) == 1L) {
    if (!requireNamespace(OrgDb, quietly = TRUE)) {
      stop("Package \"", OrgDb, "\" needed for this function to work.", call. = FALSE)
    }
    OrgDb <- getExportedValue(OrgDb, OrgDb)
  }
  OrgDb
}

.tinyarray_annoprobe_type_candidates <- function() {
  c("bioc", "soft", "pipe")
}

.tinyarray_dput_string <- function(x) {
  paste(utils::capture.output(dput(x)), collapse = "\n")
}

.tinyarray_with_suppressed_download <- function(expr) {
  result <- NULL
  utils::capture.output({
    result <- force(expr)
  })
  result
}

.tinyarray_run_annoprobe_idmap <- function(gpl, type, destdir = tempdir(), mirror = "tencent") {
  if (!requireNamespace("AnnoProbe", quietly = TRUE)) {
    return(NULL)
  }
  .tinyarray_with_suppressed_download(
    tryCatch(
      suppressMessages(suppressWarnings(
        AnnoProbe::idmap(gpl = gpl, type = type, mirror = mirror, destdir = destdir)
      )),
      error = function(e) e
    )
  )
}

.tinyarray_try_annoprobe_idmap <- function(gpl, type = NULL, destdir = tempdir(), mirror = "tencent") {
  if (!requireNamespace("AnnoProbe", quietly = TRUE)) {
    return(NULL)
  }
  requested <- if (is.null(type)) character() else unique(as.character(type))
  types <- unique(c(requested, .tinyarray_annoprobe_type_candidates()))
  types <- types[nzchar(types)]
  if (!length(types)) {
    return(NULL)
  }
  errors <- list()
  for (tp in types) {
    res <- .tinyarray_run_annoprobe_idmap(gpl = gpl, type = tp, destdir = destdir, mirror = mirror)
    if (is.data.frame(res) || is.matrix(res)) {
      return(list(
        data = res,
        type = tp,
        code = paste0("ids <- AnnoProbe::idmap(\"", gpl, "\", type = \"", tp, "\")"),
        errors = errors
      ))
    }
    errors[[tp]] <- if (inherits(res, "error")) {
      conditionMessage(res)
    } else {
      paste("unexpected result class:", paste(class(res), collapse = "/"))
    }
  }
  structure(
    list(
      errors = errors,
      tried = types
    ),
    class = "tinyarray_annoprobe_failure"
  )
}

.tinyarray_bioc_annotation_code <- function(pkg) {
  paste0(
    "library(",
    pkg,
    ".db); ids <- toTable(",
    pkg,
    "SYMBOL)"
  )
}

.tinyarray_kegg_term_tables <- function(OrgDb, species) {
  species <- tolower(species)
  cache_key <- paste0(species, "::", paste(class(OrgDb), collapse = "/"))
  if (exists(cache_key, envir = .tinyarray_kegg_term_cache, inherits = FALSE)) {
    return(get(cache_key, envir = .tinyarray_kegg_term_cache, inherits = FALSE))
  }
  OrgDb <- .tinyarray_resolve_orgdb(OrgDb)
  gene_ids <- AnnotationDbi::keys(OrgDb, keytype = "ENTREZID")
  term2gene <- tryCatch(
    suppressWarnings(
      clusterProfiler::bitr(
        gene_ids,
        fromType = "ENTREZID",
        toType = "PATH",
        OrgDb = OrgDb,
        drop = FALSE
      )
    ),
    error = function(e) NULL
  )
  if (is.null(term2gene) || !nrow(term2gene)) {
    assign(cache_key, NULL, envir = .tinyarray_kegg_term_cache)
    return(NULL)
  }
  term2gene <- term2gene[!is.na(term2gene$PATH) & nzchar(term2gene$PATH), c("PATH", "ENTREZID"), drop = FALSE]
  if (!nrow(term2gene)) {
    assign(cache_key, NULL, envir = .tinyarray_kegg_term_cache)
    return(NULL)
  }
  term2gene <- unique(term2gene)
  term2gene$PATH <- paste0(.tinyarray_orgdb_for_species(species)$kegg, term2gene$PATH)
  colnames(term2gene) <- c("term", "gene")
  term2name <- unique(term2gene["term"])
  term2name$name <- term2name$term
  res <- list(term2gene = term2gene, term2name = term2name)
  assign(cache_key, res, envir = .tinyarray_kegg_term_cache)
  res
}

.tinyarray_extid2symbol <- function(OrgDb, gene_ids, keytype) {
  OrgDb <- .tinyarray_resolve_orgdb(OrgDb)
  gene_ids <- unique(as.character(gene_ids))
  if (length(gene_ids) == 0L) {
    return(stats::setNames(character(), character()))
  }
  gn.df <- suppressWarnings(
    clusterProfiler::bitr(
      gene_ids,
      fromType = keytype,
      toType = "SYMBOL",
      OrgDb = OrgDb,
      drop = FALSE
    )
  )
  if (!is.data.frame(gn.df) || nrow(gn.df) == 0L) {
    return(stats::setNames(gene_ids, gene_ids))
  }
  gn.df <- unique(gn.df[, c(keytype, "SYMBOL"), drop = FALSE])
  gn.df <- gn.df[!is.na(gn.df[[keytype]]) & !is.na(gn.df$SYMBOL) &
                   nzchar(gn.df[[keytype]]) & nzchar(gn.df$SYMBOL), , drop = FALSE]
  gn.df <- gn.df[!duplicated(gn.df[[keytype]]), , drop = FALSE]
  gn <- as.character(gn.df$SYMBOL)
  names(gn) <- as.character(gn.df[[keytype]])
  unmap_gene_ids <- gene_ids[!gene_ids %in% names(gn)]
  if (length(unmap_gene_ids) != 0L) {
    gn <- c(gn, stats::setNames(unmap_gene_ids, unmap_gene_ids))
  }
  gn
}

.tinyarray_relabel_gene_string <- function(x, symbol_map) {
  if (length(x) != 1L || is.na(x) || !nzchar(x)) {
    return(x)
  }
  gene_ids <- strsplit(x, "/", fixed = TRUE)[[1]]
  mapped <- unname(symbol_map[gene_ids])
  missing <- is.na(mapped) | !nzchar(mapped)
  if (any(missing)) {
    mapped[missing] <- gene_ids[missing]
  }
  paste(mapped, collapse = "/")
}

.tinyarray_make_readable_enrich <- function(x, OrgDb, keyType) {
  if (is.null(x)) {
    return(NULL)
  }
  if (inherits(x, "compareClusterResult")) {
    res <- as.data.frame(x)
    gene_col <- if ("core_enrichment" %in% colnames(res)) "core_enrichment" else "geneID"
    gene_ids <- unique(unlist(strsplit(as.character(res[[gene_col]]), "/", fixed = TRUE)))
    symbol_map <- .tinyarray_extid2symbol(OrgDb, gene_ids = gene_ids, keytype = keyType)
    if (gene_col %in% colnames(res)) {
      res[[gene_col]] <- vapply(res[[gene_col]], .tinyarray_relabel_gene_string, character(1), symbol_map = symbol_map)
    }
    x@compareClusterResult <- res
  } else if (inherits(x, "gseaResult")) {
    res <- x@result
    gene_col <- if ("core_enrichment" %in% colnames(res)) "core_enrichment" else "geneID"
    gene_ids <- names(x@geneList)
    symbol_map <- .tinyarray_extid2symbol(OrgDb, gene_ids = gene_ids, keytype = keyType)
    if (gene_col %in% colnames(res)) {
      res[[gene_col]] <- vapply(res[[gene_col]], .tinyarray_relabel_gene_string, character(1), symbol_map = symbol_map)
    }
    x@result <- res
  } else if (inherits(x, "enrichResult")) {
    res <- x@result
    gene_col <- if ("core_enrichment" %in% colnames(res)) "core_enrichment" else "geneID"
    symbol_map <- .tinyarray_extid2symbol(OrgDb, gene_ids = x@gene, keytype = keyType)
    if (gene_col %in% colnames(res)) {
      res[[gene_col]] <- vapply(res[[gene_col]], .tinyarray_relabel_gene_string, character(1), symbol_map = symbol_map)
    }
    x@result <- res
  } else {
    stop("Unsupported enrichment result class.", call. = FALSE)
  }
  x@gene2Symbol <- symbol_map
  x@keytype <- keyType
  x@readable <- TRUE
  x
}