R/err_checks.R

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

# @title Data validations
#
# @description Data validations
#
err_sub_criteria_1 <- function(...){
  args <- list(...)
  err <- lapply(args, function(x){
    if(is.atomic(x) | inherits(x, c("d_attribute", "sub_criteria"))){
      NA_character_
    }else{
      class(x)
    }
  })
  err <- unlist(err, use.names = FALSE)
  if(length(err) > 0) names(err) <- 1:length(err)
  err <- err[!is.na(err)]

  if(length(err) > 0){
    paste0("Invalid object type for `...` in `sub_criteria()`:\n",
           "i - `...` must be an `atomic` vector OR,\n",
           "i - `...` must be a `d_attribute` object OR,\n",
           "i - `...` must be a `sub_criteria` object.\n",
           paste0("X - `...` ", "contains is a `", err,"` object.", collapse = "\n"))
  }else{
    FALSE
  }
}

err_sub_criteria_2 <- function(funcs, funcs_l){
  try_txt <- try(lapply(funcs, function(x){}), silent = T)
  if(inherits(try_txt, "try-error")){
    paste0("Unable to evaluate `",funcs_l,"`.:\n",
           "Issue - \"",attr(try_txt, "condition")$message, "\"")

  }else{
    FALSE
  }
}

err_sub_criteria_3 <- function(funcs, funcs_l){
  err <- sapply(funcs, is.function)
  if(length(err) > 0) names(err) <- 1:length(err)
  err <- err[!err]
  if(length(err) > 0){
    err <- paste0("`",funcs_l,"` must be a function or a `list` of functions:\n",
                  "X - `",funcs_l,"[c(", listr(names(err), conj = ",", lim=3), ")]` ",
                  ifelse(length(err ==1), "is not a function.", "are not functions."))
    err
  }else{
    F
  }
}

err_sub_criteria_4 <- function(..., funcs, funcs_l){
  if(!length(funcs) %in% c(0, 1, length(list(...)))){
    lens <- length(list(...))
    return(paste0("Number of logical test (`",funcs_l,"`) must be 1 or the same as the number of matching attributes (`...`):\n",
                  "i - Expecting 1", ifelse(lens > 1, paste0(" or ", lens), ""), ".\n",
                  "X - You've supplied ", length(funcs), " logical tests (`",funcs_l,"`)."))

  }else{
    FALSE
  }
}

err_sub_criteria_6.0 <- function(sub_cris, funcs_l = "match_funcs", funcs_pos = 2, cri_nm = "sub_criteria"){
  err <- lapply(seq_len(length(sub_cris)), function(i){
    l1 <- sub_cris[[i]]
    y <- lapply(seq_len(length(l1)), function(j){
      l2 <- l1[[j]]
      func <- l2[[funcs_pos]]
      vec <- l2[[1]]
      if(inherits(vec, "list")){
        vec <- lapply(vec, function(x) x[1:5])
      }else{
        vec <- vec[1:5]
      }
      try_txt <- try(func(x = vec, y = vec), silent = T)
      if(inherits(try_txt, "try-error")){
        attr(try_txt, "condition")$message
      }else if(!inherits(try_txt, "logical")){
        "Output is not a `logical` object"
      }else{
        NA
      }
    })
    y <- unlist(y)
    names(y) <- paste0("`", funcs_l, "` ", seq_len(length(y)), " of ", toupper(names(sub_cris)[i]))
    y
  })

  err <- unlist(err, use.names = FALSE)
  err <- err[!is.na(err)]
  if(length(err) > 0){
    err <- paste0("Unable to evaluate `", funcs_l, "` in `", cri_nm, "`:\n",
                  "i - Each `", funcs_l, "` must have the following syntax and output.\n",
                  "i - Syntax ~ `function(x, y, ...)`.\n",
                  "i - Output ~ `TRUE` or `FALSE`.\n",
                  paste0("X - Issues with ", names(err) ,": ",
                         err, ".", collapse = "\n"))
    err
  }else{
    F
  }
}

err_sub_criteria_6.1 <- function(sub_cris, funcs_l, cri_nm = "sub_criteria"){
  err <- lapply(seq_len(length(sub_cris)), function(i){
    l1 <- sub_cris[[i]]
    y <- lapply(seq_len(length(l1)), function(j){
      l2 <- l1[[j]]
      func <- l2[[2]]
      vec <- l2[[1]]
      try_txt <- try(func(x = vec), silent = T)
      if(inherits(try_txt, "try-error")){
        attr(try_txt, "condition")$message
      }else if(!inherits(try_txt, "logical")){
        "Output is not a `logical` object"
      }else{
        NA
      }
    })
    y <- unlist(y)
    names(y) <- paste0("`funcs` ", seq_len(length(y)), " of ", toupper(names(sub_cris)[i]))
    y
  })

  err <- unlist(err, use.names = FALSE)
  err <- err[!is.na(err)]
  if(length(err) > 0){
    err <- paste0("Unable to evaluate `funcs` in `", cri_nm, "`:\n",
                  "i - Each `func` must have the following syntax and output.\n",
                  "i - Syntax ~ `function(x, ...)`.\n",
                  "i - Output ~ `TRUE` or `FALSE`.\n",
                  paste0("X - Issues with ", names(err) ,": ",
                         err, ".", collapse = "\n"))
    err
  }else{
    F
  }
}

err_sub_criteria_5.0 <- function(sub_cris, funcs_l = "match_funcs", funcs_pos = 2, cri_nm = "sub_criteria"){
  f1 <- function(l1){
    sb_attr <- l1[[1]]
    func <- l1[[funcs_pos]]
    if(inherits(sb_attr, "sub_criteria")){
      f1(sb_attr[[1]])
    }else{
      all(c("x", "y") %in% methods::formalArgs(func))
    }
  }

  err <- lapply(sub_cris, f1)
  err <- unlist(err, use.names = FALSE)

  if(length(err[!err]) > 0){
    err <- paste0("Invalid arguments for `", funcs_l, "`:\n",
                  "i - Each `", funcs_l, "` must have at least two arguments named `x` and `y`.\n")
    err
  }else{
    F
  }
}

err_sub_criteria_7 <- function(sub_cris, funcs_l = "match_funcs", funcs_pos = 2, cri_nm = "case_sub_criteria"){
  err <- lapply(seq_len(length(sub_cris)), function(i){
    l1 <- sub_cris[[i]]
    y <- lapply(seq_len(length(l1)), function(j){
      l2 <- l1[[j]]
      func <- l2[[funcs_pos]]
      vec <- l2[[1]]
      if(inherits(vec, "list")){
        vec <- lapply(vec, function(x) x[1:5])
      }else{
        vec <- vec[1:5]
      }
      e <- try(func(vec, vec),
               silent = TRUE)
      x <- class(e)
      ifelse(x == "logical" & length(e) %in% c(1,5), NA_character_, paste0("Issue with ",
                                                                           "`", funcs_l, "-", j, "` of ",
                                                                           "`", cri_nm, "-", i, "`: ",
                                                                           gsub("\\n", "", e),"."))
    })
    y
  })

  err <- unlist(err, use.names = FALSE)
  err <- err[!is.na(err)]
  if(length(err) > 0){
    err <- paste0("Invalid ouput for `", funcs_l, "`:\n",
                  "i - Each `", funcs_l, "` output must have a length of 1 or the same length as `...`.\n",
                  "i - Each `", funcs_l, "` output must evaluate to `TRUE` or `FALSE`.\n",
                  paste0("X - ", err, collapse = "\n"))
    err
  }else{
    F
  }
}

err_sub_criteria_9 <- function(sub_cris, funcs_l, cri_nm = "sub_criteria"){
  err <- lapply(seq_len(length(sub_cris)), function(i){
    l1 <- sub_cris[[i]]
    y <- lapply(seq_len(length(l1)), function(j){
      l2 <- l1[[j]]
      func <- l2[[2]]
      vec <- l2[[1]]
      e <- func(vec)
      x <- class(e)
      ifelse(x == "logical" & length(e) == 1, NA_character_, x)
    })
    y <- unlist(y)
    names(y) <- paste0("`funcs` ", seq_len(length(y)), " of ", toupper(names(sub_cris)[i]))
    y
  })

  err <- unlist(err, use.names = FALSE)
  err <- err[!is.na(err)]
  if(length(err) > 0){
    err <- paste0("Invalid ouput for `funcs` in `", cri_nm, "` :\n",
                  "i - Output of each `funcs` must have a length of 1.\n",
                  "i - Output of each `funcs` must evaluate to `TRUE` or `FALSE`.\n",
                  paste0("X - ", names(err),": returns a ", err, "` object.", collapse = "\n"))
    err
  }else{
    F
  }
}

