R/15_auto_geo_group.R

In tinyarray: Expression Data Analysis and Visualization

.tinyarray_geo_stopwords <- function() {
  c(
    "sample", "samples", "patient", "patients", "subject", "subjects",
    "series", "array", "chip", "microarray", "expression", "profiling",
    "profile", "profiles", "data", "study", "studies", "gene", "genes",
    "rna", "mrna", "dna", "gse", "gsm", "gpl", "geo", "platform",
    "human", "mouse", "rat", "male", "female"
  )
}

.tinyarray_geo_control_patterns <- function() {
  c(
    "\\bcontrol\\b",
    "\\bctrl\\b",
    "\\bnormal\\b",
    "\\bhealthy\\b",
    "\\buntreat(?:ed)?\\b",
    "\\bvehicle\\b",
    "\\bsham\\b",
    "\\bmock\\b",
    "\\bbaseline\\b",
    "\\bwild\\s*type\\b",
    "\\bwt\\b",
    "\\badjacent\\s+normal\\b",
    "\\bnon[-_\\s]*tumou?r\\b",
    "\\bnon[-_\\s]*cancer\\b",
    "\\bnoncancer\\b",
    "\\bnon[-_\\s]*obese\\b",
    "\\bnonobese\\b",
    "\\bbenign\\b"
  )
}

.tinyarray_geo_is_control_level <- function(x) {
  x <- .tinyarray_geo_clean_text(x)
  x <- tolower(x)
  patterns <- .tinyarray_geo_control_patterns()
  vapply(x, function(value) {
    if (is.na(value) || !nzchar(value)) {
      return(FALSE)
    }
    any(vapply(patterns, function(pattern) {
      grepl(pattern, value, ignore.case = TRUE, perl = TRUE)
    }, logical(1)))
  }, logical(1))
}

.tinyarray_geo_resolve_pdata <- function(x) {
  if (is.data.frame(x)) {
    return(x)
  }
  if (is.list(x) && !is.null(x$pd) && is.data.frame(x$pd)) {
    return(x$pd)
  }
  stop("x must be a data.frame or a list with a data.frame element `pd`.", call. = FALSE)
}

.tinyarray_geo_clean_text <- function(x) {
  x <- as.character(x)
  x <- trimws(x)
  x[x == ""] <- NA_character_
  x <- sub("\\s*[,;].*$", "", x, perl = TRUE)
  x <- gsub("\\s*\\[[^\\]]*\\]\\s*$", "", x, perl = TRUE)
  x <- gsub("\\s*\\([^\\)]*\\)\\s*$", "", x, perl = TRUE)
  x <- gsub("([a-z0-9])([A-Z])", "\\1 \\2", x, perl = TRUE)
  x <- gsub("\\b(gse|gsm|gpl)\\d+\\b", " ", x, ignore.case = TRUE, perl = TRUE)
  x <- gsub("[^[:alnum:]\\- ]+", " ", x, perl = TRUE)
  x <- gsub("\\s+[A-Za-z]*\\d+[A-Za-z]*\\s*$", "", x, perl = TRUE)
  x <- gsub("\\s+", " ", x, perl = TRUE)
  x <- trimws(x)
  x[x == ""] <- NA_character_
  x
}

.tinyarray_geo_label_display <- function(x) {
  x <- as.character(x)
  x <- trimws(x)
  x[x == ""] <- NA_character_
  x <- gsub("\\s+", "_", x, perl = TRUE)
  x
}

.tinyarray_geo_is_numeric_levels <- function(levels) {
  levels <- as.character(levels)
  levels <- levels[!is.na(levels) & nzchar(levels)]
  if (!length(levels)) {
    return(FALSE)
  }
  numeric_levels <- suppressWarnings(as.numeric(levels))
  all(!is.na(numeric_levels))
}

.tinyarray_geo_escape_regex <- function(x) {
  gsub("([][{}()+*^$.|\\\\?])", "\\\\\\1", x, perl = TRUE)
}

