R/conv_funcs.R

In OlisaNsonwu/diyar: Record Linkage and Epidemiological Case Definitions in 'R'

# @title Convenience functions
#
# @description Convenience functions
#
# @param x x
# @aliases finite_check
#
finite_check <- function(x, lim =10){
  e <- which(!is.finite(as.numeric(x)))
  if(length(e) %in% 1:lim) {
    paste0("[",listr(format(e, scientific = F)),"]")
  }else if(length(e) > lim) {
    paste0("[",paste0(format(e[1:lim]), collapse = ", "),", ...]")
  }else if(length(e) == 0)
    TRUE
}

missing_check <- function(x, lim =10){
  e <- which(is.na(x))
  if(length(x[e]) %in% 1:lim) {
    paste0("[", listr(format(e, scientific = F)), "]")
  }else if(length(x[e]) > lim) {
    paste0("[", paste0(format(e[1:lim], scientific = F), collapse = ", "),", ...]")
  }else{
    T
  }

}

fmt <- function(x, fmt = "count"){
  if(fmt == "difftime"){
    paste0(ifelse(round(x) == 0, "< 1", round(as.numeric(x), 2)), " ", attr(x, "units"))
  }else if(fmt == "MB"){
    class(x) <- "object_size"
    format(x, fmt)
  }else{
    formatC(x, format="d", big.mark=",")
  }
}

duplicates_check <- function(x){
  pos <- 1:length(x)
  lgk <- duplicated(x)
  dups <- x[lgk]
  dups <- dups[!duplicated(dups)]

  lgk2 <- x %in% head(dups, 3)
  y <- x[lgk2]
  y_pos <- pos[lgk2]

  y <- unlist(lapply(split(y_pos, y), function(x){
    ifelse(length(x)>3,
           paste0("[",paste0(x[1:3], collapse = ", "),",..]"),
           paste0("[",paste0(x, collapse = ", "),"]"))
  }), use.names = F)


  if(length(dups)>3){
    paste0(paste0(y, collapse=", "), " ...")
  }else if (length(y)!=0) {
    listr(y)
  }else{
    TRUE
  }
}

logicals_check <- function(x){
  log_vals <-  lapply(x, function(y){
    is.logical(eval(parse(text=y), envir = parent.frame(3)))
  })

  log_vals <- x[as.logical(log_vals)==F]
  if(length(log_vals) ==0){
    TRUE
  }else{
    paste0(listr(paste0("'",log_vals,"'")), " must be either TRUE or FALSE")
  }
}

# @rdname finite_check
sep_bdr_nl <- function(x){
  nl_prp <- function(i){
    x <- x[[i]]
    if(!is.number_line(x)){
      x <- as.number_line(x)
      left_point(x) <- 0
    }

    x@start <- as.numeric(x@start)
    x <- reverse_number_line(x, "decreasing")
    crx <- x@start/abs(x@start) != diyar::right_point(x)/abs(diyar::right_point(x))
    crx[is.na(crx)] <- F

    nl_a <- x
    left_point(nl_a[crx]) <- 0

    lst <- list(nl_a)
    if(any(crx)){
      nl_b <- x
      right_point(nl_b[crx]) <- 0
      lst[[2]] <- nl_b
    }

    names(lst) <- rep(i, length(lst))
    lst
  }

  b <- lapply(1:length(x), nl_prp)
  txt <- paste0("c(",paste0("b[[",1:length(b),"]]", collapse = ", " ), ")")
  b <- eval(parse(text=txt))
  return(b)
}

progress_bar <- function(n, d, max_width, msg = "",  prefix_msg = ""){
  prop_complete <- n/d
  mx_l <- max(nchar(c(n, d)))
  d <- format(d, big.mark = ",", width = mx_l, scientific = FALSE)
  n <- format(n, big.mark = ",", width = mx_l, scientific = FALSE)
  pct_l <- paste0(msg,"; ", n, " of ", d, " record(s) completed.")

  status_width <- max_width - (nchar(pct_l) + nchar(prefix_msg))
  bar_width <- floor(prop_complete*status_width)
  space_width <- status_width - bar_width

  status <-paste0(
    prefix_msg,
    paste0(rep("-", bar_width), collapse = ""),
    # ">",
    paste0(rep(" ", space_width), collapse = ""),
    pct_l,
    "\r")
  status
}

progress_txt <- function(n, d, msg){
  prop_complete <- n/d
  mx_l <- max(nchar(c(n, d)))
  d <- format(d, big.mark = ",", width = mx_l, scientific = FALSE)
  n <- format(n, big.mark = ",", width = mx_l, scientific = FALSE)
  pct_l <- paste0(msg,": ", n, " of ", d, " record(s) completed.")

  status <- paste0(pct_l,"\r")
  cat(status, "\r",sep="")
}

update_text <- function(tot_records = NULL,
                        current_tot = NULL,
                        current_tagged = NULL,
                        indent_txt = "",
                        time = NULL,
                        skipped = NULL,
                        iteration = NULL){
  update <- ""
  if(!is.null(iteration)){
    update <- paste0(update, indent_txt, "Iteration: ", iteration, ".\n")
  }
  if(!is.null(tot_records)){
    update <- paste0(update, indent_txt, "Total: ", tot_records, " record(s).\n")
  }
  if(!is.null(current_tot)){
    update <- paste0(update, indent_txt, "Checked: ", current_tot, " record(s).\n")
  }
  if(!is.null(skipped)){
    update <- paste0(update, indent_txt, "Skipped: ", skipped, " record(s).\n")
  }
  if(!is.null(current_tagged)){
    update <- paste0(update, indent_txt, "Linked: ", current_tagged, " record(s).\n")
  }
  if(!is.null(time)){
    update <- paste0(update, indent_txt, "Time: ", time, ".\n")
  }
  return(update)
}

datasets <- function(by, val, sep = ","){
  datasets <- split(val, by)
  func <- function(x) paste0(sort(x[!duplicated(x)]), collapse = sep)
  datasets <- lapply(datasets, func)
  #datasets <- as.character(datasets)[match(by, names(datasets))]
  datasets <- unlist(datasets[match(by, names(datasets))], use.names = F)
  datasets
}

check_links <- function(cri, data_source, data_links){
  dsc <- sort(data_source[!duplicated(data_source)])
  tmp <- rep(NA_character_, length(data_source))
  datatset <- lapply(dsc, function(x){
    cri1 <- cri[x == data_source]
    cri1 <- cri1[!duplicated(cri1)]
    tmp[cri %in% cri1] <- x
    rm(cri1)
    tmp
  })

  cmb_cd <- combi(datatset)
  cmb_cd_idx <- which(!duplicated(cmb_cd))
  datatset_p <- lapply(datatset, function(x){
    x <- x[cmb_cd_idx]
  })
  names(datatset_p) <- paste0("X", seq_len(length(datatset_p)))
  datatset_p <- sapply(datatset_p, identity)
  if(isFALSE(is.matrix(datatset_p))){
    datatset_p <- t(as.matrix(datatset_p))
  }

  cmp_func <- list(l = all, g = any)
  cmp_func <- cmp_func[match(names(data_links), names(cmp_func))]

  hits <- sapply(1:length(data_links), function(i){
    x <- lapply(seq_len(nrow(datatset_p)), function(j){
      cmp_func[[i]](data_links[[i]] %in% datatset_p[j,])
    })
    unlist(x, use.names = FALSE)
  })
  if(is.vector(hits) & length(hits) > 1){
    hits <- hits > 0
  }else if (!is.vector(hits)){
    hits <- rowSums(hits) > 0
  }

  datatset_p <- lapply(seq_len(nrow(datatset_p)), function(j) {
    x <- datatset_p[j,]
    paste0(x[!is.na(x)], collapse = ",")
  })
  datatset_p <- unlist(datatset_p, use.names = FALSE)

  return(
    list(
      ds = datatset_p[cmb_cd],
      rq = hits[cmb_cd]
    )
  )
}