err_sub_criteria_8 <- function(x, cri_nm = "sub_criteria"){
  err <- err_object_types(x, cri_nm, c("sub_criteria", "list"))
  if(!isFALSE(err)) {
    return(err)
  }
  else{
    return(FALSE)
  }
}

err_data_links_1 <- function(data_source, data_links){
  # data_links - Each element must be named g or l ####
  dl_lst <- unlist(data_links, use.names = FALSE)
  ds_lst <- data_source[!duplicated(data_source)]
  ms_lst <- unique(dl_lst[!dl_lst %in% c(ds_lst,"ANY")])

  if(is.list(data_links) & !is.null(data_source)){
    nms <- names(data_links);
    names(nms) <- 1:length(nms)
    nms <- nms[!tolower(nms) %in% c("l","g","") ]
    nms
    invalid_opts <- ifelse(length(nms) > 2,
                           paste0(paste0("\"", head(nms, 2), "\"", " in [",head(names(nms),2),"]", collapse = ", "), " ..."),
                           paste0(listr(paste0("\"", nms, "\"", " in [", names(nms),"]")), "."))

    err_title <- "Invalid element names for `data_links`:\n"
    errs <- paste0(err_title,
                   "i - Each element in `data_link` (list) must be named \"l\" (links) or \"g\" (groups).\n",
                   "i - Syntax 1 - `data_links` <- list(l = c(\"DS1\", \"DS2\"), g = c(\"DS3\", \"DS4\"))\n",
                   "i - Syntax 2 - `data_links` <- c(\"l\" = \"DS5\")\n",
                   "i - \"l\" - Only return record-groups with records from \"DS1\" AND \"DS2\" `data_source`.`\n",
                   "i - \"g\" - Only return record-groups with records from \"DS3\" OR  \"DS4\" `data_source`.`\n",
                   paste0("X - You've supplied ", invalid_opts))

    if(length(nms)>0) errs else F
  }else{
    F
  }
}

err_data_links_2 <- function(data_source, data_links){
  dl_lst <- unlist(data_links, use.names = FALSE)
  dl_lst <- as.character(dl_lst)
  ds_lst <- data_source[!duplicated(data_source)]
  ds_lst <- as.character(ds_lst)
  ms_lst <- unique(dl_lst[!dl_lst %in% c(ds_lst,"ANY")])

  # data_links - Values must match what's in data_sources ####
  if(length(ms_lst)>0 & !all(toupper(dl_lst)=="ANY") & !is.null(data_source)){
    invalid_opts <- ifelse(length(ms_lst) > 4,
                           paste0(paste0("\"", head(ms_lst,4), "\"", collapse = ", "), " ..."),
                           paste0(listr(paste0("\"", ms_lst,"\"")), "."))

    valid_opts <- ifelse(length(ds_lst) > 4,
                         paste0(paste0("\"", head(ds_lst, 4), "\"", collapse = ", "), " ..."),
                         paste0(listr(paste0("\"", ds_lst, "\"")), "."))

    err_title <- "Invalid values for `data_links`:\n"
    errs <- paste0(err_title,
                   "i - Valid values are those in `data_source` i.e. ", valid_opts, "\n",
                   "X - You've supplied ", invalid_opts)
    errs
  }else{
    F
  }
}

err_criteria_1 <- function(criteria){
  if(!inherits(criteria, "list")){
    criteria <- list(criteria)
  }

  err <- lapply(criteria, function(x){
    ifelse(is.atomic(x), NA_character_, class(x))
  })
  err <- unlist(err, use.names = FALSE)
  if(length(err) > 0) names(err) <- 1:length(err)
  err <- err[!is.na(err)]

  if(length(err) > 0){
    paste0("Invalid object type for `criteria`:\n",
           "i - `criteria` must be an `atomic` vector or a `list of `atomic` vectors.\n",
           paste0("X - `criteria ", names(err),"` is a ", err, ".", collapse = "\n"))
  }else{
    F
  }
}

err_criteria_2 <- function(criteria){
  if(!inherits(criteria, "list")){
    criteria <- list(criteria)
  }

  err <- lapply(criteria, length)
  err <- unlist(err, use.names = FALSE)
  if(length(err) > 0) names(err) <- 1:length(err)
  err <- err[!duplicated(err)]

  if(!min(err) %in% c(1, max(err)) | min(err) == 0){
    paste0("Length of each `criteria` must be the same and greater than 0 or equal to 1:\n",
           paste0("X - `criteria ", names(err),"` is ", fmt(err), ".", collapse = "\n"))
  }else{
    F
  }
}

err_sub_criteria_10 <- function(ref_arg, sub_criteria, arg_nm = "criteria", cri_nm = "sub_criteria"){
  if(!inherits(ref_arg, "list")){
    ref_arg <- list(ref_arg)
  }

  if(inherits(sub_criteria, "sub_criteria")){
    sub_criteria <- list(sub_criteria)
  }
  err <- as.numeric(lapply(ref_arg, length))
  err <- err[!duplicated(err)]

  err2 <- lapply(sub_criteria, function(x){
    attr_eval(x, identity, simplify = FALSE)
  })
  err2 <- unpack(err2)
  err2 <- lapply(err2, length)
  err2 <- unlist(err2, use.names = FALSE)
  err2 <- sort(err2[!duplicated(err2)])
  if(any(!c(err, err2) %in% c(1, max(c(err, err2))))){
    return(paste0("Length of each `", arg_nm, "` and each attribute of `", cri_nm, "` must be the same or equal to 1:\n",
                  # "i - Expecting ", listr(unique(c(1, err)), conj = " or "), ".\n",
                  "X - ", ifelse(length(err) == 1, "Length", "Lengths")," of `", arg_nm, "` ", ifelse(length(err) == 1, "is", "are"), " ", listr(fmt(sort(err))), ".\n",
                  "X - ", ifelse(length(err2) == 1, "Length", "Lengths")," of attribute(s) in `", cri_nm, "` ", ifelse(length(err2) == 1, "is", "are"), " ", listr(fmt(sort(err2))), "."))
  }else{
    F
  }
}

err_sub_criteria_10b <- function(sub_criteria){
  nms <- names(sub_criteria)
  nms <- nms[nms %in% nms[duplicated(nms)]]
  nms <- rle(nms)
  if(length(nms$lengths) > 0){
    return(paste0("Multiple `sub_criteria` objects assinged to a `criteria`:\n",
                  "i - Only one `sub_criteria` object can be assinged to a `criteria`.\n",
                  "i - Instead, nest all match criteria in one `sub_criteria` object.\n",
                  "i - Example ~ `sub_criteria(X, sub_criteria(Y), operator = \"and\")`.\n",
                  paste0("X - ", nms$lengths, " `sub_criteria` object(s) assinged to Criteria-", gsub("^cr", "", nms$values), " (`", nms$values, "`)", collapse = "\n")
    )
    )
  }else{
    F
  }
}

err_sub_criteria_3dot_1 <- function(...){
  err <- lapply(list(...), function(x){
    attr_eval(x, rc_dv)
  })
  err <- unlist(err, use.names = FALSE)
  err <- sort(err[!duplicated(err)])
  err2 <- err[err != 1]

  if(length(err2) > 1){
    paste0("Different lengths for each attribute (`...`) of a `sub_criteria`:\n",
           "i - Each attribute in (`...`) must have the same length or a length of 1.\n",
           "i - This includes recursive evaluations of `d_attribute` and `sub_criteria` objects.\n",
           paste0("X - `...` ", "contains elements of lengths ", listr(err),".", collapse = "\n"))
  }else{
    FALSE
  }
}