.tinyarray_geo_rough_tokens <- function(x) {
  x <- .tinyarray_geo_clean_text(x)
  x <- gsub("[_-]+", " ", x, perl = TRUE)
  split <- strsplit(x, " ", fixed = TRUE)
  lapply(split, function(tokens) {
    tokens <- tokens[nzchar(tokens)]
    tokens
  })
}

.tinyarray_geo_common_affixes <- function(x) {
  token_list <- .tinyarray_geo_rough_tokens(unique(x))
  token_list <- token_list[lengths(token_list) > 0L]
  if (length(token_list) < 2L) {
    return(list(prefix = character(), suffix = character()))
  }

  prefix <- token_list[[1L]]
  for (i in 2:length(token_list)) {
    current <- token_list[[i]]
    n <- min(length(prefix), length(current))
    if (!n) {
      prefix <- character()
      break
    }
    idx <- which(tolower(prefix[seq_len(n)]) != tolower(current[seq_len(n)]))
    if (length(idx)) {
      prefix <- prefix[seq_len(idx[[1L]] - 1L)]
    } else {
      prefix <- prefix[seq_len(n)]
    }
    if (!length(prefix)) break
  }

  suffix <- token_list[[1L]]
  for (i in 2:length(token_list)) {
    current <- token_list[[i]]
    n <- min(length(suffix), length(current))
    if (!n) {
      suffix <- character()
      break
    }
    suffix1 <- rev(suffix)
    current1 <- rev(current)
    idx <- which(tolower(suffix1[seq_len(n)]) != tolower(current1[seq_len(n)]))
    if (length(idx)) {
      suffix <- rev(suffix1[seq_len(idx[[1L]] - 1L)])
    } else {
      suffix <- rev(suffix1[seq_len(n)])
    }
    if (!length(suffix)) break
  }

  list(prefix = prefix, suffix = suffix)
}

.tinyarray_geo_strip_affixes <- function(x, prefix = character(), suffix = character()) {
  x <- .tinyarray_geo_clean_text(x)
  if (!length(x)) {
    return(x)
  }

  strip_prefix <- function(value, tokens) {
    if (!length(tokens) || is.na(value) || !nzchar(value)) {
      return(value)
    }
    if (length(tokens) == 1L && nchar(tokens[[1L]]) < 4L) {
      return(value)
    }
    pattern <- paste0(
      "^",
      paste(vapply(tokens, .tinyarray_geo_escape_regex, character(1)), collapse = "(?:[-_\\s]+)"),
      "(?:[-_\\s]+)?"
    )
    sub(pattern, "", value, perl = TRUE)
  }

  strip_suffix <- function(value, tokens) {
    if (!length(tokens) || is.na(value) || !nzchar(value)) {
      return(value)
    }
    if (length(tokens) == 1L && nchar(tokens[[1L]]) < 4L) {
      return(value)
    }
    pattern <- paste0(
      "(?:[-_\\s]+)?",
      paste(vapply(tokens, .tinyarray_geo_escape_regex, character(1)), collapse = "(?:[-_\\s]+)"),
      "$"
    )
    sub(pattern, "", value, perl = TRUE)
  }

  out <- vapply(x, function(value) {
    if (is.na(value) || !nzchar(value)) {
      return(NA_character_)
    }
    value <- strip_prefix(value, prefix)
    value <- strip_suffix(value, suffix)
    value <- gsub("^[-_\\s]+|[-_\\s]+$", "", value, perl = TRUE)
    value <- gsub("\\s+", " ", value, perl = TRUE)
    value <- trimws(value)
    if (!nzchar(value)) {
      NA_character_
    } else {
      value
    }
  }, character(1), USE.NAMES = FALSE)
  out
}

.tinyarray_geo_alt_labels <- function(label) {
  label <- as.character(label)[1L]
  if (!length(label) || is.na(label) || !nzchar(label)) {
    return(character())
  }
  tokens <- strsplit(label, " ", fixed = TRUE)[[1L]]
  tokens <- tokens[nzchar(tokens)]
  if (length(tokens) != 1L) {
    return(character())
  }
  if (!grepl("-", tokens, fixed = TRUE)) {
    return(character())
  }
  if (grepl("^non[-_]", tolower(tokens))) {
    return(character())
  }
  pieces <- strsplit(tokens, "-", fixed = TRUE)[[1L]]
  pieces <- pieces[nzchar(pieces)]
  pieces <- pieces[grepl("[[:alpha:]]", pieces)]
  if (length(pieces) < 2L) {
    return(character())
  }
  unique(pieces)
}

