R/sql_helpers.R

In Rduckhts: 'DuckDB' High Throughput Sequencing File Formats Reader Extension

sql_quote_string <- function(con, x) {
  if (!is.character(x) || length(x) != 1L || is.na(x)) {
    stop("SQL literal must be one non-missing character string", call. = FALSE)
  }
  as.character(DBI::dbQuoteString(con, x))
}

sql_quote_identifier <- function(con, x) {
  if (!is.character(x) || length(x) != 1L || is.na(x)) {
    stop("SQL identifier must be one non-missing character string", call. = FALSE)
  }
  as.character(DBI::dbQuoteIdentifier(con, x))
}

sql_raw_expression <- function(x) {
  if (!is.character(x) || length(x) != 1L || is.na(x)) {
    stop("SQL expression must be one non-missing character string", call. = FALSE)
  }
  x
}

build_param_str <- function(params) {
  if (!length(params)) return("")
  paste0(", ", paste(names(params), ":=", params, collapse = ", "))
}

# One whole number from low to high as SQL integer text. The error names the
# argument and its range. high must fit an R integer.
sql_whole_number <- function(value, name, high, low = 0) {
  if (!is.numeric(value) || length(value) != 1L || is.na(value) ||
      value != floor(value) || value < low || value > high) {
    stop(name, " must be one whole number from ", low, " to ",
         format(high, scientific = FALSE), call. = FALSE)
  }
  as.character(as.integer(value))
}

# `regions := getvariable('<name>')`, naming a session variable that holds a
# STRUCT(chrom VARCHAR, start BIGINT, "end" BIGINT)[] value. The name is a
# quoted SQL string literal; it is never spliced as an identifier.
.duckhts_regions_expression <- function(con, regions_var) {
  if (!is.character(regions_var) || length(regions_var) != 1L || is.na(regions_var) ||
      !nzchar(regions_var)) {
    stop("regions_var must be a single non-missing, non-empty string naming a session variable",
         call. = FALSE)
  }
  # getvariable() of an unknown name is NULL, which would silently mean a full
  # scan. A typo must be an error; an existing NULL variable is still NULL.
  known <- DBI::dbGetQuery(con, paste0(
    "SELECT count(*) AS n FROM duckdb_variables() WHERE name = ", sql_quote_string(con, regions_var)))$n
  if (!isTRUE(known > 0)) {
    stop("regions_var: no session variable named '", regions_var,
         "' exists on this connection; create it with SET VARIABLE", call. = FALSE)
  }
  paste0("getvariable(", sql_quote_string(con, regions_var), ")")
}

sql_varchar_list_literal <- function(con, x, name = "value") {
  if (is.null(x) || !length(x)) return("[]::VARCHAR[]")
  if (!is.character(x) || anyNA(x) || any(!nzchar(x))) {
    stop(name, " must be a character vector without NA or empty values", call. = FALSE)
  }
  sprintf(
    "[%s]",
    paste(
      vapply(x, function(value) sql_quote_string(con, value), character(1)),
      collapse = ", "
    )
  )
}

sql_map_literal <- function(con, x, name = "column_map", allow_empty = FALSE) {
  if (is.null(x) || !length(x)) {
    if (allow_empty) return("map([]::VARCHAR[], []::VARCHAR[])")
    stop(name, " must be non-empty", call. = FALSE)
  }
  nm <- names(x)
  if (is.null(nm) || any(!nzchar(nm))) {
    stop(name, " must be a named character vector", call. = FALSE)
  }
  keys <- paste(
    vapply(nm, function(value) sql_quote_string(con, value), character(1)),
    collapse = ", "
  )
  vals <- paste(
    vapply(as.character(x), function(value) sql_quote_string(con, value), character(1)),
    collapse = ", "
  )
  sprintf("map([%s], [%s])", keys, vals)
}

duckdb_path_exists <- function(con, path) {
  # A plain local path needs no database round trip: the glob() query below
  # failed on CRAN's Windows R-devel check, which left the existence unknown.
  # glob() stays for URLs and object stores, which R cannot inspect.
  # A leading ~ is resolved against DuckDB's home_directory, which may differ
  # from R's, so such paths keep the DuckDB check.
  if (!grepl("^[A-Za-z][A-Za-z0-9+.-]*://", path) && !startsWith(path, "~")) {
    return(file.exists(path))
  }
  child_pattern <- paste0(sub("/+$", "", path), "/**")
  tryCatch(
    isTRUE(DBI::dbGetQuery(
      con,
      sprintf(
        "SELECT EXISTS(SELECT 1 FROM glob([%s, %s]) LIMIT 1) AS exists",
        sql_quote_string(con, path),
        sql_quote_string(con, child_pattern)
      )
    )$exists[[1]]),
    error = function(e) NA
  )
}

.validate_nonnegative_integer_param <- function(value, name) {
  if (
    !is.numeric(value) ||
      length(value) != 1L ||
      is.na(value) ||
      value < 0 ||
      value > .Machine$integer.max ||
      value != floor(value)
  ) {
    stop(
      sprintf(
        "%s must be a single whole number between 0 and %d",
        name,
        .Machine$integer.max
      ),
      call. = FALSE
    )
  }
  as.integer(value)
}

.validate_scan_mode_param <- function(value, name = "scan_mode") {
  if (
    !is.character(value) ||
      length(value) != 1L ||
      is.na(value) ||
      !nzchar(value)
  ) {
    stop(sprintf("%s must be 'auto' or 'sequential'", name), call. = FALSE)
  }
  value <- tolower(value)
  if (!value %in% c("auto", "sequential")) {
    stop(sprintf("%s must be 'auto' or 'sequential'", name), call. = FALSE)
  }
  value
}

read_munge_column_map_file <- function(path) {
  tbl <- utils::read.delim(
    path,
    sep = "\t",
    header = FALSE,
    stringsAsFactors = FALSE,
    quote = "",
    comment.char = ""
  )
  if (ncol(tbl) < 2) {
    stop(
      "column_map_file must be a two-column TSV with source and canonical names",
      call. = FALSE
    )
  }
  out <- structure(tbl[[1]], names = toupper(tbl[[2]]))
  out[nzchar(names(out))]
}

resolve_munge_column_map <- function(raw_map, available_columns) {
  if (
    is.null(raw_map) ||
      length(raw_map) == 0 ||
      is.null(available_columns) ||
      length(available_columns) == 0
  ) {
    return(character())
  }
  available_columns <- as.character(available_columns)
  available_upper <- toupper(available_columns)
  canonical_names <- unique(names(raw_map))
  selected <- character(length(canonical_names))
  names(selected) <- canonical_names
  for (i in seq_along(canonical_names)) {
    canonical <- canonical_names[[i]]
    candidates <- as.character(raw_map[names(raw_map) == canonical])
    for (candidate in candidates) {
      idx <- match(toupper(candidate), available_upper)
      if (!is.na(idx)) {
        selected[[i]] <- available_columns[[idx]]
        break
      }
    }
  }
  selected[nzchar(selected)]
}

read_munge_preset_map <- function(con, preset) {
  out <- DBI::dbGetQuery(
    con,
    sprintf("SELECT duckhts__munge_preset_map(%s) AS m", sql_quote_string(con, preset))
  )
  if (nrow(out) != 1 || is.null(out$m[[1]])) {
    stop("duckhts_munge: unknown preset", call. = FALSE)
  }
  m <- out$m[[1]]
  if (!is.data.frame(m) || !all(c("key", "value") %in% names(m))) {
    stop("duckhts_munge: failed to read preset map", call. = FALSE)
  }
  structure(as.character(m$value), names = toupper(as.character(m$key)))
}