R/ptm-list-class.R

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

# Constructor ----

#' @title Internal constructor to create `peptr_ptm_list` type
#'
#' @description Asserts that `ptmsn` isa list of `peptr_ptm` , and that `name` is a string.
#'
#' @keywords internal
#' @importFrom vctrs vec_assert new_vctr new_list_of
new_list_of_ptms <- function(x = list()) {
  new_list_of(
    x,
    ptype = peptr_ptm(),
    class = "peptr_ptm_list"
  )
}



# Helper ----

#' @title A class for post-translational modifications that occurs on one residue
#'
#' @param ... `peptr_ptm` objects
#' @export
#' @importFrom vctrs vec_cast
#' @importFrom rlang list2 set_names
#' @importFrom ellipsis check_dots_unnamed
#' @examples
#' x <- peptr_ptm(c(10L, 22L, 58L, 125L), "phosphorylation")
#' y <- peptr_ptm(c(58L, 132L, 24L), "O-glycosylation")
#' peptr_ptm_list(x, y)
peptr_ptm_list <- function(...) {
  check_dots_unnamed()
  ptms <- list2(...)
  ptms_list_check(ptms)
  ptms <- lapply(ptms, vec_cast, peptr_ptm())
  names_ptms <- lapply(ptms, peptr_get_ptm_name)
  ptms <- set_names(ptms, names_ptms)
  new_list_of_ptms(ptms)
}

setOldClass(c("peptr_ptm_list", "vctrs_list_of", "vctrs_vctr"))


# Class check ----


#' @title Test if an object is of class `peptr_ptm_list`
#'
#' @param x An object.
#'
#' @return `TRUE` if object is of class `peptr_ptm_list` and `FALSE` if it is not.
#' @export
peptr_is_ptm_list <- function(x) {
  inherits(x, "peptr_ptm_list")
}

# Formatting ----

vec_ptype_full.peptr_ptm_list <- function(x, ...) {
  paste0("ptm_list")
}

vec_ptype_abbr.peptr_ptm_list <- function(x, ...) {
  "ptm_l"
}

#' @export
#' @importFrom vctrs field
format.peptr_ptm_list <- function(x, ...) {
  out <- vapply(x, function(y) {
    position <- field(y, "position")
    paste(paste(position, collapse = ", "))
  }, FUN.VALUE = character(1), USE.NAMES = TRUE)
  out[is.na(x)] <- NA
  out
}

obj_print_data.peptr_ptm_list <- function(x, ...) {
  if (length(x) == 0) {
    return()
  }
  print(format(x), quote = FALSE)
}


# Casting and coercion ----

#' @rdname vctrs-compat
#' @method vec_ptype2 peptr_ptm_list
#' @export
#' @export vec_ptype2.peptr_ptm_list
vec_ptype2.peptr_ptm_list <- function(x, y, ...) {
  UseMethod("vec_ptype2.peptr_ptm_list", y)
}

#' @method vec_ptype2.peptr_ptm_list default
#' @export
#' @importFrom vctrs vec_default_ptype2
vec_ptype2.peptr_ptm_list.default <- function(x, y, ..., x_arg = "x", y_arg = "y") {
  vec_default_ptype2(x, y, x_arg = x_arg, y_arg = y_arg)
}

#' @rdname vctrs-compat
#' @method vec_cast peptr_ptm_list
#' @export
#' @export vec_cast.peptr_ptm_list
vec_cast.peptr_ptm_list <- function(x, to, ...) {
  UseMethod("vec_cast.peptr_ptm_list")
}

#' @importFrom vctrs vec_default_cast
#' @export
vec_cast.peptr_ptm_list.default <- function(x, to, ...) {
  vec_default_cast(x, to)
}


# coercion and cast of peptr_ptm_list with itself

#' @method vec_ptype2.peptr_ptm_list peptr_ptm_list
#' @export
vec_ptype2.peptr_ptm_list.peptr_ptm_list <- function(x, y, ...) {
  peptr_ptm_list()
}

#' @method vec_cast.peptr_ptm_list peptr_ptm_list
#' @export
vec_cast.peptr_ptm_list.peptr_ptm_list <- function(x, to, ...) {
  x
}


# List


#' @method vec_ptype2.peptr_ptm_list list
#' @export
vec_ptype2.peptr_ptm_list.list <- function(x, y, ...) {
  x
}

#' @method vec_ptype2.list peptr_ptm_list
#' @export
vec_ptype2.list.peptr_ptm_list <- function(x, y, ...) {
  x
}

#' @method vec_cast.peptr_ptm_list list
#' @export
vec_cast.peptr_ptm_list.list <- function(x, to, ...) {
  new_list_of_ptms(x)
}

#' @method vec_cast.list peptr_ptm_list
#' @export
#' @importFrom vctrs vec_data
vec_cast.list.peptr_ptm_list <- function(x, to, ...) {
  as.list(vec_data(x))
}