.tinyarray_geo_trim_shared_tokens <- function(label, reference) {
  label_tokens <- strsplit(as.character(label), " ", fixed = TRUE)[[1L]]
  ref_tokens <- strsplit(as.character(reference), " ", fixed = TRUE)[[1L]]
  label_tokens <- label_tokens[nzchar(label_tokens)]
  ref_tokens <- ref_tokens[nzchar(ref_tokens)]
  if (!length(label_tokens) || !length(ref_tokens)) {
    return(list(label = as.character(label), reference = as.character(reference)))
  }
  while (
    length(label_tokens) > 1L &&
      length(ref_tokens) > 1L &&
      identical(tolower(label_tokens[1L]), tolower(ref_tokens[1L]))
  ) {
    label_tokens <- label_tokens[-1L]
    ref_tokens <- ref_tokens[-1L]
  }
  while (
    length(label_tokens) > 1L &&
      length(ref_tokens) > 1L &&
      identical(tolower(utils::tail(label_tokens, 1L)), tolower(utils::tail(ref_tokens, 1L)))
  ) {
    label_tokens <- utils::head(label_tokens, -1L)
    ref_tokens <- utils::head(ref_tokens, -1L)
  }
  label2 <- paste(label_tokens, collapse = " ")
  ref2 <- paste(ref_tokens, collapse = " ")
  if (!nzchar(label2) || !nzchar(ref2)) {
    return(list(label = as.character(label), reference = as.character(reference)))
  }
  list(label = label2, reference = ref2)
}

.tinyarray_geo_tokenize <- function(x, stopwords = .tinyarray_geo_stopwords()) {
  cleaned <- .tinyarray_geo_clean_text(x)
  token_list <- strsplit(cleaned, " ", fixed = TRUE)
  stopwords_lower <- tolower(stopwords)
  lapply(token_list, function(tokens) {
    tokens <- tokens[nzchar(tokens)]
    tokens <- tokens[grepl("[[:alpha:]]", tokens)]
    tokens <- tokens[!tolower(tokens) %in% stopwords_lower]
    unique(tokens)
  })
}

.tinyarray_geo_candidate_labels <- function(tokens) {
  tokens <- tokens[nzchar(tokens)]
  if (!length(tokens)) {
    return(character())
  }
  unique(tokens)
}

.tinyarray_geo_reference_label <- function(phrases, labels) {
  if (!length(labels)) {
    return(NULL)
  }
  control_labels <- labels[.tinyarray_geo_is_control_level(labels)]
  if (length(control_labels)) {
    control_metrics <- vapply(control_labels, function(label) {
      sum(!is.na(phrases) & phrases == label)
    }, integer(1))
    control_labels <- control_labels[order(-control_metrics, nchar(control_labels), control_labels)]
    return(control_labels[[1L]])
  }
  metrics <- t(vapply(labels, function(label) {
    present <- !is.na(phrases) & phrases == label
    c(
      avg_tokens = if (any(present)) mean(lengths(strsplit(phrases[present], " ", fixed = TRUE))) else Inf,
      support = sum(present)
    )
  }, numeric(2)))
  metrics <- as.data.frame(metrics, stringsAsFactors = FALSE)
  metrics$label <- rownames(metrics)
  metrics <- metrics[order(metrics$avg_tokens, -metrics$support, nchar(metrics$label), metrics$label), , drop = FALSE]
  if (!nrow(metrics) || !is.finite(metrics$avg_tokens[1L])) {
    return(NULL)
  }
  metrics$label[[1L]]
}