err_sn_1 <- function(sn, ref_nm, ref_num){
  if(!inherits(sn, c("numeric", "integer", "NULL"))){
    err <- paste0("Invalid object type for `sn`:\n",
                  "i - Valid object type is `integer`.\n",
                  "i - `numeric` objects are coerced to `integer` objects.\n",
                  "i - Duplicate values (after coercion) are not permitted.\n",
                  "X - You've supplied a `", class(sn), "` object.")
    return(err)
  }

  if(!inherits(sn, "NULL")){
    if(length(sn) != ref_num){
      err <- paste0("Length of `sn` must be the same as `", ref_nm, "`:\n",
                    "i - Expecting a length of ", fmt(ref_num), ".\n",
                    "X - Length is ", fmt(length(sn)), ".\n")
      return(err)
    }

    dp_check <- duplicates_check(as.integer(sn))
    if(dp_check != T){
      err <- paste0("`sn` must be unique values.\n",
                    "i - `numeric` objects are coerced to `integer` objects.\n",
                    "i - Duplicate values (after coercion) are not permitted.\n",
                    "X - There are duplicate values in ", dp_check ,".")
      return(err)
    }

    fn_check <- finite_check(sn)
    if(fn_check!=T){
      err <- paste0("`sn` must be finite `integer` values:\n",
                    "X - There are non-finite values in ",fn_check)
      return(err)
    }
  }
  return(FALSE)
}

err_episode_unit_1 <- function(episode_unit){
  if(any(!tolower(episode_unit) %in% names(diyar::episode_unit))){
    opts <- episode_unit
    sn <- 1:length(opts)

    opts <- split(sn , opts)
    opts <- opts[!tolower(names(opts)) %in% names(episode_unit)]

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

    opts <- paste0("\"", names(opts),"\"", " at ", opts)
    if(length(opts) >3){
      errs <- paste0(paste0(opts[1:3], collapse = ", "), " ...")
    }  else{
      errs <- listr(opts)
    }
    errs <-  paste0("Invalid values for `episode_unit`:\n",
                    "i - Vaild values are ", listr(paste0("\"", names(diyar::episode_unit), "\""), conj = " or "), ".\n",
                    "X - You've supplied ", errs, ".")

    return(errs)
  }else{
    return(FALSE)
  }
}

err_by_1 <- function(by){
  if(any( by <= 0)){
    by[by <= 0] <- NA_real_
    err <- missing_check(by)

    if(err != FALSE){
      err <-  paste0("Invalid values for `by`:\n",
                     "i - `by' must be greater than 0.\n",
                     "X - `by' is less than 1 at ", err, ".")
      return(err)
    }

  }

  return(FALSE)
}
err_by_2 <- function(by, x){
  x <- as.number_line(x)
  lgk <- (x@.Data > 0 & by < 0) | (x@.Data < 0 & by > 0)
  if(any(lgk)){
    by[lgk] <- NA_real_
    err <- missing_check(by)

    if(err != FALSE){
      err <-  paste0("Incorrect sign for `by`:\n",
                     "i - \"+\" and \"-\" are required for \"increasing\" and \"decreasing\" `number_lines' respectively.\n",
                     "X - Incorrect sign at ", err, ".")
      return(err)
    }

  }

  return(FALSE)
}

err_lnt_out_1 <- function(length.out){
  if(any( length.out  <= 0)){
    length.out [length.out  <= 0] <- NA_real_
    err <- missing_check(length.out )

    if(err != FALSE){
      errs <-  paste0("Invalid values for `length.out `:\n",
                      "i - `length.out' must be greater than 0.\n",
                      "X - `length.out' is less than 1 at ", errs, ".")
      return(errs)
    }

  }

  return(FALSE)
}

err_overlap_methods_1 <- function(overlap_methods, overlap_methods_nm){
  if(!(inherits(overlap_methods, "list"))){
    overlap_methods <- list(overlap_methods)
  }

  err <- lapply(overlap_methods, overlaps_err)
  names(err) <- seq_len(length(err))
  err <- unlist(err, use.names = T)

  if(length(err) > 0){
    err <- paste0("Invalid option for `", overlap_methods_nm, "`\n",
                  "i - Valid options can be values in `diyar::overlap_methods$options$cd`.\n",
                  "i - Valid options can be values in `names(diyar::overlap_methods$methods)`.\n",
                  "i - Syntax 1 ~ `100`.\n",
                  "i - Syntax 2 ~ `\"aligns_end|exact...\"`.\n",
                  "i - Syntax 3 ~ `include_overlap_method(c(\"aligns_end\", \"exact\"))`.\n",
                  "i - Syntax 4 ~ `exclude_overlap_method(c(\"across\", \"chain\", \"aligns_start\", \"inbetween\")`).\n",
                  paste0("X - `", overlap_methods_nm, " ", names(err),   "`: You've supplied ", err, ".", collapse = "\n"))
    return(err)
  }else{
    return(FALSE)
  }
}

err_overlap_methods_2 <- function(overlap_methods, lengths, overlap_methods_nm, lengths_nm){
  # overlap_methods - Check if there are more overlap methods than there are lengths

  if(!inherits(lengths, "list")){
    lengths <- list(lengths)
  }
  if(!inherits(overlap_methods, "list")){
    overlap_methods <- list(overlap_methods)
  }
  if(!length(overlap_methods) %in% c(1, length(lengths))){
    errs <- paste0("`", overlap_methods_nm, "` must have one element or the same number in `", lengths_nm ,"`:\n",
                   "X - `", overlap_methods_nm, "` has ", length(overlap_methods)," ", ifelse(length(overlap_methods) == 1, "element", "elements"), "\n",
                   "X - `", lengths_nm, "` has ", length(lengths)," ", ifelse(length(lengths) == 1, "element", "elements"),".")
    return(errs)
  }else{
    return(FALSE)
  }
}

err_missing_check <- function(x, arg_nm, lim =10){
  err <- missing_check(x, lim = lim)
  if(err != T){
    err <- paste0("`", arg_nm, "` must not contain missing values:\n",
                  "X - Missing values in ",  err, ".")
    return(err)
  }else{
    return(FALSE)
  }
}

err_match_ref_len <- function(arg, ref_nm, ref_len, arg_nm){
  if(!inherits(arg, "list")){
    arg <- list(arg)
    multi_opts <- F
  }else{
    multi_opts <- T
  }
  err <- unlist(lapply(arg, function(x){
    x <- length(x)
    ifelse(!x %in% c(ref_len), x, NA_real_)
  }), use.names = FALSE)
  if(length(err) > 0) names(err) <- 1:length(err)
  err <- err[!is.na(err)]

  if(length(err) > 0){
    err <- paste0("Invalid length for ", ifelse(multi_opts, "elements in ", ""), "`", arg_nm, "`:\n",
                  ifelse(ref_nm == "", "", paste0("i - Length must be ", ifelse(1 %in% ref_len,"1 or", ""), " the same as `", ref_nm, "`.\n")),
                  "i - Expecting a length of ", listr(fmt(unique(ref_len)), conj = " or "), ".\n",
                  paste0("X - ", ifelse(rep(multi_opts, fmt(length(err))), paste0("`", arg_nm, " ", names(err), "`: "), ""), "Length is ", fmt(err), ".", collapse = "\n"))
    return(err)
  }
  return(FALSE)
}

err_match_ref_len_2 <- function(arg, ref_nm, ref_len, arg_nm, multi_opts = FALSE){
  if(inherits(arg, "list")){
    unlist(lapply(arg, function(x){
      err_match_ref_len_2(x, ref_nm, ref_len, arg_nm, multi_opts = TRUE)
    }), use.names = FALSE)
  }
  else{
    err <- length(arg)
    err <- ifelse(!err %in% c(ref_len), err, NA_real_)
    if(length(err) > 0) names(err) <- 1:length(err)
    err <- err[!is.na(err)]

    if(length(err) > 0){
      err <- paste0("Invalid length for ", ifelse(multi_opts, "elements in ", ""), "`", arg_nm, "`:\n",
                    paste0("i - Length must be ", ifelse(1 %in% ref_len,"1", ""), ref_nm, ".\n"),
                    ifelse(ref_nm == "",
                           "",
                           paste0("i - Expecting a length of ", listr(fmt(unique(ref_len)), conj = " or "), ".\n")),
                    paste0("X - ", ifelse(rep(multi_opts, fmt(length(err))), paste0("`", arg_nm, " ", names(err), "`: "), ""), "Length is ", fmt(err), ".", collapse = "\n"))
      return(err)
    }else{
      return(FALSE)
    }
  }

  if(!inherits(arg, "list")){
    arg <- list(arg)
    multi_opts <- F
  }else{
    multi_opts <- T
  }


  return(FALSE)
}

