R/class_checks.R

In jeanmanguy/peptr: What the Package Does (One Line, Title Case)

#' @importFrom rlang abort is_integerish are_na
position_check <- function(position) {
  if (!all(are_na(position))) {
    if (!is_integerish(position)) {
      abort("`position` must be an integer vector.", "peptr_wrong_type")
    }
    if (any(!is.na(position) & position < 1L)) {
      abort("`position` should only contain positive integers", "peptr_wrong_value")
    }
  }
  return(invisible(TRUE))
}


#' @importFrom vctrs vec_size
ptm_check <- function(position, name) {
  position_check(position)
  if (!is.character(name) | vec_size(name) > 1L) {
    abort("`name` must be a single string.", "peptr_wrong_type")
  }
}

#' #' @importFrom rlang are_na abort is_integerish are_na
#' #' @importFrom vctrs vec_size
# ptm2_check <- function(position_1, position_2) {
#   position_check(position_1)
#   position_check(position_2)
#
#   if (vec_size(position_1) != vec_size(position_2)) {
#     abort(
#       paste0(
#         "`position_1` and `position_2` must have the same size (",
#         vec_size(position_1), "!=", vec_size(position_2),
#         ")."
#       ),
#       "peptr_wrong_size"
#     )
#   }
#   if (any(mapply(function(x, y) {
#     !is.na(x) & !is.na(y) & x == y
#   }, position_1, position_2))) {
#     abort("All `position_1` and `position_2` must be different.", "peptr_wrong_value")
#   }
#   return(invisible(TRUE))
# }


value_position_check <- function(value, position, range) {
  if (!all(are_na(value))) {
    if (!is.double(value)) {
      abort("`value` must be a double vector.", "peptr_wrong_type")
    }
  }

  position_check(position)
  if (any(duplicated(position))) {
    abort("`position` must be unique", "peptr_duplicated_position")
  }

  if (!all(are_na(range))) {
    if (!is.double(range)) {
      abort("`range` must be a double vector.", "peptr_wrong_type")
    }
  }
  if (vec_size(range) != 2L) {
    abort("`range` must be a vector of length 2.", "peptr_wrong_size")
  }
  if (range[[1]] > range[[2]]) {
    abort("`range` must be sorted.", "peptr_wrong_value")
  }
  range_value <- range(value)
  if (range_value[[1]] < range[[1]] | range_value[[2]] > range[[2]]) {
    abort("`value` must be comprised inside`range`.", "peptr_wrong_value")
  }
  return(invisible(TRUE))
}

ptms_list_check <- function(x) {
  if (!all(sapply(x, peptr_is_ptm))) {
    abort("All `...` must be `peptr_ptm` objects.", "peptr_wrong_type")
  }
  if (length(x) != length(unique(sapply(x, peptr_get_ptm_name)))) {
    abort("All `...` must have unique and non-NA `name` attributes.", "peptr_wrong_type")
  }
  return(invisible(TRUE))
}

#' @importFrom rlang is_empty
peptide_check <- function(sequence, count, position, ptms) {
  if (!all(are_na(sequence))) {
    if (!is.character(sequence)) {
      abort("`sequence` must be a character vector.", "peptr_wrong_type")
    }
    if (!all(is_peptide_sequence(sequence))) {
      abort("`sequence` must be only contains amino acid 1-letter code characters.", "peptr_wrong_value")
    }
  }

  if (!all(are_na(count))) {
    if (!is_integerish(count)) {
      abort("`count` must be a positive integer vector.", "peptr_wrong_type")
    }
    if (any(count < 0L)) {
      abort("`count` must be a positive integer vector.", "peptr_wrong_value")
    }
  }

  position_check(position)

  if (!all(is_empty(ptms))) {
    if (!is.list(ptms) | !all(sapply(ptms, peptr_is_ptm_list))) {
      abort("`ptms` must be a list of `peptr_ptm_list` objects.", "peptr_wrong_type")
    }
  }

  return(invisible(TRUE))
}