prep_lengths <- function(length, overlap_methods, int,
                         episode_unit, bi_direction,
                         #from_last,
                         include_index_period = F){
  length <- length
  if(!inherits(length, "list")){
    length <- list(length)
  }
  if(!inherits(overlap_methods, "list")){
    overlap_methods <- list(overlap_methods)
  }
  if(length(overlap_methods) == 1){
    overlap_methods <- rep(overlap_methods, length(length))
  }

  length <- sep_bdr_nl(length)
  r <- rle(names(length))
  overlap_methods <- rep(overlap_methods[as.numeric(r$values)], r$lengths)

  if(any(bi_direction == T)){
    is_bdr <- names(length) %in% r$values[r$lengths == 2]
    n_length  <- length[!is_bdr]
    if(length(n_length) > 0){
      n_length <- lapply(n_length, function(x){
        x[bi_direction] <- invert_number_line(x)[bi_direction]
        return(x)
      })
      length <- c(n_length, length)
      overlap_methods <- c(overlap_methods[!is_bdr], overlap_methods)
    }
  }

  overlap_methods <- lapply(overlap_methods, function(x){
    if(length(x)==1){
      x <- rep(x, length(int))
    }else{
      x
    }
  })

  list(
    lengths = length,
    method = overlap_methods
  )
}

ovr_chks <- function(date, window, mths, ord){
  x <- overlaps(date, window, methods = mths)
  ord[x %in% c(NA, FALSE)] <-  0
  rm(list = ls()[ls() != "ord"])
  as.numeric(ord)
}

overlaps_err <- function(opts){
  opts <- as.vector(opts)
  if(inherits(opts, "character")){
    opts <- tolower(opts)
    opts_cd <- overlap_method_codes(opts)
  }else if(inherits(opts, c("numeric", "integer"))){
    opts_cd <- match(opts, diyar::overlap_methods$options$cd)
  }

  opts <- opts[is.na(opts_cd)]
  opts <- opts[!duplicated(opts)]
  if(length(opts) > 0){
    opts <- paste0("\"", opts,"\"")
    if(length(opts) >3) errs <- paste0(paste0(opts, collapse = ", "), " ...") else errs <- listr(opts)
    return(errs)
  }else{
    return(character())
  }
}

invalid_opts <- function(vals, opts){
  sn <- 1:length(vals)
  vals <- split(sn , vals)

  f1 <- function(x) paste0(x, collapse="|")
  all_pos <- combns(opts, seq_len(length(opts)), FUN = f1)

  vals <- vals[!names(vals) %in% all_pos]
  vals_len <- length(vals)
  vals <- head(vals, 5)

  names(vals) <- sapply(strsplit(names(vals), split="\\|"), function(x){
    paste0(x[!x %in% opts | is.na(x)], collapse = "|")
  })

  vals <- unlist(lapply(vals, function(x){
    missing_check(ifelse(sn %in% x, NA, T), 2)
  }), use.names = T)

  if(length(vals) > 0){
    vals <- paste0("\"", names(vals),"\"", " at ", vals)
    if(vals_len >3) errs <- paste0(paste0(vals, collapse = ", "), " ...") else errs <- listr(vals)
    return(errs)
  }else{
    return(character())
  }
}

pid_cri_l <- function(n){
  n[n == 0] <- "No hits"
  n[n == "-1"] <- "Skipped"
  lgk <- !n %in% c("Skipped", "No hits")
  n[lgk] <- paste0("CRI ", formatC(as.integer(n[lgk]), width = 3, flag = 0, format = "fg"))
  rm(lgk)
  return(n)
}

combns <- function(x, m, FUN = NULL, simplify = TRUE, ...){
  funx <- function(v){
    v <- v[!duplicated(v)]
    lapply(seq_len(length(v)), function(i){
      shuffle <- c(0:(i-1), i+1, i, (i+2):length(v))
      shuffle <- shuffle[shuffle %in% 1:length(v)]
      shuffle <- shuffle[!duplicated(shuffle)]
      v[shuffle]
    })
  }

  pos <- seq_len(length(x))
  all_pos <- lapply(m, function(i){
    utils::combn(pos, m = i, simplify = F, FUN = funx)
  })
  all_pos <- unlist(unlist(all_pos, recursive = F), recursive = F)
  all_pos <- lapply(all_pos, function(y){x[y]})

  if(inherits(FUN, "NULL")){
    func <- function(x, ...) x
  }else{
    func <- function(x, ...) FUN(x, ...)
  }
  all_pos <- sapply(all_pos, func, simplify = simplify)
  return(all_pos)
}


#' @name listr
#' @aliases listr
#' @title Grammatical lists.
#' @description A convenience function to format \code{atomic} vectors as a written list.
#'
#' @param x \code{atomic} vector.
#' @param sep Separator.
#' @param conj Final separator.
#' @param lim Elements to include in the list. Other elements are abbreviated to \code{" ..."}.
#'
#'
#' @return \code{character}.
#'
#' @examples
#' listr(1:5)
#' listr(1:5, sep = "; ")
#' listr(1:5, sep = "; ", conj = " and")
#' listr(1:5, sep = "; ", conj = " and", lim = 2)
#'
#' @export
listr <- function(x, sep = ", ", conj = " and ", lim = Inf){
  err <- err_atomic_vectors(x, "x")
  if(err != F) stop(err, call. = F)
  err <- err_object_types(sep, "sep", c("character"))
  if(err != F) stop(err, call. = F)
  err <- err_match_ref_len(sep, "", 1, "sep")
  if(err != F) stop(err, call. = F)
  err <- err_object_types(conj, "conj", c("character"))
  if(err != F) stop(err, call. = F)
  err <- err_match_ref_len(conj, "", 1, "conj")
  if(err != F) stop(err, call. = F)
  err <- err_object_types(lim, "lim", c("integer", "numeric"))
  if(err != F) stop(err, call. = F)
  err <- err_match_ref_len(lim, "", 1, "lim")
  if(err != F) stop(err, call. = F)

  if(length(x) <= lim){
    p <- x[length(x)]
    f <- x[1:(length(x)-1)]
    f <- paste(f, collapse = sep)
    x <- ifelse(length(x) > 1, paste0(f, conj, p), f)
  }else{
    x <- paste0(paste0(x[seq_len(lim)], collapse = sep), " ...")
  }

  return(x)
}

sb_h <- function(x, by) {
  x$x1 <- x$x1 + by
  x$x2 <- x$x2 + by
  x
}

sb_v <- function(x, by) {
  x$y1 <- x$y1 + by
  x$y2 <- x$y2 + by
  x
}


box_set <- function(x = box, n, by){
  mapply(sb_h, rep(x, n), (seq_len(n)-1) * by, SIMPLIFY = F)
}

box_45d <- function(y){
  x <- y
  ref_pt <- nrow(y)
  spacing <- c(0, abs(x$x2[1:(length(x$x1)-1)] - x$x1[-1]))
  y_int <- (((seq_len(nrow(x))-1) * (x$y2 - x$y1)) + ((seq_len(nrow(x))-1) * spacing))
  y$x1 <- x$x1[ref_pt]
  y$x2 <- x$x2[ref_pt]
  y$y1 <- x$y1 - y_int
  y$y2 <- x$y2 - y_int

  return(y)
}

box_45l <- function(y){
  x <- y
  ref_pt <- nrow(y)
  spacing <- c(0, abs(x$y1[1:(length(x$y1)-1)] - x$y2[-1]) )
  x_int <- (((seq_len(nrow(x))-1) * (x$x2 - x$x1)) + ((seq_len(nrow(x))-1) * spacing))
  y$y1 <- x$y1[ref_pt]
  y$y2 <- x$y2[ref_pt]
  y$x1 <- x$x1 - x_int
  y$x2 <- x$x2 - x_int
  y <- y[order(y$x1),]
  return(y)
}

box_45u <- function(y){
  x <- y
  ref_pt <- 1
  spacing <- c(0, abs(x$x2[1:(length(x$x1)-1)] - x$x1[-1]))
  y_int <- (((seq_len(nrow(x))-1) * (x$y2 - x$y1)) + ((seq_len(nrow(x))-1) * spacing))
  y$x1 <- x$x1[ref_pt]
  y$x2 <- x$x2[ref_pt]
  y$y1 <- x$y1 + y_int
  y$y2 <- x$y2 + y_int
  y <- y[order(-y$y1),]
  return(y)
}

