# Similar to na.omit() without appending attributes
.drop_na <- function(x) {
  x[!is.na(x)]
}

# Similar to pbapply::pblapply() for handling cluster argument, but
# with no progress bar.
.lapply_selector <- function(..., cl = NULL) {
  if (is.null(cl)) {
    lapply(...)
  }
  else if (inherits(cl, "cluster")) {
    if (isTRUE(getOption("pboptions")$use_lb))
      parallel::parLapplyLB(cl, ...)
    else parallel::parLapply(cl, ...)
  }
  else {
    parallel::mclapply(..., mc.cores = as.integer(cl))
  }
}

# Similar to rbind() or dplyr::bind_rows(), but specifically to append a df
# to another with fewer columns
.rbind_larger <- function(x, y) {

  if (is.data.frame(x) || is.data.frame(y)) {
    if (is.null(x)) return(y)
    if (is.null(y)) return(x)

    x <- as.data.frame(x)
    y <- as.data.frame(y)

    nam <- {
      if (ncol(x) > ncol(y)) names(x)
      else names(y)
    }

    .expand <- function(d, nam) {
      nam_not_in_d <- setdiff(nam, names(d))
      to_add <- as.data.frame(matrix(nrow = nrow(d), ncol = length(nam_not_in_d),
                                     dimnames = list(rownames(d), nam_not_in_d)))
      cbind(d, to_add)[nam]
    }
  }
  else if (is.matrix(x) && is.matrix(y)) {
    if (is.null(x)) return(y)
    if (is.null(y)) return(x)

    nam <- {
      if (ncol(x) > ncol(y)) names(x)
      else names(y)
    }

    .expand <- function(d, nam) {
      nam_not_in_d <- setdiff(nam, colnames(d))
      to_add <- matrix(nrow = nrow(d), ncol = length(nam_not_in_d),
                       dimnames = list(rownames(d), nam_not_in_d))
      cbind(d, to_add)[, nam, drop = FALSE]
    }
  }
  else {
    arg::err("{.arg x} and {.arg y} must be data frames or matrices")
  }

  if (ncol(x) > ncol(y)) {
    rbind(x, .expand(y, nam))
  }
  else if (ncol(x) < ncol(y)) {
    rbind(.expand(x, nam), y)
  }
  else {
    rbind(x, y)
  }
}

#When given a vector of strings, creates a string of the form "a and b"
#or "a, b, and c"
.word_list <- function(word.list = NULL, and.or = "and") {

  word.list <- word.list[!word.list %in% c(NA_character_, "")]
  L <- length(word.list)

  if (L == 0) {
    return("")
  }

  if (L == 1) {
    return(word.list)
  }

  and.or <- arg::match_arg(and.or, c("and", "or"))

  if (L == 2) {
    out <- paste(word.list, collapse = paste0(" ", and.or, " "))
  }
  else {
    out <- paste(toString(word.list[seq_len(L - 1)]),
                 word.list[L], sep = paste0(", ", and.or, " "))

  }

  out
}

# Checks if supplied argument is a color; vectorized
.is_color <- function(x) {
  vapply(x, function(z) {
    tryCatch(is.matrix(grDevices::col2rgb(z)),
             error = function(e) FALSE)
  }, logical(1L))
}

# Extracts vertebra positions for remaining observations from a
# regions_data dataset
.get_pos <- function(x, subset = TRUE) {
  if (inherits(x, "regions_pco")) {
    x <- attr(x, "data")
  }

  if (inherits(x, "regions_data")) {   # Original code for data processed with process_measurements
    pos_ind <- attr(x, "pos_ind")
    pos <- unlist(lapply(x, `[[`, pos_ind))

    if (!subset) {
      return(pos)
    }
  }
  else if (inherits(x, "regions_dataGM")) {  # New code for data processed with process_gmPC
    pos <- attr(x, "Xvar")
  }

  pos[pos %in% attr(x, "eligible_vertebrae")]
}

# Extracts measurements from
# regions_data dataset
.get_data_without_pos <- function(x, subset = TRUE) {
  if (inherits(x, "regions_pco")) {
    x <- attr(x, "data")
  }

  pos_ind <- attr(x, "pos_ind")

  out <- do.call("rbind", x)[-pos_ind]

  if (!subset) {
    return(out)
  }

  out[.get_pos(x, FALSE) %in% .get_eligible_vertebrae(x), ]
}

.get_eligible_vertebrae <- function(x, subset = TRUE) {
  if (inherits(x, "regions_pco")) {
    x <- attr(x, "data")
  }

  if (subset) {
    return(attr(x, "eligible_vertebrae"))
  }

  pos <- .get_pos(x, subset = FALSE)

  sort(unique(pos))
}

# Fast lm(), uses .lm.fit() but accommodates weights
.fast_lm <- function(x, y, w = NULL) {
  if (is.null(w)) {
    return(.lm.fit(x, y))
  }

  w <- sqrt(w)
  out <- .lm.fit(x * w, y * w)
  out$residuals <- out$residuals / w

  out
}

# Get last element in a vector
.last <- function(x) {
  x[length(x)]
}

# Test whether each row of matrix contains any elements in vec
.any_mat_in <- function(m, vec) {
  comp <- {
    if (length(vec) > 1) function(x, y) x %in% y
    else function(x, y) x == y
  }

  .rowSums(matrix(comp(m, vec), ncol = ncol(m)),
           m = nrow(m), n = ncol(m)) > 0
}

# Test whether each row of matrix contains all elements in vec
.all_mat_in <- function(m, vec) {
  p <- ncol(m)

  out <- .rowSums(matrix(m == vec[1], ncol = p),
                  m = nrow(m), n = p) > 0

  for (i in seq_along(vec)[-1L]) {
    out[out][.rowSums(matrix(m[out, ] == vec[i], ncol = p),
                      m = sum(out), n = p) == 0] <- FALSE
  }

  out
}

# Fast, minimal version of pmax() that takes in vector and scalar
.pmax2 <- function(x, n = 0) {
  x[x < n] <- n
  x
}

# Checks if two vector of numbers are equal within tolerance
.equiv <- function(x, y, tol = sqrt(.Machine$double.eps)) {
  arg::arg_numeric(x)
  arg::arg_numeric(y)
  arg::arg_number(tol)
  arg::arg_gte(tol, 0)

  abs(x - y) < tol
}