.tinyarray_geo_build_candidate <- function(phrases,
                                           keep_idx,
                                           present,
                                           label_raw,
                                           ref_raw,
                                           colname,
                                           n_total,
                                           level_order = NULL,
                                           ref = NULL,
                                           method = c("phrase", "token"),
                                           seen = NULL) {
  method <- match.arg(method)
  if (sum(present) < 2L || sum(!present) < 2L) {
    return(NULL)
  }
  trimmed <- .tinyarray_geo_trim_shared_tokens(label_raw, ref_raw)
  display_label <- .tinyarray_geo_label_display(trimmed$label)
  display_ref <- .tinyarray_geo_label_display(trimmed$reference)
  if (!nzchar(display_label) || !nzchar(display_ref) || identical(display_label, display_ref)) {
    return(NULL)
  }
  if (length(keep_idx) != length(present)) {
    return(NULL)
  }
  group <- rep(NA_character_, n_total)
  group[keep_idx] <- ifelse(present, display_label, display_ref)
  group <- factor(group, levels = c(display_label, display_ref))
  group <- .tinyarray_geo_order_levels(group, level_order = level_order, ref = ref)
  group <- droplevels(group)
  if (length(unique(stats::na.omit(group))) < 2L) {
    return(NULL)
  }
  if (nlevels(group) > 1L && sum(!is.na(group)) < 2L) {
    return(NULL)
  }
  if (nlevels(group) > 5L && .tinyarray_geo_is_numeric_levels(base::levels(group))) {
    return(NULL)
  }
  sig <- paste(ifelse(is.na(group), "<NA>", as.character(group)), collapse = "\r")
  if (!is.null(seen) && length(seen) && sig %in% seen) {
    return(NULL)
  }
  counts2 <- sort(table(group), decreasing = TRUE)
  list(
    column = colname,
    label = display_label,
    reference = display_ref,
    label_raw = label_raw,
    reference_raw = ref_raw,
    candidate = paste(base::levels(group), collapse = "-"),
    group = group,
    counts = counts2,
    coverage = mean(!is.na(group)),
    n_groups = nlevels(group),
    levels = base::levels(group),
    support = sum(present),
    reference_support = sum(!present),
    label_words = length(strsplit(display_label, "_", fixed = TRUE)[[1L]]),
    label_table = counts2,
    method = method,
    signature = sig
  )
}

.tinyarray_geo_order_levels <- function(group, level_order = NULL, ref = NULL) {
  if (!is.factor(group)) {
    group <- factor(group, levels = unique(group))
  }
  lev <- base::levels(group)
  if (length(lev) < 2L) {
    return(group)
  }

  resolve_level <- function(value) {
    if (is.null(value) || !length(value)) {
      return(NA_character_)
    }
    value <- as.character(value)[1L]
    if (value %in% lev) {
      return(value)
    }
    hit <- lev[tolower(lev) == tolower(value)]
    if (length(hit) == 1L) {
      return(hit)
    }
    NA_character_
  }

  ord <- lev
  if (!is.null(level_order)) {
    wanted <- vapply(as.character(level_order), resolve_level, character(1), USE.NAMES = FALSE)
    wanted <- wanted[!is.na(wanted) & nzchar(wanted)]
    ord <- c(wanted, setdiff(lev, wanted))
  }
  if (!is.null(ref)) {
    ref_level <- resolve_level(ref)
    if (!is.null(ref_level) && !is.na(ref_level) && nzchar(ref_level)) {
      ord <- c(ref_level, setdiff(ord, ref_level))
    }
  }
  if (is.null(level_order) && is.null(ref)) {
    control_levels <- lev[.tinyarray_geo_is_control_level(lev)]
    if (length(control_levels)) {
      ord <- c(control_levels, setdiff(ord, control_levels))
    }
  }
  ord <- unique(ord[nzchar(ord)])
  factor(group, levels = ord)
}