box_45r <- function(y){
  x <- y
  ref_pt <- 1
  spacing <- c(0, abs(x$y1[1:(length(x$y1)-1)] - x$y2[-1]) )
  x_int <- (((seq_len(nrow(x))-1) * (x$x2 - x$x1)) + ((seq_len(nrow(x))-1) * spacing))
  y$y1 <- x$y1[ref_pt]
  y$y2 <- x$y2[ref_pt]
  y$x1 <- x$x1 + x_int
  y$x2 <- x$x2 + x_int
  return(y)
}

box <- function(by){
  data.frame(x1 = 1, x2 = by, y1 = 1, y2 = by)
}

box_ring <- function(boxes_w = 3, order = 1){
  boxes_n <- order * 2
  boxes <- box_set(x = list(box(boxes_w)), n = boxes_n, by = boxes_w)
  h_boxes <- do.call(rbind, boxes)
  top_box <- sb_h(sb_v(h_boxes, boxes_w * order), boxes_w * -(order-1))
  boxes <- rbind(
    top_box
    ,sb_v(box_45d(top_box), -boxes_w)
    ,sb_h(box_45l(sb_v(box_45d(top_box), -boxes_w)), -boxes_w)
    ,sb_v(box_45u(sb_h(box_45l(sb_v(box_45d(top_box), -boxes_w)), -boxes_w)), boxes_w)
  )
  boxes
}

l_ar <- function(lens, pltd, wind_nm, is_dt, epid_unit){
  lar <- lapply(seq_len(length(lens)), function(i){
    winds <- pltd[!duplicated(pltd$wind_id) &
                    pltd$wind_nm %in% wind_nm &
                    !is.na(pltd$wind_nm),]
    lgk <- pltd$sn %in% winds$wind_id
    lar <- pltd[lgk,]
    lens[[i]] <- lens[[i]][lgk]

    rec_ls <- nrow(lar)
    if(rec_ls >0){

      # lar$mid_y_lead <- pltd$mid_y[match(lar$sn, pltd$wind_id)]
      lar$mid_y_lead <- winds$mid_y

      x <- lens[[i]]
      y <- number_line(as.numeric(start_point(x)),
                       as.numeric(end_point(x)))
      y <- as.data.frame(y)
      y$id <- NULL
      y$gid <- NULL
      y$epid <- lar$epid
      y$wind_total <- lar$wind_total
      y$epid_total <- lar$epid_total
      y$y <- lar$y
      y$mid_y_lead <- lar$mid_y_lead
      y$pt_start <- lar$start
      y$pt_end <- lar$end
      y$pt_sn <- lar$sn
      y$ep_uni <- lar$episode_unit
      y$nl_nm <- "len"
      y$start_rl <- as.numeric(left_point(x))
      y$end_rl <- as.numeric(right_point(x))
      y$wind_nm_l <- paste0("`",winds$wind_nm[match(lar$sn, winds$wind_id)], "`-length")
      y$bi_dir <- start_point(x) < lar$end & end_point(x) > lar$end
      y <- y[!is.na(y$start) & !is.na(y$end),]
      if(nrow(y) > 0){
        if(any(y$bi_dir)){
          v <- y[y$bi_dir,]
          v$start <- v$pt_end
          y$end[y$bi_dir] <- y$pt_end[y$bi_dir]
          y <- rbind(y, v)
          rm(v)
        }
      }else{
        y$lab_y <- y$nl_s <- y$nl_e <- y$nl_l <- numeric()
        y$episode <- character()
      }

      y$bi_dir <- NULL
      y$nl_l <- epid_lengths(number_line(y$pt_start,
                                         y$pt_end),
                             number_line(y$start,
                                         y$end),
                             "seconds")

      if(is_dt == TRUE){
        y$nl_l <- number_line(start_point(y$nl_l)/as.numeric(diyar::episode_unit[y$ep_uni]),
                              end_point(y$nl_l)/as.numeric(diyar::episode_unit[y$ep_uni]))
      }
      y$nl_s <- start_point(y$nl_l)
      y$nl_e <- end_point(y$nl_l)
      y$episode_unit <- y$ep_uni
      y$nl_l <- NULL
      y$lab_y <- (y$mid_y_lead + y$y)/2
      return(y)
    }else{
      lar <-  pltd[0, c("end", "start", "epid", "y", "wind_total", "epid_total", "episode_unit")]
      lar$wind_nm_l <- lar$nl_nm <- character()
      lar$start_rl <- lar$end_rl <- lar$pt_start <- lar$pt_end <- lar$lab_y <- lar$mid_y_lead <- lar$nl_s <- lar$nl_e <- numeric()
      lar$pt_sn <- integer()
      return(lar)
    }
  })
  lar
}

scale_size <- function(size_lims, count_upper_lim, pts_n, decreasing = TRUE){
  unit_change <- (max(size_lims) - min(size_lims))/(count_upper_lim - 0)
  if(decreasing){
    max(size_lims) - (ifelse(pts_n > count_upper_lim, count_upper_lim, pts_n) * unit_change)
  }else{
    min(size_lims) + (ifelse(pts_n > count_upper_lim, count_upper_lim, pts_n) * unit_change)
  }
}

length_to_range <- function(lengths, date, from_last, episode_unit, skip_if_b4_lengths = FALSE){
  if(!inherits(lengths, "list")){
    lengths <- list(range = list(lengths))
  }else{
    lengths <- list(range = lengths)
  }

  lengths$range <- lapply(lengths$range, function(x){
    if(!inherits(x, "number_line")){
      x <- number_line(0, x)
    }
    return(x)
  })

  if(any(from_last)) {
    lengths$range <- lapply(lengths$range, function(x){
      if(length(x) < length(from_last)){
        x <- rep(x, length(date))
      }
      x@start <- as.numeric(x@start)
      x[from_last] <- reverse_number_line(
        invert_number_line(x[from_last]),
        direction = "decreasing")
      return(x)
    })
  }

  if(any(skip_if_b4_lengths == T)) {
    lengths$coverage <- lapply(lengths$range, function(x){
      matrix(c(left_point(x), right_point(x)), ncol = 2)
    })
    lengths$coverage <- do.call("cbind", lengths$coverage)
    lengths$coverage <- number_line(
      row_wise(lengths$coverage, type = "min"),
      row_wise(lengths$coverage, type = "max")
    )
    lgk <- lengths$coverage@start > 0 &
      lengths$coverage@.Data > -abs(lengths$coverage@start)
    left_point(lengths$coverage[lgk]) <- 0

    lgk <- lengths$coverage@start < 0 &
      lengths$coverage@.Data < abs(lengths$coverage@start)
    right_point(lengths$coverage[lgk]) <- 0

    lengths$coverage <- epid_windows(
      date = date,
      lengths = lengths$coverage,
      episode_unit = names(diyar::episode_unit)[episode_unit]
    )
  }

  lengths$range <- lapply(lengths$range, function(x){
    x <- epid_windows(
      date = date,
      lengths = x,
      episode_unit = names(diyar::episode_unit)[episode_unit]
    )
    return(x)
  })
  return(lengths)
}

opt_level <- function(opt, mth, tr_mth){
  if(opt == "g") {
    tr_mth
  }else if(opt == "b"){
    lgk <- mth != tr_mth
    mth[lgk] <- overlap_method_codes(paste0(overlap_method_names(mth[lgk]), "|", overlap_method_names(tr_mth[lgk])))
    mth
  }else{
    mth
  }
}

pane_checks <- function(dates, windows){
  fnx <- function(x, int = dates){
    ovr_chks(rep(windows[[x]], length(int)), int, rep(8, length(int)), rep(x, length(int)))
  }

  checks <- as.matrix(sapply(as.numeric(seq_len(length(windows))), fnx))
  if(length(dates) == 1){
    checks <- t(checks)
  }
  ep_checks <- row_wise(checks, type = "max", value = TRUE)
  as.integer(ep_checks)
}