err_object_types <- function(arg, arg_nm, obj_types){

  if(inherits(arg, "list")){
    unlist(lapply(arg, function(x){
      err_object_types(x, arg_nm, obj_types)
    }), use.names = FALSE)
  }else{
    x <- class(arg)
    if(!any(x %in% obj_types)){
      err <- listr(paste0("`", x[!x %in% obj_types], "`"), conj = " or ")
    }else{
      err <- NA_character_
    }
    err <- err[!is.na(err)]

    if(length(err) > 0){
      obj_types <- ifelse(obj_types == "logical", "logical (TRUE or FALSE)", obj_types)
      obj_types <- paste0("`", obj_types, "`")
      if("`list`" %in% obj_types){
        obj_types <- obj_types[!obj_types %in% "`list`"]
        obj_types <- c(obj_types,
                       paste0("a `list` with ", listr(paste0(obj_types), conj = " or "), " elements"))
      }
      valid_opts <- listr(paste0(obj_types), conj = " or ")
      err <- paste0("Invalid object type for `", arg_nm, "`.\n",
                    "i - Valid object type", ifelse(length(obj_types) > 1, "s are", " is"),  " ", valid_opts, ".\n",
                    paste0("X - You've supplied a ", err, " object.", collapse = "\n"))
      return(err)
    }else{
      return(FALSE)
    }
  }
}

err_object_types_2 <- function(arg, arg_nm, obj_types){
  if("list" %in% obj_types & inherits(arg, "list")){
    unlist(lapply(arg, function(x){
      err_object_types_2(x, arg_nm, obj_types)
    }), use.names = FALSE)
  }else if("atomic" %in% obj_types){
    unlist(err_atomic_vectors_2(arg, arg_nm), use.names = FALSE)
  }else{
    x <- class(arg)
    if(!any(x %in% obj_types)){
      err <- listr(paste0("`", x[!x %in% obj_types], "`"), conj = " or ")
    }else{
      err <- NA_character_
    }
    err <- err[!is.na(err)]
    if(length(err) > 0){
      obj_types <- ifelse(obj_types == "logical", "logical (TRUE or FALSE)", obj_types)
      obj_types <- paste0("`", obj_types, "`")
      if("`list`" %in% obj_types){
        obj_types <- obj_types[!obj_types %in% "`list`"]
        obj_types <- c(obj_types,
                       paste0("a `list` with ", listr(paste0(obj_types), conj = " or "), " elements"))
      }
      valid_opts <- listr(paste0(obj_types), conj = " or ")

      err <- paste0("Invalid object type for `", arg_nm, "`.\n",
                    "i - Valid object type ", ifelse(length(valid_opts) > 1, "are", "is"),  ": ", valid_opts, ".\n",
                    paste0("X - You've supplied: ", err, collapse = "\n"))
      return(err)
    }else{
      return(FALSE)
    }
  }
}