.tinyarray_geo_infer_from_column <- function(x,
                                             colname,
                                             min_group_size = 2L,
                                             max_groups = 20L,
                                             min_coverage = 0.8,
                                             stopwords = .tinyarray_geo_stopwords(),
                                             level_order = NULL,
                                             ref = NULL) {
  cleaned <- .tinyarray_geo_clean_text(x)
  keep <- !is.na(cleaned)
  if (sum(keep) < 2L) {
    return(NULL)
  }

  cleaned <- cleaned[keep]
  keep_idx <- which(keep)
  affixes <- .tinyarray_geo_common_affixes(cleaned)
  stripped <- .tinyarray_geo_strip_affixes(
    cleaned,
    prefix = affixes$prefix,
    suffix = affixes$suffix
  )
  keep2 <- !is.na(stripped) & nzchar(stripped)
  if (sum(keep2) < 2L) {
    return(NULL)
  }

  stripped <- stripped[keep2]
  keep_idx <- keep_idx[keep2]
  total_n <- length(x)
  # Merge labels that differ only in case while retaining the most common
  # spelling. This prevents values such as `c`/`C` from becoming separate
  # groups because of inconsistent metadata capitalization.
  case_key <- tolower(stripped)
  for (key in unique(case_key)) {
    idx <- !is.na(case_key) & case_key == key
    spellings <- sort(table(stripped[idx]), decreasing = TRUE)
    stripped[idx] <- names(spellings)[1L]
  }

  display <- .tinyarray_geo_label_display(stripped)
  label_counts <- table(display)
  valid_levels <- names(label_counts)[label_counts >= min_group_size]
  assigned <- !is.na(display) & display %in% valid_levels
  coverage <- sum(assigned) / total_n
  if (coverage < min_coverage) {
    return(NULL)
  }
  if (length(valid_levels) < 2L || length(valid_levels) > max_groups) {
    return(NULL)
  }

  group <- rep(NA_character_, total_n)
  group[keep_idx[assigned]] <- display[assigned]
  group <- factor(group, levels = unique(display[assigned]))
  group <- .tinyarray_geo_order_levels(group, level_order = level_order, ref = ref)
  group <- droplevels(group)
  if (nlevels(group) > 5L && .tinyarray_geo_is_numeric_levels(base::levels(group))) {
    return(NULL)
  }

  make_candidate <- function(group, method) {
    lev <- base::levels(group)
    counts2 <- table(group)
    reference <- lev[1L]
    labels <- setdiff(lev, reference)
    list(
      column = colname,
      label = paste(labels, collapse = "|"),
      reference = reference,
      label_raw = paste(labels, collapse = "|"),
      reference_raw = reference,
      candidate = paste(lev, collapse = "-"),
      group = group,
      counts = sort(counts2, decreasing = TRUE),
      coverage = mean(!is.na(group)),
      n_groups = nlevels(group),
      levels = lev,
      support = as.integer(min(counts2)),
      reference_support = as.integer(counts2[[reference]]),
      label_words = max(lengths(strsplit(labels, "_", fixed = TRUE))),
      label_table = sort(counts2, decreasing = TRUE),
      method = method,
      signature = paste(ifelse(is.na(group), "<NA>", as.character(group)), collapse = "\r")
    )
  }

  candidates <- list(make_candidate(
    group,
    if (nlevels(group) == 2L) "groups" else "multigroup"
  ))

  # For a genuinely binary column, keep harmless alternative labels obtained
  # from a hyphenated group name. Membership is unchanged; only the display
  # label differs. This preserves useful choices such as Disease/Normal versus
  # Ovary-Disease/Normal without collapsing any third group into the reference.
  if (nlevels(group) == 2L) {
    ref_level <- base::levels(group)[1L]
    target_level <- base::levels(group)[2L]
    alt_labels <- .tinyarray_geo_alt_labels(gsub("_", " ", target_level, fixed = TRUE))
    for (alt in alt_labels) {
      alt <- .tinyarray_geo_label_display(alt)
      alt_values <- ifelse(
        is.na(group),
        NA_character_,
        ifelse(as.character(group) == target_level, alt, as.character(group))
      )
      alt_group <- factor(alt_values, levels = c(ref_level, alt))
      alt_group <- .tinyarray_geo_order_levels(alt_group, level_order = level_order, ref = ref)
      candidates[[length(candidates) + 1L]] <- make_candidate(alt_group, "alt_hyphen")
    }
  }

  order_idx <- order(
    vapply(candidates, `[[`, integer(1), "label_words"),
    vapply(candidates, `[[`, character(1), "candidate"),
    vapply(candidates, `[[`, character(1), "method")
  )
  candidates[order_idx]
}