check_skips <- function(lgk, cri, cr, tr_ep_l, vr, tr_date, date, case_nm){
  if(length(lgk[lgk]) > 0){
    ep_l_min_a <- rbind(
      row_wise(sapply(tr_ep_l, function(x) start_point(x[lgk])), type = "min"),
      row_wise(sapply(tr_ep_l, function(x) start_point(x[lgk])), type = "max")
    )

    ep_l_min_z <- rbind(
      row_wise(sapply(tr_ep_l, function(x) end_point(x[lgk])), type = "min"),
      row_wise(sapply(tr_ep_l, function(x) end_point(x[lgk])), type = "max")
    )
    ep_l_bounds_a <- start_point(tr_date[lgk])
    ep_l_bounds_z <- end_point(tr_date[lgk])

    ep_l_bounds_a <- ifelse(ep_l_min_a[1,] < ep_l_bounds_a, ep_l_min_a[1,], ep_l_bounds_a)
    ep_l_bounds_z <- ifelse(ep_l_min_z[2,] > ep_l_bounds_z, ep_l_min_z[2,], ep_l_bounds_z)

    epc_bnds <- suppressWarnings(
      number_line(
        l = ep_l_bounds_a,
        r = ep_l_bounds_z))

    ep_obds_checks <- suppressWarnings(overlap(date[lgk], epc_bnds))
    ep_obds_checks <- ifelse(is.na(ep_obds_checks), FALSE, ep_obds_checks)

    ref_period <- overlap(date, tr_date)
    ref_period <- ifelse(is.na(ref_period), FALSE, ref_period)
    skp_crxt <- cri[vr & !ref_period]
    skp_crxt <- skp_crxt[!duplicated(skp_crxt)]
    indx <- (ep_obds_checks &
               !cr[lgk] &
               cri[lgk] %in% skp_crxt &
               is.na(case_nm[lgk]))
    lgk <- which(lgk == TRUE)[indx == TRUE]
    return(lgk)
  }else{
    return(numeric())
  }
}

f_rbind <- function(..., deparse.level = 1){
  dfs <- list(...)
  dfs_nms <- unlist(lapply(dfs, names), use.names = FALSE)
  dfs_nms <- dfs_nms[!duplicated(dfs_nms)]
  dfs <- lapply(dfs, function(x){
    for (i in dfs_nms) {
      if(!i %in% names(x) & nrow(x) > 0){
        x[[i]] <- NA
      }else if (!i %in% names(x) & nrow(x) == 0){
        x[[i]] <- logical()
      }
    }
    return(x)
  })
  t.rbind <- function(..., x = deparse.level) rbind(..., deparse.level = x)
  dfs <- do.call("t.rbind", dfs)
  return(dfs)
}

#' @name attr_eval
#' @title Sub-criteria attributes.
#' @param x \code{[\link{sub_criteria}]}
#' @param func \code{[function]}
#' @param simplify If \code{TRUE} (default), coerce to a vector.
#' @description
#' Recursive evaluation of a function (\code{func}) on each attribute (vector) in a \bold{\code{\link{sub_criteria}}}.
#' @return \code{vector}; \code{list}
#' @export
#'
#' @examples
#' x <- sub_criteria(rep(1, 5), rep(5 * 10, 5))
#' attr_eval(x)
#' attr_eval(x, func = max)
#' attr_eval(x, func = max, simplify = FALSE)
#' attr_eval(sub_criteria(x, x), func = max, simplify = FALSE)
attr_eval <- function(x, func = length, simplify = TRUE){
  if(inherits(x, "sub_criteria")){
    x <- lapply(x, function(x){
      attr_eval(x[[1]], func = func, simplify = simplify)
    })
  }else if(inherits(x, "d_attribute")){
    x <- lapply(x, func)
  }else if(is.atomic(x)){
    x <- func(x)
  }

  if(simplify) unlist(x, use.names = FALSE) else x
}

sp_scri <- function(b, lgk){
  for (i in seq_len(length(b))) {
    attr <- (b[[i]][[1]])
    if(inherits(attr, "sub_criteria")){
      b[[i]][[1]] <- sp_scri(attr, lgk)
    }else if(inherits(attr, "d_attribute")){
      attr <- lapply(attr, function(x){
        x[lgk]
      })
      class(attr) <- "d_attribute"
      b[[i]][[1]] <- attr
    }else{
      b[[i]][[1]] <- attr[lgk]
    }
  }
  return(b)
}

rf_scri <- function(b, strata){
  for (i in seq_len(length(b))) {
    attr <- (b[[i]][[1]])
    if(inherits(attr, "sub_criteria")){
      b[[i]][[1]] <- sp_scri(attr, strata)
    }else if(inherits(attr, "d_attribute")){
      attr <- lapply(attr, function(x){
        x <- split(x, strata)[strata[!duplicated(strata)]]
        names(x) <- NULL
        x
      })
      class(attr) <- "d_attribute"
      b[[i]][[1]] <- attr
    }else{
      b[[i]][[1]] <- split(attr, strata)[strata[!duplicated(strata)]]
      names(b[[i]][[1]]) <- NULL
    }
  }
  return(b)
}

#' @name combi
#' @title Vector combinations
#' @description Numeric codes for unique combination of vectors.
#' @param ... \code{[atomic]}
#' @return \code{numeric}
#'
#' @examples
#' x <- c("A", "B", "A", "C", "B", "B")
#' y <- c("X", "X", "Z", "Z", "X", "Z")
#' combi(x, y)
#'
#' # The code above is equivalent to but quicker than the one below.
#' z <- paste0(y, "-", x)
#' z <- match(z, z)
#' z
#' @export

combi <- function(...){
  # ... must be vectors
  combi <- list(...)
  is_list <- unlist(lapply(combi, function(x){
    inherits(x, "list")
  }), use.names = FALSE)
  combi <- c(unlist(combi[is_list], recursive = FALSE),
             combi[!is_list])
  # Validations
  err_txt <- unlist(lapply(seq_len(length(combi)), function(i){
    x <- err_atomic_vectors(combi[[i]], paste0("vector ", i))
    x[x == FALSE] <- NA_character_
    x
  }), use.names = FALSE)
  err_txt <- err_txt[!is.na(err_txt)]
  if(length(err_txt) > 0) stop(err_txt, call. = FALSE)

  vec_lens <- unlist(lapply(combi, length), use.names = FALSE)
  dd_err <- vec_lens[!duplicated(vec_lens)]
  if(!(length(dd_err) == 1 | (length(dd_err) == 2 & 1 %in% dd_err))){
    err_txt <- paste0("Length of each vector in `...` must be the same or equal to 1:\n",
                      paste0("X - Length of vector ",
                             seq_len(length(vec_lens)),
                             " is ", vec_lens, ".",
                             collapse = "\n"))
    stop(err_txt, call. = FALSE)
  }

  combi[vec_lens == 1] <- NULL
  if(length(combi) == 0){
    return(rep(1, max(dd_err)))
  }
  combi_cd <- match(combi[[1]], (combi[[1]])[!duplicated(combi[[1]])])
  for (j in seq_len(length(combi))[-1]){
    k <- match(combi[[j]], (combi[[j]])[!duplicated(combi[[j]])])

    faC <- as.integer(log10(max(combi_cd))) + 1
    faC <- 10 ^ faC

    combi_cd <- combi_cd + (k * faC)
    combi_cd <- match(combi_cd, combi_cd[!duplicated(combi_cd)])
  }
  rm(list = ls()[ls() != "combi_cd"])
  return(combi_cd)
}

mk_cd <- function(x){
  match(x, x[!duplicated(x)])
}