err_split_nl_1 <- function(x,
                           by,
                           length.out,
                           fill,
                           simplify){
  # Check for non-atomic vectors
  args <- list(x = x,
               by = by,
               length.out = length.out,
               fill = fill,
               simplify = simplify)

  err <- mapply(err_atomic_vectors_2,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object types
  args <- list(x = x,
               by = by,
               length.out = length.out,
               fill = fill,
               simplify = simplify)

  args_classes <- list(x = c("number_line"),
                       by = c("integer", "numeric", "NULL"),
                       length.out = c("integer", "numeric", "NULL"),
                       fill = "logical",
                       simplify = "logical")

  err <- mapply(err_object_types,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  len_lims <- c(1, length(x))
  args <- list(by = by,
               length.out = length.out,
               fill = fill,
               simplify = simplify)

  args_lens <- list(by = c(len_lims, 0),
                    length.out = c(len_lims, 0),
                    fill = len_lims,
                    simplify = len_lims)

  err <- mapply(err_match_ref_len,
                args,
                rep(as.list("date"), length(args_lens)),
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for missing values where they are not permitted
  args <- list(by = by,
               length.out = length.out,
               fill = fill,
               simplify = simplify)

  err <- mapply(err_missing_check,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  err <- err_by_2(by, x)
  if(err != FALSE) return(err[1])
  err <- err_lnt_out_1(length.out)
  if(err != FALSE) return(err[1])

  errs_l <- finite_check(x@start)
  errs_r <- finite_check(x@.Data)

  if(errs_l != T | errs_r != T){
    errs <- paste0("`x` must have finite left and right points:\n",
                   ifelse(errs_l != T, paste0("X - There are non-finite values in `left_point(x)", errs_l, "`.\n"), ""),
                   ifelse(errs_r != T, paste0("X - There are non-finite values in `right_point(x)", errs_r, "`."), ""))
    return(errs)
  }

  fn_check <- finite_check(by)
  if(fn_check!=T) return(paste0("`by` must have finite values:\n",
                                paste0("X - There are non-finite values in `by",fn_check, "`.")))

  return(FALSE)
}

err_episodes_checks_0 <- function(date = 1, case_length = 1, episode_type = "fixed", recurrence_length = case_length,
                                  episode_unit = "days", strata = 1, sn = seq_len(length(date)), episodes_max = 1, rolls_max = 1,
                                  case_overlap_methods = 8, recurrence_overlap_methods = case_overlap_methods,
                                  skip_if_b4_lengths = FALSE, data_source = "1",
                                  data_links = "ANY", custom_sort = 1, skip_order = 1, reference_event = "last_record",
                                  case_for_recurrence = FALSE, from_last = FALSE, group_stats = c("case_nm", "wind", "epid_interval"),
                                  display = "none", case_sub_criteria = NULL, recurrence_sub_criteria = NULL,
                                  case_length_total = 1, recurrence_length_total = case_length_total,
                                  skip_unique_strata = TRUE, skip_checks = NULL, batched = "semi", ...){

  # Check for required object types
  args <- list(date = date,
               case_length = case_length,
               recurrence_length = recurrence_length,
               episode_type = episode_type,
               case_overlap_methods = case_overlap_methods,
               recurrence_overlap_methods = recurrence_overlap_methods,
               episode_unit = episode_unit,
               display = display,
               data_source = data_source,
               episodes_max = episodes_max,
               rolls_max = rolls_max,
               skip_if_b4_lengths = skip_if_b4_lengths,
               data_links = data_links,
               skip_order = skip_order,
               reference_event = reference_event,
               case_for_recurrence = case_for_recurrence,
               from_last = from_last,
               group_stats = group_stats,
               case_length_total = case_length_total,
               recurrence_length_total = recurrence_length_total,
               case_sub_criteria = case_sub_criteria,
               recurrence_sub_criteria = recurrence_sub_criteria,
               skip_unique_strata = skip_unique_strata,
               batched = batched)

  args_classes <- list(date = c("Date","POSIXct", "POSIXt", "POSIXlt", "number_line", "numeric", "integer"),
                       episode_type = "character",
                       case_overlap_methods = c("list", "numeric", "integer", "character"),
                       recurrence_overlap_methods = c("list", "numeric", "integer", "character"),
                       episode_unit = "character",
                       display = "character",
                       case_length = c("list", "integer", "numeric", "number_line"),
                       recurrence_length = c("list", "integer", "numeric", "number_line"),
                       episodes_max = c("numeric", "integer"),
                       rolls_max = c("numeric", "integer"),
                       data_source = c("NULL", "character"),
                       data_links = c("list", "character"),
                       skip_order = c("numeric", "integer"),
                       skip_if_b4_lengths = "logical",
                       reference_event = c("character", "logical"),
                       case_for_recurrence = "logical",
                       from_last = "logical",
                       group_stats = c("logical", "character", "NULL"),
                       case_length_total = c("numeric", "integer", "number_line"),
                       recurrence_length_total = c("numeric", "integer", "number_line"),
                       case_sub_criteria = c("sub_criteria", "NULL"),
                       recurrence_sub_criteria = c("sub_criteria", "NULL"),
                       skip_unique_strata = "logical",
                       batched = "character")

  err <- mapply(err_object_types_2,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  if(length(date) == 0){
    return(
      paste0("Invalid length for `date`:\n",
             "i - Length must be greater than 0.\n",
             "X - Length is ", fmt(length(date)), ".\n")
    )
  }
  # Check for required object lengths
  len_lims <- c(1, length(date))
  args <- list(case_length = case_length,
               recurrence_length = recurrence_length,
               episode_type = episode_type,
               episode_unit= episode_unit,
               case_overlap_methods = case_overlap_methods,
               recurrence_overlap_methods = recurrence_overlap_methods,
               display = display,
               strata = strata,
               custom_sort = custom_sort,
               episodes_max = episodes_max,
               rolls_max = rolls_max,
               data_source = data_source,
               #data_links = data_links,
               skip_order = skip_order,
               skip_if_b4_lengths = skip_if_b4_lengths,
               reference_event = reference_event,
               case_for_recurrence = case_for_recurrence,
               case_length_total = case_length_total,
               recurrence_length_total = recurrence_length_total,
               skip_unique_strata = skip_unique_strata,
               batched = batched)

  args_lens <- list(episode_type = len_lims,
                    case_overlap_methods = len_lims,
                    recurrence_overlap_methods = len_lims,
                    episode_unit = len_lims,
                    display = 1,
                    case_length = len_lims,
                    strata = c(0, len_lims),
                    custom_sort = c(0, len_lims),
                    recurrence_length = len_lims,
                    episodes_max = len_lims,
                    rolls_max = len_lims,
                    data_source = c(0, len_lims),
                    #data_links = len_lims,
                    skip_order = len_lims,
                    skip_if_b4_lengths = len_lims,
                    reference_event = len_lims,
                    case_for_recurrence = len_lims,
                    case_length_total = len_lims,
                    recurrence_length_total = len_lims,
                    skip_unique_strata = 1,
                    batched = 1)

  err <- mapply(err_match_ref_len_2,
                args,
                c(
                  rep(as.list(" or the same length as `date`"), 4),
                  as.list(""),
                  rep(as.list(" or the same length as `date`"), 13),
                  rep(as.list(""), 2)
                )
                ,
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for missing values where they are not permitted
  args <- list(episode_type = episode_type,
               case_overlap_methods = case_overlap_methods,
               recurrence_overlap_methods = recurrence_overlap_methods,
               display = display,
               episodes_max = episodes_max,
               rolls_max = rolls_max,
               data_source = data_source,
               data_links = data_links,
               skip_order = skip_order,
               skip_if_b4_lengths = skip_if_b4_lengths,
               reference_event = reference_event,
               case_for_recurrence = case_for_recurrence,
               case_length_total = case_length_total,
               recurrence_length_total = recurrence_length_total,
               skip_unique_strata = skip_unique_strata)

  err <- mapply(err_missing_check,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  len_lims <- c(1, length(date))
  args <- list(case_length = case_length,
               recurrence_length = recurrence_length,
               case_overlap_methods = case_overlap_methods,
               recurrence_overlap_methods = recurrence_overlap_methods,
               data_links = data_links)

  args_opt_lv <- list(case_length = c("", "r", "e", "w"),
                      recurrence_length = c("", "r", "e", "w"),
                      case_overlap_methods = c("", "r", "e", "w"),
                      recurrence_overlap_methods = c("", "r", "e", "w"),
                      data_links = c("", "l", "g"))

  err <- mapply(err_option_level,
                args,
                args_opt_lv[match(names(args), names(args_opt_lv))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])


  err <- err_data_links_1(data_source = data_source, data_links = data_links)
  if(err != FALSE) return(err)
  err <- err_data_links_2(data_source = data_source, data_links = data_links)
  if(err != FALSE) return(err)
  err <- err_episode_unit_1(episode_unit = episode_unit)
  if(err != FALSE) return(err)
  err <- err_spec_vals(episode_type, "episode_type", c("fixed", "rolling"))
  if(err != FALSE) return(err)
  err <- err_spec_vals(batched, "batched", c("yes", "semi", "no"))
  if(err != FALSE) return(err)
  err <- err_spec_vals(display, "display", c("none", "progress", "stats", "none_with_report", "progress_with_report", "stats_with_report"))
  if(err != FALSE) return(err)
  err <- err_spec_vals(reference_event, "reference_event", c("all_record", "first_record", "first_event", "last_record", "last_event",  TRUE, FALSE))
  if(err != FALSE) return(err)
  err <- err_spec_vals(group_stats, "group_stats", c("case_nm", "wind", "epid_interval", TRUE, FALSE, NULL))
  if(err != FALSE) return(err)
  err <- err_overlap_methods_1(overlap_methods = case_overlap_methods, "case_overlap_methods")
  if(err != FALSE) return(err)
  err <- err_overlap_methods_1(overlap_methods = recurrence_overlap_methods, "recurrence_overlap_methods")
  if(err != FALSE) return(err)
  err <- err_overlap_methods_2(overlap_methods = case_overlap_methods, lengths = case_length, overlap_methods_nm = "case_overlap_methods", lengths_nm = "case_length")
  if(err != FALSE) return(err)
  err <- err_overlap_methods_2(overlap_methods = recurrence_overlap_methods, lengths = recurrence_length, overlap_methods_nm = "recurrence_overlap_methods", lengths_nm = "recurrence_length")
  if(err != FALSE) return(err)
  err <- err_sn_1(sn = sn, ref_num = length(date), ref_nm = "date")
  if(err != FALSE) return(err)
  if(!"strata_level" %in% skip_checks){
    err <- err_strata_level_args(from_last, strata, "from_last")
    if(err != FALSE) return(err)
    err <- err_strata_level_args(episodes_max, strata, "episodes_max")
    if(err != FALSE) return(err)
  }
  if(!inherits(case_sub_criteria, "NULL")){
    err <- err_sub_criteria_8(case_sub_criteria, cri_nm = "case_sub_criteria")
    if(err != FALSE) return(err[1])
    err <- err_sub_criteria_10(date, case_sub_criteria, "date", cri_nm = "case_sub_criteria")
    if(err != FALSE) return(err)
  }

  if(!inherits(recurrence_sub_criteria, "NULL")){
    err <- err_sub_criteria_8(recurrence_sub_criteria, cri_nm = "recurrence_sub_criteria")
    if(err != FALSE) return(err[1])
    err <- err_sub_criteria_10(date, recurrence_sub_criteria, "date", cri_nm = "recurrence_sub_criteria")
    if(err != FALSE) return(err)
  }

  err <- err_mins_1(case_length_total, "case_length_total")
  if(err != FALSE) return(err)
  err <- err_mins_1(recurrence_length_total, "recurrence_length_total")
  if(err != FALSE) return(err)
  return(FALSE)
}

err_links_checks_0 <- function(
    criteria,
    sub_criteria,
    sn,
    strata,
    data_source,
    data_links,
    display,
    group_stats,
    expand,
    shrink,
    recursive,
    check_duplicates,
    tie_sort,
    repeats_allowed,
    permutations_allowed,
    ignore_same_source,
    batched){

  # Check for required object types
  args <- list(
    data_source = data_source,
    display = display,
    group_stats = group_stats,
    expand = expand,
    shrink = shrink,
    recursive = recursive,
    sub_criteria = sub_criteria,
    criteria = criteria,
    tie_sort = tie_sort,
    strata = strata,
    check_duplicates = check_duplicates,
    repeats_allowed = repeats_allowed,
    permutations_allowed = permutations_allowed,
    ignore_same_source = ignore_same_source,
    batched = batched)

  args_classes <- list(display = "character",
                       data_source = c("character", "NULL"),
                       data_links = c("list", "character"),
                       shrink = "logical",
                       expand = "logical",
                       group_stats = "logical",
                       recursive = c("character", "logical"),
                       sub_criteria = c("list", "sub_criteria", "NULL"),
                       criteria = c("list", "atomic"),
                       tie_sort = "atomic",
                       strata = "atomic",
                       check_duplicates = "logical",
                       repeats_allowed = "logical",
                       permutations_allowed = "logical",
                       ignore_same_source = "logical",
                       batched = "character")

  err <- mapply(err_object_types_2,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  if(!inherits(criteria, "list")){
    criteria <- list(criteria)
  }
  len_lims <- c(1, length(criteria[[1]]))
  if(!is.null(sub_criteria)){
    scri.attrs.len <- lapply(sub_criteria, function(x){
      attr_eval(x, rc_dv)
    })
    scri.attrs.len <- unlist(scri.attrs.len, use.names = FALSE)
    len_lims <- max(c(len_lims, scri.attrs.len))
  }
  args <- list(data_source = data_source,
               display = display,
               group_stats = group_stats,
               expand = expand,
               shrink = shrink,
               recursive = recursive,
               check_duplicates = check_duplicates,
               tie_sort = tie_sort,
               repeats_allowed = repeats_allowed,
               permutations_allowed = permutations_allowed,
               ignore_same_source = ignore_same_source,
               batched = batched,
               strata = strata)

  args_lens <- list(data_source = c(0, len_lims),
                    display = 1,
                    group_stats = 1,
                    expand = 1,
                    shrink = 1,
                    recursive = 1:4,
                    check_duplicates = 1,
                    tie_sort = c(0, len_lims),
                    repeats_allowed = 1,
                    permutations_allowed = 1,
                    ignore_same_source = 1,
                    batched = 1,
                    strata = c(0, len_lims))

  err <- mapply(err_match_ref_len_2,
                args,
                c(as.list(" or the same length as each attribute in the match crtieria"),
                  rep(as.list(""), 6),
                  as.list(" or the same length as each attribute in the match crtieria"),
                  rep(as.list(""), 3),
                  rep(as.list(" or the same length as each attribute in the match crtieria"), 2)
                ),
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  err <- err_data_links_1(data_source = data_source, data_links = data_links)
  if(err != FALSE) return(err)

  err <- err_data_links_2(data_source = data_source, data_links = data_links)
  if(err != FALSE) return(err)

  if(!inherits(criteria, "list")){
    criteria <- list(criteria)
  }

  if(!inherits(sub_criteria, "NULL")){
    err <- err_sub_criteria_8(sub_criteria)
    if(any(err != FALSE)) return((err[err != FALSE])[1])
    err <- err_sub_criteria_10(criteria, sub_criteria)
    if(err != FALSE) return(err)
    err <- err_sub_criteria_10b(sub_criteria)
    if(err != FALSE) return(err)
  }
  err <- err_criteria_1(criteria)
  if(err != FALSE) return(err)
  err <- err_criteria_2(criteria)
  if(err != FALSE) return(err)
  err <- err_spec_vals(display, "display", c("none", "progress", "stats",
                                             "none_with_report", "progress_with_report",
                                             "stats_with_report"))
  if(err != FALSE) return(err)
  err <- err_spec_vals(batched, "batched", c("yes", "semi", "no"))
  if(err != FALSE) return(err)
  err <- err_spec_vals(recursive, "recursive", c("linked", "unlinked", "none", TRUE, FALSE))
  if(err != FALSE) return(err)
  return(FALSE)
}

err_atomic_vectors <- function(arg, arg_nm){
  if(!inherits(arg, "list")){
    arg <- list(arg)
    multi_opts <- F
  }else{
    multi_opts <- T
  }
  err <- unlist(lapply(arg, is.atomic), use.names = FALSE)
  if(length(err) > 0) names(err) <- 1:length(err)
  err <- err[!err]

  if(length(err) > 0){
    err <- paste0(ifelse(multi_opts, "Input for ", ""), "`", arg_nm, "` must be an `atomic` vector.`\n")
    return(err)
  }else{
    return(FALSE)
  }
}

err_atomic_vectors_2 <- function(arg, arg_nm){
  err <- is.atomic(arg) | is.null(arg)
  if(isFALSE(err)){
    return(paste0("`", arg_nm, "` must be an `atomic` vector.`\n"))
  }else{
    return(FALSE)
  }
}

err_invalid_opts <- function(arg_vals, arg_nm, valid_opts){
  errs <- invalid_opts(arg_vals, valid_opts)
  if(length(errs) > 0){
    errs <-  paste0("Invalid values for `", arg_nm, "`:\n",
                    "i - Vaild values are ", listr(paste0("\"", valid_opts, "\""), conj = " or "), ".\n",
                    "X - You've supplied ", errs, ".")
    return(errs)
  }else{
    return(FALSE)
  }
}

err_strata_level_args <- function(arg, strata, arg_nm, strata_l = "`strata`"){
  one_val <- arg[!duplicated(arg)]
  one_val <- length(arg) == 1
  if(!one_val){
    if(inherits(strata, "NULL")){
      strata <- "NULL"
    }
    sp <- split(arg, strata)
    opts <- lapply(sp, function(x){
      x <- x[!duplicated(x)]
      length(x)
    })

    opts <- unlist(opts, use.names = FALSE)
    names(opts) <- names(sp)
    opts <- opts[opts > 1]

    if(length(opts) > 0){
      errs <- paste0("Unique values of `", arg_nm, "` required for every record of each ", strata_l, ":\n",
                     paste0("X - Different values in records of `strata`: ", listr(paste0("\"", names(opts), "\""), lim = 3), "."))
      return(errs)
    }else{
      return(FALSE)
    }
  }else{
    return(FALSE)
  }
}

err_partitions_checks_0 <- function(
    date,
    window,
    windows_total ,
    separate,
    sn,
    strata,
    data_source,
    data_links,
    custom_sort,
    group_stats,
    by,
    length.out,
    fill,
    display){

  # browser()
  if(!inherits(window, "list")){
    window <- list(window)
  }
  # Check for required object types
  args <- list(
    date = date,
    window = window,
    windows_total  = windows_total ,
    separate = separate,
    strata = strata,
    custom_sort = custom_sort,
    data_source = data_source,
    data_links = data_links,
    group_stats = group_stats,
    by = by,
    length.out = length.out,
    fill = fill,
    group_stats = group_stats,
    display = display )

  args_classes <- list(
    date = c("Date","POSIXct", "POSIXt", "POSIXlt", "number_line", "numeric", "integer"),
    window = c("numeric", "integer", "number_line", "list", "NULL"),
    windows_total  = c("number_line", "numeric", "integer"),
    separate = "logical",
    strata = "atomic",
    custom_sort = "atomic",
    data_source = "atomic",
    data_links = c("list", "character"),
    group_stats = "logical",
    by = c("numeric", "integer", "NULL"),
    length.out = c("numeric", "integer", "NULL"),
    fill = "logical",
    group_stats = "logical",
    display = "character")

  err <- mapply(err_object_types_2,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  len_lims <- c(1, length(date))
  args <- list(separate = separate,
               strata = strata,
               window = window,
               custom_sort = custom_sort,
               data_source = data_source,
               by = by,
               length.out = length.out,
               fill = fill,
               group_stats = group_stats,
               display = display)

  args_lens <- list(separate = 1,
                    strata = c(0, len_lims),
                    window = c(0, len_lims),
                    custom_sort = c(0, len_lims),
                    data_source = c(0, len_lims),
                    by = c(0, len_lims),
                    length.out = c(0, len_lims),
                    fill = c(0, len_lims),
                    group_stats = 1,
                    display = 1)

  err <- mapply(err_match_ref_len_2,
                args,
                c(
                  rep(as.list(""), 1),
                  " or the same length as `date`",
                  " or the same length as `date`",
                  rep(as.list(""), 7)
                ),
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for missing values where they are not permitted
  args <- list(window = window,
               windows_total  = windows_total ,
               separate = separate,
               strata = strata,
               custom_sort = custom_sort,
               data_source = data_source,
               data_links = data_links,
               by = by,
               length.out = length.out,
               fill = fill,
               group_stats = group_stats,
               display = display)

  err <- mapply(err_missing_check,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  err <- err_data_links_1(data_source = data_source, data_links = data_links)
  if(err != FALSE) return(err)
  err <- err_data_links_2(data_source = data_source, data_links = data_links)
  if(err != FALSE) return(err)
  err <- err_sn_1(sn = sn, ref_num = length(date), ref_nm = "date")
  if(err != FALSE) return(err)
  err <- err_strata_level_args(separate, strata, "separate")
  if(err != FALSE) return(err)

  if(!is.null(by)){
    err <- err_by_2(by, date)
    if(err != FALSE) return(err[1])

    err <- err_strata_level_args(by, strata, "by")
    if(err != FALSE) return(err)
  }

  if(!is.null(length.out)){
    err <- err_lnt_out_1(length.out)
    if(err != FALSE) return(err[1])

    err <- err_strata_level_args(length.out, strata, "length.out")
    if(err != FALSE) return(err)
  }

  err <- err_strata_level_args(fill, strata, "fill")
  if(err != FALSE) return(err)
  err <- err_strata_level_args(windows_total , strata, "windows_total")
  if(err != FALSE) return(err)

  if(!is.null(window)){
    if(is.number_line(window)){
      window <- list(window)
    }
    err <- err_strata_level_args(window , strata, "window")
  }
  if(err != FALSE) return(err)
  err <- err_spec_vals(display, "display", c("none", "progress", "stats"))
  if(err != FALSE) return(err)
  return(FALSE)
}

err_spec_vals <- function(x, var, vals){
  if(any(!tolower(x) %in% tolower(vals))){
    opts <- x
    sn <- 1:length(opts)

    opts <- split(sn , opts)
    opts <- opts[!tolower(names(opts)) %in% tolower(vals)]

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

    opts <- paste0("\"", names(opts),"\"", " at ", opts)
    if(length(opts) >3){
      errs <- paste0(paste0(opts[1:3], collapse = ", "), " ...")
    }  else{
      errs <- listr(opts)
    }
    errs <-  paste0("Invalid values for `",var, "`:\n",
                    "i - Vaild values are ", listr(paste0("\"", vals, "\""), conj = " or "), ".\n",
                    "X - You've supplied ", errs, ".")

    return(errs)
  }else{
    return(FALSE)
  }
}

err_mins_1 <- function(x, arg){
  lgk <- start_point(as.number_line(x)) < 1
  if(any(lgk)){
    opts <- x
    sn <- 1:length(opts)
    opts <- split(sn[lgk] , format(opts[lgk]))
    opts <- head(opts, 5)
    opts <- unlist(lapply(opts, function(x){
      missing_check(ifelse(sn %in% x, NA, T), 2)
    }), use.names = T)

    opts <- paste0("\"", names(opts),"\"", " at ", opts)
    if(length(opts) >3){
      errs <- paste0(paste0(opts[1:3], collapse = ", "), " ...")
    }  else{
      errs <- listr(opts)
    }
    errs <-  paste0("Invalid values for `", arg, "`:\n",
                    "i - Vaild values are ", "integers > 0", ".\n",
                    "X - You've supplied ", errs, ".")
    return(errs)
  }else{
    F
  }
}

err_schema_epid_0 <- function(
    x,
    date,
    case_length,
    recurrence_length,
    episode_unit,
    from_last,
    title,
    show_labels,
    show_skipped,
    show_non_finite,
    theme){

  err <- err_object_types(x, "x", "epid")
  if(err != FALSE) return(err)
  err <- err_match_ref_len(date, "x", length(x), "date")
  if(err != FALSE) return(err)

  errs <- err_episodes_checks_0(
    date = date, case_length = case_length,
    recurrence_length = recurrence_length,
    episode_unit = episode_unit,
    from_last = from_last,
    skip_checks = "strata_level")

  if(!isFALSE(errs)) return(errs)

  # Check for non-atomic vectors
  args <- list(title = title,
               show_labels = show_labels,
               show_skipped = show_skipped,
               show_non_finite = show_non_finite,
               theme = theme)

  err <- mapply(err_atomic_vectors_2,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object types
  args <- list(title = title,
               show_labels = show_labels,
               show_skipped = show_skipped,
               show_non_finite = show_non_finite,
               theme = theme)

  args_classes <- list(title = c("character", "NULL"),
                       show_labels = c("character", "logical"),
                       show_skipped = "logical",
                       show_non_finite = "logical",
                       theme = "character")

  err <- mapply(err_object_types,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  len_lims <- 1
  args <- list(title = title,
               #show_labels = show_labels,
               show_skipped = show_skipped,
               show_non_finite = show_non_finite,
               theme = theme)

  args_lens <- list(title = c(0, len_lims),
                    #show_labels = len_lims,
                    show_skipped = len_lims,
                    show_non_finite = len_lims,
                    theme = len_lims)

  err <- mapply(err_match_ref_len,
                args,
                rep(as.list("x"), length(args_lens)),
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for missing values where they are not permitted
  args <- list(title = title,
               show_labels = show_labels,
               show_skipped = show_skipped,
               show_non_finite = show_non_finite,
               theme = theme)

  err <- mapply(err_missing_check,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  err <- err_spec_vals(show_labels, "show_labels", c(TRUE, FALSE, "sn", "epid", "date", "case_nm", "wind_nm", "length",
                                                     "length_arrow", "case_overlap_methods","recurrence_overlap_methods"))
  if(err != FALSE) return(err[1])

  err <- err_spec_vals(theme, "theme", c("dark", "light"))
  if(err != FALSE) return(err[1])

  return(FALSE)
}

err_schema_pane_0 <- function(
    x,
    date,
    title,
    show_labels,
    theme){

  err <- err_object_types(x, "x", "pane")
  if(err != FALSE) return(err)
  err <- err_match_ref_len(date, "x", length(x), "date")
  if(err != FALSE) return(err)

  errs <- err_episodes_checks_0(date = date)
  if(!isFALSE(errs)) return(errs)

  # Check for non-atomic vectors
  args <- list(title = title,
               show_labels = show_labels,
               theme = theme)

  err <- mapply(err_atomic_vectors_2,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object types
  args <- list(title = title,
               show_labels = show_labels,
               theme = theme)

  args_classes <- list(title = c("character", "NULL"),
                       show_labels = c("character", "logical"),
                       theme = "character")

  err <- mapply(err_object_types,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  len_lims <- 1
  args <- list(title = title,
               #show_labels = show_labels,
               theme = theme)

  args_lens <- list(title = c(0, len_lims),
                    #show_labels = len_lims,
                    theme = len_lims)

  err <- mapply(err_match_ref_len,
                args,
                rep(as.list("x"), length(args_lens)),
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for missing values where they are not permitted
  args <- list(title = title,
               show_labels = show_labels,
               theme = theme)

  err <- mapply(err_missing_check,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  err <- err_spec_vals(show_labels, "show_labels", c(TRUE, FALSE, "sn", "pane", "date", "case_nm", "window_label"))
  if(err != FALSE) return(err[1])

  err <- err_spec_vals(theme, "theme", c("dark", "light"))
  if(err != FALSE) return(err[1])

  return(FALSE)
}

err_schema_pid_0 <- function(
    x,
    title,
    show_labels,
    theme,
    orientation){

  err <- err_object_types(x, "x", "pid")
  if(err != FALSE) return(err)

  # Check for non-atomic vectors
  args <- list(title = title,
               show_labels = show_labels,
               theme = theme,
               orientation = orientation)

  err <- mapply(err_atomic_vectors_2,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object types
  args <- list(title = title,
               show_labels = show_labels,
               theme = theme,
               orientation = orientation)

  args_classes <- list(title = c("character", "NULL"),
                       show_labels = c("character", "logical"),
                       theme = "character",
                       orientation = "character")

  err <- mapply(err_object_types,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  len_lims <- 1
  args <- list(title = title,
               #show_labels = show_labels,
               theme = theme,
               orientation = orientation)

  args_lens <- list(title = c(0, len_lims),
                    #show_labels = len_lims,
                    theme = len_lims,
                    orientation = len_lims)

  err <- mapply(err_match_ref_len,
                args,
                rep(as.list("x"), length(args_lens)),
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for missing values where they are not permitted
  args <- list(title = title,
               show_labels = show_labels,
               theme = theme,
               orientation = orientation)

  err <- mapply(err_missing_check,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  err <- err_spec_vals(show_labels, "show_labels", c(TRUE, FALSE, "sn", "pane", "date", "case_nm", "window_label"))
  if(err != FALSE) return(err[1])

  err <- err_spec_vals(orientation, "orientation", c("by_pid", "by_pid_cri", "by_iteration"))
  if(err != FALSE) return(err[1])

  err <- err_spec_vals(theme, "theme", c("dark", "light"))
  if(err != FALSE) return(err[1])

  return(FALSE)
}


err_sub_criteria_funcs <- function(..., funcs, funcs_l){
  if(!inherits(funcs, "list")){
    funcs <- list(funcs)
  }

  err <- err_sub_criteria_2(funcs = funcs, funcs_l = funcs_l)
  if(!isFALSE(err)) return(err)

  err <- err_sub_criteria_3(funcs = funcs, funcs_l = funcs_l)
  if(!isFALSE(err)) return(err)

  err <- err_sub_criteria_4(..., funcs = funcs, funcs_l = funcs_l)
  if(!isFALSE(err)) return(err)

  return(FALSE)
}

err_links_wf_probablistic_0 <- function(attribute,
                                        blocking_attribute,
                                        cmp_func,
                                        attr_threshold,
                                        probabilistic,
                                        m_probability,
                                        u_probability,
                                        score_threshold,
                                        id_1, id_2){
  # Check for non-atomic vectors
  args <- list(blocking_attribute = blocking_attribute,
               attr_threshold = attr_threshold,
               probabilistic = probabilistic,
               # m_probability = m_probability,
               # u_probability = u_probability,
               score_threshold = score_threshold,
               id_1 = id_1, id_2 = id_2)

  err <- mapply(err_atomic_vectors_2,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object types
  args <- list(
    # attribute = attribute,
    attr_threshold = attr_threshold,
    probabilistic = probabilistic,
    m_probability = m_probability,
    u_probability = u_probability,
    score_threshold = score_threshold,
    cmp_func = cmp_func,
    id_1 = id_1, id_2 = id_2)

  args_classes <- list(
    # attribute = c("list", "data.frame", "matrix", "d_attribute"),
    attr_threshold = c("list", "numeric", "integer", "number_line"),
    probabilistic = "logical",
    m_probability = c("list", "numeric", "integer"),
    u_probability = c("list", "numeric", "integer", "NULL"),
    score_threshold = c("list", "numeric", "integer", "number_line"),
    cmp_func = c("list", "function"),
    id_1 = c("NULL", "numeric", "integer"),
    id_2 = c("NULL", "numeric", "integer"))

  err <- mapply(err_object_types,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  if(inherits(attribute, c("list", "data.frame"))){
    attribute <- attrs(.obj = attribute)
  }else if(inherits(attribute, c("matrix"))){
    attribute <- attrs(.obj = as.data.frame(attribute))
  }else if(inherits(attribute, c("d_attribute"))){

  }else{
    attribute <- attrs(attribute)
  }

  err <- unlist(lapply(attribute, is.atomic), use.names = FALSE)
  if(length(which(!err)) > 0){
    err <- paste0("`attribute` must be an `atomic` object or `d_attribute` with `atomic` elements:\n")
    return(err)
  }

  lens <- unlist(lapply(attribute, attr_eval), use.names = FALSE)
  if(!is.null(blocking_attribute)){
    lens <- c(lens, length(blocking_attribute))
  }
  lens <- lens[!duplicated(lens)]
  if(length(lens) != 1 & length(blocking_attribute) != 1){
    err <- paste0("Lengths of `blocking_attribute` and each attribute must be the same or equal to 1")
    return(err)
  }
  # lens_2 <- unlist(lapply(list(id_1, id_2), attr_eval), use.names = FALSE)
  lens_2 <- c(length(id_1), length(id_2))
  lens_2 <- lens_2[!duplicated(lens_2)]
  if(length(lens_2) != 1){
    err <- paste0("Lengths of `id_1` and `id_2` must be the same or equal to 1")
    return(err)
  }

  lens <- seq_len(max(lens))
  id_1 <- id_1[!duplicated(id_1)]
  id_2 <- id_2[!duplicated(id_2)]
  err_1 <- which(!as.integer(id_1) %in% lens)
  err_2 <- which(!as.integer(id_2) %in% lens)
  if(length(err_1) + length(err_2) != 0){
    err <- paste0("`id_1` and `id_2` must be an index of the record set:\n",
                  paste0("X - Index ", listr(c(id_1[err_1], id_2[err_2]), lim =5), " do not exist"))
    return(err)
  }

  err <- c("m_probability" = length(m_probability),
           "u_probability" = length(u_probability),
           "cmp_func" = length(cmp_func),
           "attr_threshold" = length(attr_threshold))
  if(is.null(u_probability)){
    err <- err[names(err) != "u_probability"]
  }
  ref_err <- length(attribute)
  err_lgk <- which(ref_err != err & err != 1)
  if(any(which(ref_err != err & err != 1))){
    err <- paste0("Lengths of `cmp_func`, `attr_threshold`, `m_probability` and `u_probability` must be 1 or match the number of attributes supplied:\n",
                  "i - Expecting lengths of 1 or ", ref_err, "\n",
                  paste0("X - Length of `", names(err[err_lgk]), "` is ", err[err_lgk], ".", collapse = "\n"))
    return(err)
  }


  if(!inherits(m_probability, "list")){
    m_probability <- as.list(m_probability)
  }
  err <- lapply(m_probability, function(x) !all(x >= 0 & x <= 1))
  err <- unlist(err, use.names = FALSE)
  if(length(err[err]) > 0){
    err <- paste0("m-probabilities must be between 0 and 1:\n",
                  paste0("X - `m_probability[[", which(err), "]]` is ", m_probability[[which(err)]], ".", collapse = "\n"))
    return(err)
  }

  if(!is.null(u_probability)){
    if(!inherits(u_probability, "list")){
      u_probability <- as.list(u_probability)
    }
    err <- lapply(u_probability, function(x) !all(x >= 0 & x <= 1))
    err <- unlist(err, use.names = FALSE)
    if(length(err[err]) > 0){
      err <- paste0("u-probabilities must be between 0 and 1:\n",
                    paste0("X - `u_probability[[", which(err), "]]` is ", u_probability[[which(err)]], ".", collapse = "\n"))
      return(err)
    }
  }
  return(FALSE)
}

err_sub_criteria_0 <- function(...,
                               match_funcs = match_funcs,
                               equal_funcs = equal_funcs,
                               operator = operator){
  err <- err_sub_criteria_1(...)
  if(!isFALSE(err)) return(err)

  err <- err_sub_criteria_3dot_1(...)
  if(!isFALSE(err)) return(err)

  err <- err_sub_criteria_funcs(..., funcs = match_funcs, funcs_l = "match_funcs")
  if(!isFALSE(err)) return(err)

  err <- err_sub_criteria_funcs(..., funcs = equal_funcs, funcs_l = "match_funcs")
  if(!isFALSE(err)) return(err)

  return(FALSE)
}


err_3dot_lens <- function(...){
  args <- list(...)
  err <- lapply(list(...), length)
  err <- unlist(err, use.names = FALSE)
  err <- sort(err[!duplicated(err)])

  if(length(err) != 1 | all(err == 0)){
    paste0("Different lengths for each attribute (`...`) in `attrs()`:\n",
           "i - Each attribute in (`...`) must have the same length.\n",
           paste0("X - `...` ", "contains elements of lengths ", listr(err),".", collapse = "\n"))
  }else{
    FALSE
  }
}

err_make_pairs_1 <- function(x = 1, strata = NULL,
                             repeats_allowed = TRUE,
                             permutations_allowed = TRUE){

  # Check for non-atomic vectors
  args <- list(x = x,
               strata = strata,
               repeats_allowed = repeats_allowed,
               permutations_allowed = permutations_allowed)

  err <- mapply(err_atomic_vectors_2,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object types
  args <- list(repeats_allowed = repeats_allowed,
               permutations_allowed = permutations_allowed)

  args_classes <- list(repeats_allowed = "logical",
                       permutations_allowed = "logical")

  err <- mapply(err_object_types,
                args,
                as.list(names(args)),
                args_classes[match(names(args), names(args_classes))])
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for required object lengths
  len_lims <- c(1, length(x))
  args <- list(strata = strata,
               repeats_allowed = repeats_allowed,
               permutations_allowed = permutations_allowed)

  args_lens <- list(strata = c(0, len_lims),
                    repeats_allowed = 1,
                    permutations_allowed = 1)

  err <- mapply(err_match_ref_len,
                args,
                rep(as.list("x"), length(args_lens)),
                args_lens[match(names(args), names(args_lens))],
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  # Check for missing values where they are not permitted
  args <- list(repeats_allowed = repeats_allowed,
               permutations_allowed = permutations_allowed)

  err <- mapply(err_missing_check,
                args,
                as.list(names(args)))
  err <- unlist(err, use.names = FALSE)
  err <- err[err != FALSE]
  if(length(err) > 0) return(err[1])

  return(FALSE)
}

err_option_level <- function(x,  valid_opts = c("", "r", "e", "w"), arg_nm = "case_length"){
  if(inherits(x, "list") & !is.null(names(x))){
    opts <- names(x)
    opts <- opts[!opts %in% valid_opts]

    if(length(opts) > 0){
      err_title <- paste0("Invalid option level for `", arg_nm, "`:\n")
      errs <- paste0(err_title,
                     "i - valid option levels are: ", listr(paste0("\"",valid_opts,"\"")), ".\n",
                     "i - Syntax ~ ", paste0("`(... ", arg_nm, " = list(\"w\" = c(\"14\",\"14\",\"28\",\"29\")))`"),"\n",
                     "i - Syntax ~ ", paste0("`(... ", arg_nm, " = list(\"w\" = c(\"14\",\"14\",\"28\",\"29\")))`"),"\n",
                     paste0("X - You've supplied ", listr(paste0("\"",opts,"\""), lim = 3)))
      return(errs)
    }else{
      FALSE
    }
  }else{
    FALSE
  }
}