.tinyarray_geo_candidate_table <- function(candidates) {
  if (!length(candidates)) {
    return(data.frame())
  }
  candidate_name <- character(length(candidates))
  columns <- vapply(candidates, `[[`, character(1), "column")
  for (col in unique(columns)) {
    idx <- which(columns == col)
    if (length(idx) == 1L) {
      candidate_name[idx] <- paste0(col, "_choice")
    } else {
      candidate_name[idx] <- paste0(col, "_choice", seq_along(idx))
    }
  }
  data.frame(
    idx = seq_along(candidates),
    candidate_name = candidate_name,
    column = vapply(candidates, `[[`, character(1), "column"),
    candidate = vapply(candidates, `[[`, character(1), "candidate"),
    label = vapply(candidates, `[[`, character(1), "label"),
    reference = vapply(candidates, `[[`, character(1), "reference"),
    method = vapply(candidates, `[[`, character(1), "method"),
    n_groups = vapply(candidates, `[[`, integer(1), "n_groups"),
    coverage = round(vapply(candidates, `[[`, numeric(1), "coverage"), 3),
    support = vapply(candidates, `[[`, integer(1), "support"),
    label_words = vapply(candidates, `[[`, integer(1), "label_words"),
    groups = vapply(candidates, function(x) paste(x$levels, collapse = " | "), character(1)),
    counts = vapply(
      candidates,
      function(x) paste(names(x$counts), as.integer(x$counts), sep = ":", collapse = ", "),
      character(1)
    ),
    stringsAsFactors = FALSE
  )
}

.tinyarray_geo_collect_candidates <- function(pd,
                                              group_col = "title",
                                              min_group_size = 2L,
                                              max_groups = 20L,
                                              min_coverage = 0.8,
                                              stopwords = .tinyarray_geo_stopwords(),
                                              levels = NULL,
                                              ref = NULL,
                                              search_other_cols = TRUE) {
  pd <- .tinyarray_geo_resolve_pdata(pd)
  preferred_cols <- unique(c(
    group_col,
    if (tolower(group_col) != "title" && "title" %in% names(pd)) "title" else character()
  ))
  preferred_cols <- preferred_cols[preferred_cols %in% names(pd)]
  cols <- if (isTRUE(search_other_cols)) {
    unique(c(preferred_cols, setdiff(names(pd), preferred_cols)))
  } else {
    preferred_cols
  }
  candidates <- list()
  for (col in cols) {
    candidate <- .tinyarray_geo_infer_from_column(
      pd[[col]],
      colname = col,
      min_group_size = min_group_size,
      max_groups = max_groups,
      min_coverage = min_coverage,
      stopwords = stopwords,
      level_order = levels,
      ref = ref
    )
    if (!is.null(candidate)) {
      candidates[[col]] <- candidate
    }
  }
  candidates
}

.tinyarray_geo_flatten_candidates <- function(candidates) {
  if (!length(candidates)) {
    return(list())
  }
  out <- list()
  out_names <- character()
  for (col in names(candidates)) {
    inner <- candidates[[col]]
    if (!length(inner)) {
      next
    }
    for (candidate in inner) {
      out[[length(out) + 1L]] <- candidate
      out_names <- c(out_names, paste(col, candidate$candidate, sep = "_"))
    }
  }
  names(out) <- out_names
  out
}

.tinyarray_geo_deduplicate_candidates <- function(candidates) {
  if (!length(candidates)) {
    return(list())
  }
  sig <- vapply(
    candidates,
    function(x) {
      group <- x$group
      paste(ifelse(is.na(group), "<NA>", as.character(group)), collapse = "\r")
    },
    character(1)
  )
  candidates[!duplicated(sig)]
}