combi_v2 <- function(...){
  # ... must be vectors
  combi <- list(...)
  is_list <- unlist(lapply(combi, function(x){
    inherits(x, "list")
  }), use.names = FALSE)
  combi <- c(unlist(combi[is_list], recursive = FALSE),
             combi[!is_list])
  # Validations
  err_txt <- unlist(lapply(seq_len(length(combi)), function(i){
    x <- err_atomic_vectors(combi[[i]], paste0("vector ", i))
    x[x == FALSE] <- NA_character_
    x
  }), use.names = FALSE)
  err_txt <- err_txt[!is.na(err_txt)]
  if(length(err_txt) > 0) stop(err_txt, call. = FALSE)

  vec_lens <- unlist(lapply(combi, length), use.names = FALSE)
  dd_err <- vec_lens[!duplicated(vec_lens)]
  if(!(length(dd_err) == 1 | (length(dd_err) == 2 & 1 %in% dd_err))){
    err_txt <- paste0("Length of each vector in `...` must be the same or equal to 1:\n",
                      paste0("X - Length of vector ",
                             seq_len(length(vec_lens)),
                             " is ", vec_lens, ".",
                             collapse = "\n"))
    stop(err_txt, call. = FALSE)
  }

  combi[vec_lens == 1] <- NULL
  if(length(combi) == 0){
    return(rep(1, max(dd_err)))
  }

  combi <- lapply(combi, mk_cd)

  faC <- lapply(combi, function(x){
    faC <- as.integer(log10(max(x))) + 1
    return(faC)
  })

  faC <- unlist(faC, use.names = FALSE)
  faC <- faC + (length(faC)-1):0
  faC <- 10 ^ faC

  combi <- sapply(seq_len(length(faC)), function(i){
    combi[[i]] * faC[i]
  })

  combi <- rowSums(combi)
  combi <- match(combi, combi[!duplicated(combi)])

  rm(list = ls()[ls() != "combi"])
  return(combi)
}

concat.integer <- function(...){
  # ... must be vectors
  combi <- list(...)
  faC <- lapply(combi, function(x){
    faC <- as.integer(log10(max(x))) + 1L
    return(faC)
  })

  faC <- unlist(faC, use.names = FALSE)
  faC <- rev(cumsum(rev(faC)))
  faC <- c(faC, 0)

  faC <- c(faC[1:(length(faC)-1)], 0)
  faC <- 10 ^ faC

  combi <- sapply(seq_len(length(faC)-1L), function(i){
    combi[[i]] * faC[i+1]
  })

  if(inherits(combi, "matrix")){
    combi <- rowSums(combi)
  }else{
    combi <- sum(combi)
  }

  combi <- combi + faC[1]

  rm(list = ls()[ls() != "combi"])
  return(combi)
}

dst_tab <- function(x, order_by_label = NULL, order_by_val = TRUE){
  y <- rle(as.vector(x))
  if(is.null(order_by_label) & isTRUE(order_by_val)){
    pos <- order(-y$lengths)
  }else{
    pos <- match(order_by_label, y$values)
    pos <- pos[!is.na(pos)]
  }
  y$values <- y$values[pos]
  y$lengths <- y$lengths[pos]
  y
}

di_report <- function(duration = 0L, cumm_time = 0L, iteration = NA, current_tot = 0L,
                      current_tagged = 0L, current_skipped = 0L,
                      criteria = 0L, memory_used = 0L){
  x <- list(iteration = iteration,
            duration = duration,
            cumm_time = cumm_time,
            records_checked = as.integer(current_tot),
            records_tracked = as.integer(current_tagged),
            records_skipped = as.integer(current_skipped),
            criteria = as.integer(criteria),
            memory_used = as.numeric(memory_used)/(1000 * 1024))
  return(x)
}

permute_num <- function(x, r = 2){
  (((x ^ r) - x)/r) + x
}

inherit <- function(tag, cri, pid_cri, tie_sort, sn, pr_sn, expand, pid, link_id, upd_link_id = TRUE, old_link_id = NULL, sn_ref){
  hri <- seq_len(length(tag))
  s_tag <- tag
  s_tag[s_tag != 0 & !expand] <- 1
  s_tag[!expand] <- !s_tag[!expand]
  sort_ord <- order(cri, -s_tag, pid_cri, tie_sort, sn, decreasing = TRUE)
  rm(s_tag)
  cri <- cri[sort_ord]
  sn <- sn[sort_ord]
  pr_sn <- pr_sn[sort_ord]
  pid <- pid[sort_ord]
  pid_cri <- pid_cri[sort_ord]
  tag <- tag[sort_ord]
  link_id <- link_id[sort_ord]
  if(!is.null(old_link_id)){
    old_link_id <- old_link_id[sort_ord]
  }
  lgk <- which(!duplicated(cri, fromLast = TRUE))
  rep_lgk <- match(cri, cri[lgk])
  tr_pid <- (pid[lgk])[rep_lgk]
  tr_sn <- (sn[lgk])[rep_lgk]
  tr_tag <- (tag[lgk])[rep_lgk]
  rm(rep_lgk)
  lgk <- which(cri %in% cri[!duplicated(cri)] & tr_tag == 1 & cri > 0 & tag != 1 & expand)
  pid[lgk] <- tr_pid[lgk]
  if(upd_link_id){
    link_id[lgk] <- tr_sn[lgk]
  }else{
    # ll <- which(!duplicated(cri, fromLast = TRUE))
    # link_id[link_id %in% link_id[ll]] <- tr_sn[link_id %in% link_id[ll]]
    link_id[pr_sn %in% tr_sn & tr_tag == 1] <- old_link_id[pr_sn %in% tr_sn & tr_tag == 1]
  }
  lgk <- which(cri %in% cri[!duplicated(cri)] & tr_tag == 0 & cri > 0 & tag != 1)
  pid[lgk] <- tr_sn[lgk]
  if(upd_link_id){
    link_id[lgk] <- tr_sn[lgk]
  }else{

  }

  return(list(
    pid = pid,
    link_id = link_id,
    tag = tag,
    pid_cri = pid_cri,
    pr_sn = pr_sn,
    sn = sn
  ))
}

mk_lazy_opt <- function(x){
  class(x) <- "d_lazy_opts"
  return(x)
}

prep_prob_link_args <- function(attribute,
                                probabilistic,
                                m_probability,
                                u_probability){
  # u-probabilities
  if(is.null(u_probability)){
    u_probability <- list()
    u_probability$x <- lapply(attribute, function(x){
      x_cd <- match(x, x[!duplicated(x)])
      x_cd[is.na(x)] <- NA_real_
      r <- rle(x_cd[order(x_cd)])
      n <- r$lengths[match(x_cd, r$values)]
      p <- n/length(x_cd)
      p[is.na(x_cd)] <- 0
      p
    })
  }else if(!inherits(u_probability, c("list"))){
    u_probability <- list(x = list(u_probability))
  }
  attr_nm <- names(attribute)
  rm(attribute)
  if(length(u_probability$x) == 1 & length(attr_nm) > 1){
    u_probability$x <- rep(u_probability$x, length(attr_nm))
  }

  # m-probabilities
  if(!inherits(m_probability, c("list"))){
    m_probability <- list(x = list(m_probability))
  }
  if(length(m_probability$x) == 1 & length(attr_nm) > 1){
    m_probability$x <- rep(m_probability$x, length(attr_nm))
  }

  names(m_probability$x) <- names(u_probability$x) <- attr_nm

  return(list(m_probability = m_probability,
              u_probability = u_probability))
}

prep_cmps_thresh <- function(attr_nm,
                             cmp_func,
                             attr_threshold,
                             score_threshold){
  # Threshold for agreement in each attribute
  if(is.number_line(attr_threshold)){
    attr_threshold[attr_threshold@.Data < 0] <- reverse_number_line(attr_threshold[attr_threshold@.Data < 0], "decreasing")
  }else{
    attr_threshold <- suppressWarnings(number_line(attr_threshold, Inf))
  }

  if(length(attr_threshold) == 1 & length(attr_nm) > 1){
    attr_threshold <- rep(attr_threshold, length(attr_nm))
  }

  if(is.number_line(score_threshold)){
    score_threshold[score_threshold@.Data < 0] <- reverse_number_line(score_threshold[score_threshold@.Data < 0], "decreasing")
  }else{
    score_threshold <- suppressWarnings(number_line(score_threshold, Inf))
  }

  # String comparator for each attribute
  if(!inherits(cmp_func, c("list"))){
    cmp_func <- list(cmp_func)
  }
  if(length(cmp_func) == 1 & length(attr_nm) > 1){
    cmp_func <- rep(cmp_func, length(attr_nm))
  }

  names(attr_threshold) <-
    names(cmp_func) <- attr_nm

  return(list(cmp_func = cmp_func,
              attr_threshold = attr_threshold,
              score_threshold = score_threshold))
}