.tinyarray_geo_group_candidates <- function(pd,
                                            group_col = "title",
                                            min_group_size = 2L,
                                            max_groups = 20L,
                                            min_coverage = 0.8,
                                            stopwords = .tinyarray_geo_stopwords(),
                                            levels = NULL,
                                            ref = NULL,
                                            search_other_cols = TRUE) {
  candidates <- .tinyarray_geo_collect_candidates(
    pd = pd,
    group_col = group_col,
    min_group_size = min_group_size,
    max_groups = max_groups,
    min_coverage = min_coverage,
    stopwords = stopwords,
    levels = levels,
    ref = ref,
    search_other_cols = search_other_cols
  )
  out <- list()
  flat <- .tinyarray_geo_flatten_candidates(candidates)
  flat <- .tinyarray_geo_deduplicate_candidates(flat)
  if (length(flat)) {
    tbl <- .tinyarray_geo_candidate_table(flat)
    out <- stats::setNames(lapply(flat, function(x) x$group), tbl$candidate_name)
  }
  out
}

#' auto_geo_group
#'
#' Infer sample groups from GEO phenotype metadata.
#'
#' The function first tries the user-specified `group_col`, then `title`. If no
#' stable grouping is found, it scans the remaining columns and returns a table
#' of candidate groupings for manual selection. Both binary and multigroup
#' factors are supported. Rare groups are left as `NA` rather than being
#' relabeled as another group.
#'
#' Labels that differ only in capitalization are merged, retaining their most
#' common spelling. Shared affixes and trailing sample identifiers are removed
#' when they can be identified consistently.
#'
#' @param x A GEO result list with a `pd` data frame, or a phenotype data frame.
#' @param group_col Column name to try first. The default is `title`.
#' @param choice Candidate index to select. Use `0` to cancel. If `NULL`, the
#'   function returns the candidate table without selecting.
#' @param min_group_size Minimum number of samples required for a split label.
#' @param max_groups Maximum number of group labels allowed in one column.
#' @param min_coverage Minimum fraction of samples that must be assigned a label.
#' @param search_other_cols Whether to search other columns when `group_col` and
#'   `title` fail.
#' @param stopwords Character vector of generic words to ignore during tokenization.
#' @param levels Optional character vector giving the desired factor level order.
#' @param ref Optional reference level to place first.
#' @param verbose Whether to print messages and candidate tables.
#'
#' @return A list with `group_list`, `source_col`, `selected_index`,
#'   `candidate_table`, `candidates`, and `pdata`.
#'
#' @export
#'
#' @examples
#' pd <- data.frame(
#'   title = c("Control sample", "Control sample", "Treat sample", "Treat sample"),
#'   stringsAsFactors = FALSE
#' )
#' rownames(pd) <- paste0("s", 1:4)
#' res <- auto_geo_group(
#'   pd,
#'   choice = 1,
#'   levels = c("Control", "Treat"),
#'   ref = "Control",
#'   verbose = FALSE
#' )
#' res$source_col
#' levels(res$group_list)
#' table(res$group_list)
auto_geo_group <- function(x,
                           group_col = "title",
                           choice = NULL,
                           min_group_size = 2L,
                           max_groups = 20L,
                           min_coverage = 0.8,
                           search_other_cols = TRUE,
                           stopwords = .tinyarray_geo_stopwords(),
                           levels = NULL,
                           ref = NULL,
                           verbose = TRUE) {
  pd <- .tinyarray_geo_resolve_pdata(x)
  if (!nrow(pd)) {
    stop("pdata has no rows.", call. = FALSE)
  }
  preferred_cols <- unique(c(
    group_col,
    if (tolower(group_col) != "title" && "title" %in% names(pd)) "title" else character()
  ))
  preferred_cols <- preferred_cols[preferred_cols %in% names(pd)]
  candidate_order <- if (isTRUE(search_other_cols)) {
    unique(c(preferred_cols, setdiff(names(pd), preferred_cols)))
  } else {
    preferred_cols
  }

  candidates_by_col <- .tinyarray_geo_collect_candidates(
    pd = pd,
    group_col = group_col,
    min_group_size = min_group_size,
    max_groups = max_groups,
    min_coverage = min_coverage,
    stopwords = stopwords,
    levels = levels,
    ref = ref,
    search_other_cols = search_other_cols
  )

  candidates <- .tinyarray_geo_flatten_candidates(candidates_by_col)
  candidates <- .tinyarray_geo_deduplicate_candidates(candidates)
  if (!length(candidates)) {
    if (verbose) {
      if (search_other_cols) {
        message(
          "No stable grouping was found in `", group_col, "`, `title`, or other columns. ",
          "If grouping information exists, extract it manually from the GPL table."
        )
      } else {
        message(
          "No stable grouping was found in `", paste(c(group_col, if (tolower(group_col) != "title" && "title" %in% names(pd)) "title" else character()), collapse = "`, `"), "`."
        )
      }
    }
    return(structure(
      list(
        group_list = NULL,
        source_col = NULL,
        source_candidate = NULL,
        selected_index = 0L,
        candidate_table = data.frame(),
        candidates = list(),
        pdata = pd
      ),
      class = "geo_auto_group"
    ))
  }

  cand_tbl <- .tinyarray_geo_candidate_table(candidates)
  cand_tbl$column_rank <- match(cand_tbl$column, candidate_order)
  cand_tbl$column_rank[is.na(cand_tbl$column_rank)] <- length(candidate_order) + 1L
  cand_tbl <- cand_tbl[order(cand_tbl$column_rank, -cand_tbl$coverage, -cand_tbl$support, cand_tbl$label_words, cand_tbl$column, cand_tbl$candidate), , drop = FALSE]
  if (nrow(cand_tbl)) {
    cand_tbl$idx <- seq_len(nrow(cand_tbl))
  }
  candidates <- candidates[rownames(cand_tbl)]
  names(candidates) <- cand_tbl$candidate_name

  if (verbose) {
    print(cand_tbl)
    message("Choose a candidate index, or set `choice = 0` to cancel.")
  }

  if (is.null(choice)) {
    if (nrow(cand_tbl) == 1L) {
      choice <- 1L
    } else if (interactive()) {
      choice <- utils::menu(c(paste0(cand_tbl$idx, ": ", cand_tbl$candidate_name), "0: none"))
    } else {
      return(structure(
        list(
          group_list = NULL,
          source_col = NULL,
          source_candidate = NULL,
          source_name = NULL,
          selected_index = NA_integer_,
          candidate_table = cand_tbl,
          candidates = candidates,
          pdata = pd
        ),
        class = "geo_auto_group"
      ))
    }
  }
  if (length(choice) != 1L || is.na(choice) || choice < 0L || choice > nrow(cand_tbl)) {
    stop("choice must be between 0 and ", nrow(cand_tbl), call. = FALSE)
  }
  if (choice == 0L) {
    return(structure(
      list(
        group_list = NULL,
        source_col = NULL,
        source_candidate = NULL,
        source_name = NULL,
        selected_index = 0L,
        candidate_table = cand_tbl,
        candidates = candidates,
        pdata = pd
      ),
      class = "geo_auto_group"
    ))
  }

  selected <- candidates[[choice]]
  if (!is.null(rownames(pd)) && length(rownames(pd)) == length(selected$group)) {
    names(selected$group) <- rownames(pd)
  }
  structure(
    list(
      group_list = selected$group,
      source_col = selected$column,
      source_candidate = selected$candidate,
      source_name = names(candidates)[choice],
      selected_index = choice,
      candidate_table = cand_tbl,
      candidates = candidates,
      pdata = pd
    ),
    class = "geo_auto_group"
  )
}

#' Print a GEO auto-group result
#'
#' @param x An object returned by `auto_geo_group()`.
#' @param ... Additional arguments passed to `print()`.
#' @export
print.geo_auto_group <- function(x, ...) {
  if (!is.null(x$group_list)) {
    cat("<geo_auto_group: selected>\n")
    cat("source column:", x$source_col, "\n")
    if (!is.null(x$source_name)) {
      cat("source name:", x$source_name, "\n")
    }
    if (!is.null(x$source_candidate)) {
      cat("source candidate:", x$source_candidate, "\n")
    }
    print(table(x$group_list))
    return(invisible(x))
  }
  cat("<geo_auto_group: candidates>\n")
  if (nrow(x$candidate_table)) {
    print(x$candidate_table)
  } else {
    cat("no candidates\n")
  }
  invisible(x)
}