make_pairs_batch_legacy <- function(strata, assign_ord, index_record, sn, ignore_same_source = FALSE, data_source = NULL, look_back = FALSE){
  includes_multi_index <- any(index_record == -1)
  curr_ds_len <- length(strata)
  strata <- strata

  if(isTRUE(includes_multi_index) & isFALSE(look_back)){
    sc_ord <- order(strata, -(index_record != 0), assign_ord, decreasing = FALSE)
    assign_ord <- assign_ord[sc_ord]
  }else{
    sc_ord <- order(strata, -index_record, decreasing = FALSE)
  }

  sn <- sn[sc_ord]
  strata <- strata[sc_ord]
  index_record <- index_record[sc_ord]
  rc_sc_ord <- order(sc_ord)

  rrr <- rle(strata)
  lgk <- which(!duplicated(strata, fromLast = FALSE))

  pos_repo <- list(sn = sn)
  pos_repo$x_pos <- sn
  pos_repo$y_pos <- rep(pos_repo$x_pos[lgk], rrr$lengths)

  pos_repo$index_ord <- rep(1L, length(pos_repo[[1]]))
  if(isTRUE(includes_multi_index)){
    pos_repo$y_tot <- rep(rrr$lengths, rrr$lengths)
    if(isFALSE(look_back)){
      temporal_ord <- order(strata, abs(assign_ord), decreasing = FALSE)
      pos_repo$y_ord <- sequence(rrr$lengths)[temporal_ord]

    }
    pos_repo$y_ref <- rep(lgk, rrr$lengths)
    indx <- which(pos_repo$x_pos %in% sn[index_record == -1])
    tmp_pos <- pos_repo[-1]

    tmp_pos$x_pos <- tmp_pos$x_pos[indx]
    tmp_pos$y_pos <- tmp_pos$y_pos[indx]
    tmp_pos$y_tot <- tmp_pos$y_tot[indx]

    if(isFALSE(look_back)){
      tmp_pos$y_ord <- tmp_pos$y_ord[indx]
    }
    tmp_pos$y_ref <- tmp_pos$y_ref[indx]
    tmp_pos$index_ord <- tmp_pos$index_ord[indx]

    rrr <- rle(tmp_pos$y_pos)
    tmp_pos$index_ord <- sequence(rrr$lengths) + 1L

    if(isFALSE(look_back)){
      tmp_pos$y_tot <- (tmp_pos$y_tot - tmp_pos$y_ord) + 1
      tmp_pos$y_ref <- (tmp_pos$y_ref + tmp_pos$y_ord) - 1
    }

    tmp_pos$y_pos <- pos_repo$sn[temporal_ord][rep(tmp_pos$y_ref, tmp_pos$y_tot) + sequence(tmp_pos$y_tot, from = 0)]
    tmp_pos$x_pos <- rep(tmp_pos$x_pos, tmp_pos$y_tot)
    tmp_pos$index_ord <- rep(tmp_pos$index_ord, tmp_pos$y_tot)

    pos_repo <- lapply(pos_repo, function(x) x[rc_sc_ord])
    pos_repo$x_pos <-
      pos_repo$sn <- c(pos_repo$x_pos, tmp_pos$y_pos)
    pos_repo$y_pos <- c(pos_repo$y_pos, tmp_pos$x_pos)
    pos_repo$index_ord <- c(pos_repo$index_ord, tmp_pos$index_ord)
    tmp_pos <- pos_repo$y_ord <- pos_repo$y_ref <- pos_repo$y_tot <- NULL
  }

  if(!is.null(data_source) & isTRUE(ignore_same_source)){
    lgk <- which(data_source[pos_repo$x_pos] != data_source[pos_repo$y_pos])
    pos_repo <- lapply(pos_repo, function(x) x[lgk])
  }
  rm(list = ls()[ls() != "pos_repo"])
  return(pos_repo)
}

make_pairs_batched <- function(
    x,
    index_record = rep(TRUE, length(x)),
    strata = index_record,
    assign_ord = order(x),
    ignore_same_source = FALSE,
    data_source = NULL,
    look_back = FALSE,
    include_repeat = FALSE){

  tmp <- list(sn = order(strata, assign_ord))
  tmp$pr_sn <- seq_len(length(tmp[[1]]))
  tmp$strata <- strata[tmp$sn]
  lgk <- which(!duplicated(tmp$strata, fromLast = FALSE))
  rrr <- rle(tmp$strata)
  class(rrr) <- NULL

  tmp$strata_tot <- rep(rrr$lengths, rrr$lengths)
  tmp$rec_ord <- sequence(rrr$lengths)
  if(isFALSE(look_back)){
    tmp$strata_a_ord <- tmp$rec_ord
    tmp$strata_a_indx <- tmp$pr_sn
  }else{
    tmp$strata_a_ord <- rep(1, length(tmp[[1]]))
    tmp$strata_a_indx <- rep(lgk, rrr$lengths)
  }
  if(isFALSE(include_repeat)){
    tmp$strata_tot <- tmp$strata_tot - 1
  }

  tmp$reference_record <- index_record[tmp$sn]
  tmp_indexes <- lapply(tmp, function(x){
    x[tmp$reference_record == 1]
  })
  tmp_indexes$strata_tot_new <- tmp_indexes$strata_tot - tmp_indexes$strata_a_ord + 1

  rrr <- rle(tmp_indexes$strata)
  tmp_indexes$index_ord <- sequence(rrr$lengths)

  tmp2 <- list()
  tmp2$x_ord <- sequence(tmp_indexes$strata_tot_new)
  if(isFALSE(include_repeat)){
    if(isTRUE(look_back)){
      tmp2$y_ord <- rep(tmp_indexes$rec_ord, tmp_indexes$strata_tot_new)
      tmp2$y_tot <- rep(tmp_indexes$strata_tot_new, tmp_indexes$strata_tot_new)
      tmp2$lgk <- tmp2$x_ord == tmp2$y_ord
      tmp2$x_ord[tmp2$lgk] <- tmp2$y_tot[tmp2$lgk] + 1
    }else{
      tmp_indexes <- lapply(tmp_indexes, function(x){
        x[!tmp_indexes$strata_tot_new == 0]
      })
      tmp_indexes$strata_a_indx <- tmp_indexes$strata_a_indx + 1
    }
  }
  tmp2$x_pos <- tmp2$x_ord + rep(tmp_indexes$strata_a_indx, tmp_indexes$strata_tot_new) - 1
  tmp2$y_pos <- rep(tmp_indexes$pr_sn, tmp_indexes$strata_tot_new)
  tmp2$index_ord <- rep(tmp_indexes$index_ord, tmp_indexes$strata_tot_new)

  tmp2 <- tmp2[c("x_pos", "y_pos", "index_ord")]

  tmp2$x_pos <- tmp$sn[tmp2$x_pos]
  tmp2$y_pos <- tmp$sn[tmp2$y_pos]

  if(!is.null(data_source) & isTRUE(ignore_same_source)){
    lgk <- which(data_source[tmp2$x_pos] != data_source[tmp2$y_pos])
    tmp2 <- lapply(tmp2, function(x) x[lgk])
  }

  tmp2$x_val <- x[tmp2$x_pos]
  tmp2$y_val <- x[tmp2$y_pos]
  if(!is.null(strata)){
    tmp2$strata <- strata[tmp2$y_pos]
  }

  rm(list = ls()[ls() != "tmp2"])
  return(tmp2)
}

fmt_sub_criteria <- function(x, depth_n = 0, show_levels = FALSE){
  left_indent <- paste0(rep(" ", 2 * depth_n), collapse = "")
  operator_txt <- toupper(attr(x, "operator"))
  operator_txt <- paste0(" ", operator_txt," ")

  attr_n <- length(x)

  # if(FALSE){
  #   if(isTRUE(show_levels)){
  #     depth_attr_n_nm <- paste0("diyar.recurs.depth.", depth_n)
  #     if(!exists(depth_attr_n_nm, 0, envir = .GlobalEnv)){
  #       assign(depth_attr_n_nm, 0, envir = .GlobalEnv)
  #     }else{
  #       assign(
  #         depth_attr_n_nm,
  #         get(depth_attr_n_nm, envir = .GlobalEnv) + attr_n, envir = .GlobalEnv)
  #     }
  #   }
  # }

  logic_txt <- lapply(x, function(vv){
    mf_nm <- names(vv[2])
    if(length(mf_nm) == 0){
      mf_nm <- "match_func"
    }else if(mf_nm == ""){
      mf_nm <- "match_func"
    }
    at_nm <- names(vv[1])
    if(length(at_nm) == 0){
      at_nm <- ""
    }
    vv <- vv[[1]]
    if(inherits(vv, c("sub_criteria"))){
      paste0("\n", fmt_sub_criteria(vv, depth_n + 1, show_levels))
    }else{
      if(at_nm != ""){

      }else if(is.atomic(vv)){
        at_nm <- listr(trimws(format(vv[1:4])), lim = 3, sep = ",")
      }else{
        if(!is.null(names(vv))){
          at_nm <- paste0(class(vv), "; ", listr(paste0("`", names(vv), "`"), lim = 2))
        }else{
          at_nm <- class(vv)
        }
      }
      paste0(mf_nm, "(", at_nm, ")")
    }
  })

  if(isTRUE(show_levels)){
    logic_txt <- lapply(1:length(logic_txt), function(i){
      if(FALSE){
        i2 <- get(depth_attr_n_nm, envir = .GlobalEnv) + i
      }else{
        i2 <- i
      }
      if(grepl("^\\n", logic_txt[[i]])){
        paste0("\n", left_indent, "Lv.", depth_n, ".", i2, "-", logic_txt[[i]])
        gsub(" \\{\\n ", paste0(" Lv.", depth_n, ".", i2, "-", "{\n "), logic_txt[[i]])
      }else{
        paste0("Lv.", depth_n, ".", i2, "-", logic_txt[[i]])
      }
    })
  }
  logic_txt <- unlist(logic_txt, use.names = FALSE)
  if(ceiling(length(logic_txt)/2) == 1){
    logic_txt_row <- rep(1, length(logic_txt))
  }else{
    logic_txt_row <- as.numeric(cut(seq_len(length(logic_txt)), ceiling(length(logic_txt)/2)))
  }

  logic_txt <- split(logic_txt, logic_txt_row)
  logic_txt <- lapply(seq_len(length(logic_txt)), function(i){
    if(i == length(logic_txt)){
      paste0(logic_txt[[i]], collapse = operator_txt)
    }else{
      paste0(logic_txt[[i]], operator_txt, collapse = "")
    }
  })
  logic_txt <- unlist(logic_txt, use.names = FALSE)
  logic_txt <- paste0(logic_txt, collapse = paste0("\n", left_indent))
  depth_l <- ifelse(F, paste0("Lv", depth_n), "")

  logic_txt <- paste0(left_indent, "{", depth_l, "\n",
                      left_indent, logic_txt, "\n",
                      left_indent, "}")
  logic_txt <- gsub("\\n *\\n", "\n", logic_txt)
  logic_txt
}

rc_dv <- function(x, func = length, depth = 1, tgt_depth = Inf){
  if(inherits(x, c("d_attribute", "list")) & depth <= tgt_depth){
    lapply(x, function(x) rc_dv(x = x, func = func,
                                depth = depth + 1,
                                tgt_depth = tgt_depth))
  }else if (is.atomic(x)){
    func(x)
  }else{

  }
}

nl_bind <- function(...){
  return(c(...))
}

index_multiples <- function(x, multiples, repeats){
  y <- seq(0, multiples * (repeats - 1), by = multiples)
  r <- list()
  r$mi <- rep(x, repeats)
  r$mm <- r$mi + rep(y, rep(length(x), repeats))
  r$ord <- rep(seq_len(length(y)), rep(length(x), repeats))
  rm(x, repeats, multiples, y)
  return(r)
}

length_hits <- function(ep_checks, strata, current_tot, range.n){
  hits <- ceiling(seq_len(length(ep_checks)) / current_tot)
  hits <- hits[ep_checks]
  tmp_strata <- rep(strata, range.n)[ep_checks]
  if(range.n <= 308){
    hits <- hits / 10 ^ (floor(hits/10) + 1)
    hits <- tmp_strata + hits
  }else{
    hits <- combi(hits, tmp_strata)
  }
  hits <- tmp_strata[!duplicated(hits)]
  hits <- rle(sort(hits))
  hits <- hits$lengths[match(strata, hits$values)]
  return(hits)
}

is_even <- function(x){
  as.logical(x %% 2)
}

row_wise <- function(x, value = TRUE, type = "max"){
  type <- ifelse(type == "max", 1, -1)
  if(is.null(ncol(x))){
    x <- t(x)
  }
  y <- ((max.col(x * type) - 1) * nrow(x)) + seq_len(nrow(x))
  if(isTRUE(value)){
    y <- x[y]
  }
  return(y)
}

group_stats <- function(strata, start_date, end_date){
  dts_a <- lapply(split(as.numeric(start_date), strata), min)
  dts_z <- lapply(split(as.numeric(end_date), strata), max)

  interval <- number_line(as.numeric(dts_a), as.numeric(dts_z))
  interval <- interval[match(strata, as.numeric(names(dts_a)))]
  return(interval)
}

make_refs_V2 <- function(x_val, y_val, id_length = max(x_val, y_val), useAsPos = TRUE, na = NA_real_){
  if(length(x_val) == 0 & length(y_val) == 0){
    return(cbind(NA, NA))
  }
  repo <- list(x = x_val, y = y_val)
  repo <- cbind(x_val, y_val)

  ref_ord <- NULL
  if(!is.null(ref_ord)){
    repo$ref_ord <- ref_ord
  }
  if(isTRUE(useAsPos)){
    repo <- repo[order(repo[,1], repo[,2]),]
  }

  if(is.null(ncol(repo))){
    repo <- matrix(repo, ncol = 2)
  }
  x_val <- repo[,1][!duplicated(repo[,1])]
  if(isFALSE(useAsPos)){
    id_length <- length(x_val)
  }else{
    x_val <- seq_len(id_length)
  }
  if(is.null(ref_ord)){
    rrr <- rle(repo[,1])
    ref_ord <- sequence(rrr$lengths)
    ref_sn <- rep(seq_len(length(rrr$lengths)), rrr$lengths)
    repo <- cbind(repo, ref_sn, ref_ord)
  }
  mx_ord <- max(ref_ord)
  link_id <- rep(na, id_length * mx_ord)

  if(isTRUE(useAsPos)){
    x.mi <- ((ref_ord - 1) * id_length) + repo[,1]
    link_id[x.mi] <- y_val[repo[,2]]
  }else{
    x.mi <- ((ref_ord - 1) * id_length) + repo[,3]
    link_id[x.mi] <- repo[,2]
  }

  link_id <- matrix(c(x_val, link_id), nrow = id_length)
  colnames(link_id) <- c("x", paste0("y", 1:(ncol(link_id)-1)))
  return(link_id)
}

dv <- function(lst){
  min_ord <- order(lst$x.f, lst$y3)
  min_ord <- lapply(lst[c("x.f", "y3")], function(x) x[min_ord])
  lst$y3 <- min_ord$y3[match(lst$x.f, min_ord$x.f)]
  lst$y2a <- lst$y3[match(lst$y.f_bk, lst$x.f)]
  lst$lgk <- !is.na(lst$y2a) & lst$y2a < lst$y3
  lst$y3[lst$lgk] <- lst$y2a[lst$lgk]

  min_ord <- order(lst$y.f_bk, lst$y3)
  min_ord <- lapply(lst[c("y.f_bk", "y3")], function(x) x[min_ord])
  lst$y3 <- min_ord$y3[match(lst$y.f_bk, min_ord$y.f_bk)]
  lst$y2b <- lst$y3[match(lst$x.f, lst$y.f_bk)]
  lst$lgk <- !is.na(lst$y2b) & lst$y2b < lst$y3
  lst$y3[lst$lgk] <- lst$y2b[lst$lgk]

  rm(min_ord)
  if(all(lst$y.f == lst$y3)){
    return(lst)
  }else{
    dv(list(x.f_bk = lst$x.f_bk,
            y.f_bk = lst$y.f_bk,
            x.f = lst$x.f,
            y.f = lst$y3,
            y3 = lst$y3))
  }
}

unpack <- function(xx, depth = 0){
  classes <- unlist(lapply(xx, class))
  lgk <- classes == "list"
  xx.1 <- xx[!lgk]
  xx.2 <- unlist(xx[lgk], recursive = FALSE)
  if(length(xx.1) > 0){
    names(xx.1) <- paste0("var_", depth, ".", seq_len(length(xx.1)))
  }
  if(length(xx.2) > 0){
    names(xx.2) <- paste0("var_", depth + 1, ".", seq_len(length(xx.2)))
  }
  xx <- c(xx.1, xx.2)
  classes <- unlist(lapply(xx, class))
  lgk <- classes == "list"
  if(any(lgk)){
    # rm(list = ls()[!ls() %in% c("xx", "depth", "lgk")])
    unpack(xx, depth = depth + 1)
  }else{
    # rm(list = ls()[!ls() %in% c("xx", "depth", "lgk")])
    xx
  }
}

make_sets_v2 <- function (x, r, strata = NULL, permutations_allowed = TRUE, repeats_allowed = TRUE){
  if (!is.null(strata)) {
    strata <- match(strata, strata)
    pos <- seq_len(length(x))
    s_ord <- order(strata)
    strata <- strata[s_ord]
    pos <- pos[s_ord]
    rl <- rle(strata)
    n <- max(rl$lengths)
  }
  else {
    n <- length(x)
  }
  repo <- sets(n = n, r = r, permutations_allowed = permutations_allowed,
               repeats_allowed = repeats_allowed)
  if (!is.null(strata)) {
    sn <- seq_len(length(x))
    rl$start_sn <- sn[!duplicated(strata)]
    unq_lens <- rl$lengths[!duplicated(rl$lengths)]
    repo <- lapply(unq_lens, function(x) {
      exc_indx <- which(repo > x)
      exc_indx <- exc_indx%%nrow(repo)
      exc_indx[exc_indx == 0] <- nrow(repo)
      x.repo <- repo[!seq_len(nrow(repo)) %in% exc_indx,
      ]
      x.repo
    })
    repo <- repo[match(rl$lengths, unq_lens)]
    reps <- (unq_lens^2)
    reps <- reps[match(rl$lengths, unq_lens)]
    repo <- do.call("rbind", repo)
    start_sn <- rep(rep(rl$start_sn, reps), r)
    repo <- repo + (start_sn - 1)
    repo <- pos[repo]
    repo <- matrix(repo, ncol = r)
  }
  repo <- split(repo, rep(seq_len(r), rep(nrow(repo), r)))
  repo <- c(repo, lapply(repo, function(i) x[i]))
  names(repo) <- paste0("x", rep(1:r, 2), rep(c("_pos", "_val"),
                                              rep(r, 2)))
  rm(list = ls()[ls() != "repo"])
  return(repo)
}


make_pairs_batched_wf_episodes <- function(
    x, index_record, strata, assign_ord,
    ignore_same_source, data_source, lgk){

  a_indx <- which(lgk)
  b_indx <- which(!lgk)
  a <- make_pairs_batched(
    strata = strata[a_indx],
    x = x[a_indx],
    index_record = index_record[a_indx],
    assign_ord = assign_ord[a_indx],
    include_repeat = TRUE,
    look_back = TRUE
  )

  b <- make_pairs_batched(
    strata = strata[b_indx],
    x = x[b_indx],
    index_record = index_record[b_indx],
    assign_ord = assign_ord[b_indx],
    include_repeat = TRUE,
    look_back = FALSE
  )

  a$x_pos <- c(a$x_pos, b$x_pos)
  a$y_pos <- c(a$y_pos, b$y_pos)
  a$x_val <- c(a$x_val, b$x_val)
  a$y_val <- c(a$y_val, b$y_val)
  a$index_ord <- c(a$index_ord, b$index_ord)
  b <- NULL

  return(a)
}


mix_pos <- function(cu_pos.mi, tr_pos.mi, ld_pos.mi, cu_pos.ord, opt_levels){
  rp <- list(
    cu_pos.mi = cu_pos.mi, tr_pos.mi = tr_pos.mi,
    ld_pos.mi = ld_pos.mi, cu_pos.ord = cu_pos.ord)
  # default "r"
  rp$nwPos <- rp$cu_pos.mi
  for (lv in c("e", "w")){
    if(!any(lv %in% opt_levels)){
      next
    }
    nm <- lv
    nm[nm == "e"] <- "ld_pos.mi"
    nm[nm == "w"] <- "tr_pos.mi"
    # nm[nm == "r"] <- "cu_pos.mi"
    tmp.opts.lv <- seq_len(length(opt_levels))[opt_levels %in% lv]
    indx <- which(rp$cu_pos.ord %in% tmp.opts.lv)
    rp$nwPos[indx] <-
      rp[[nm]][indx]
  }

  return(rp$nwPos)
}

S4_to_list <- function(x, decode = TRUE, .Data_type = "epid"){
  decode_opt <- decode
  rm(decode)
  if(decode_opt){
    tmp.func <- decode
  }else{
    tmp.func <- identity
  }

  if(inherits(x, "pane")){
    window_list <- lapply(x@window_list, list)
    x@window_list <- list()
  }
  slot.nm <- methods::slotNames(x)
  slot.val <- lapply(slot.nm, function(nm){
    methods::slot(x, nm)
  })
  names(slot.val) <- slot.nm
  slot.val <- slot.val[slot.nm != "options"]
  names(slot.val) -> slot.nm

  lgk <- lapply(slot.val, function(x){
    inherits(x, "list")
  })
  lgk <- as.logical(lgk)
  if(any(lgk)){
    slot.val <- c(slot.val[!lgk],
                  unlist(slot.val[lgk], recursive = FALSE))
  }

  lgk <- lapply(slot.val, length) == 0
  slot.val <- slot.val[!lgk]

  names(slot.val) <- gsub("^wind_id\\.|^wind_nm\\.|^link_id\\." , "", names(slot.val))
  names(slot.val)[grepl(".Data", names(slot.val))] <- .Data_type

  names(slot.val) -> slot.nm
  slot.val <- lapply(slot.val, function(x){
    if(inherits(x, "d_label")){
      tmp.func(x)
    }else{
      x
    }
  })

  lgk <- grepl("interval$", slot.nm)
  if(any(lgk)){
    tmp.list <- list()
    tmp.list[[paste0(.Data_type,"_start")]] <- slot.val[lgk][[1]]@start
    tmp.list[[paste0(.Data_type,"_end")]] <- right_point(slot.val[lgk][[1]])
    slot.val <- c(slot.val[!lgk], tmp.list)
  }

  if(inherits(x, "pane")){
    slot.val$window_list <- window_list[match(slot.val$pane, names(window_list))]
    names(slot.val$window_list) <- NULL
  }
  return(slot.val)
}

missing_wf.null <- function(x){
  l <- FALSE
  if(missing(x)){
    return(TRUE)
  }else{
    is.null(x)
  }
}

round_to <- function(x, to, f = round){
  r <- (as.numeric(x) %% to)
  (x - r) + (f(r/to) * to)
}

concat.integer_v1 <- function(a, z){
  faC <- as.integer(log10(max(z, na.rm = TRUE))) + 1L
  faC <- 10 ^ faC
  a <- (a * faC) + z
  a
}

id_total <- function(x){
  rr <- rle(sort(x))
  x <- rr$lengths[match(x, rr$values)]
  x
}

extract.opts <- function(..., ref.func){
  opt_lst <- list(...)
  def_list <- formals(ref.func)
  named_pos <- which(names(opt_lst) %in% names(def_list))
  unamed_pos <- seq_len(length(opt_lst))[!seq_len(length(opt_lst)) %in% named_pos]
  unnamed_args <- names(def_list)[!names(def_list) %in% names(opt_lst)]
  unnamed_args <- unnamed_args[unamed_pos]
  names(opt_lst)[unamed_pos] <- unnamed_args

  opt_lst <- c(
    opt_lst,
    def_list[names(def_list)[!names(def_list) %in% names(opt_lst)]]
  )

  opt_lst <- lapply(opt_lst, function(x){
    if(inherits(x, "call")){
      return(eval(x))
    }else if(inherits(x, "name")){
      return(opt_lst[[x]])
    }else{
      return(x)
    }
  })

  return(opt_lst)
}