R/peptide-class.R

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

# Constructor ----

#' Internal constructor to create `peptr_peptide` type
#'
#' Asserts that `sequence` is a character vector, `count` and `position` are integer vectors, `ptms` a list, and `has_position` and `has_ptms` are flags (length 1 booleans).
#'
#' @keywords internal
#' @importFrom vctrs vec_assert new_vctr new_rcrd
#' @importFrom vctrs vec_cast
#' @importFrom vctrs vec_ptype
#' @importFrom vctrs vec_ptype2
new_peptide <- function(sequence = character(),
                        count = integer(),
                        position = integer(),
                        ptms = list()) {
  vec_assert(sequence, ptype = character())
  vec_assert(count, ptype = integer())
  vec_assert(position, ptype = integer())
  vec_assert(ptms, ptype = list())

  new_rcrd(
    fields = list(
      sequence = sequence,
      count = count,
      position = position,
      ptms = ptms
    ),
    class = "peptr_peptide"
  )
}


# Helper ----

#' @title A class for peptides
#'
#' @param sequence A character vector of the peptide sequences.
#' @param count An integer vector of the count of peptide.
#' @param position An integer vector of the peptide relative to the precursor protein.
#' @param ptms a list of `peptr_ptm` and `peptr_ptm2` objects.
#' @export
#' @importFrom vctrs vec_cast vec_cast_common vec_recycle_common
#' @examples
#' peptr_peptide("LVMYL")
#' # peptr_peptide("LL", ptms = list(peptr_ptm_list(peptr_ptm(name = "a"))))
#' peptr_peptide(c("LLMVKL", "CVLIMNLQN"))
peptr_peptide <- function(sequence = character(),
                          count = 1L,
                          position = 1L,
                          ptms = list(peptr_ptm_list())) {
  peptide_check(sequence, count, position, ptms)

  sequence <- vec_cast(sequence, to = character())
  c(count, position) %<-% vec_cast_common(count, position, .to = integer())
  ptms <- vec_cast(ptms, to = list())
  if (is_empty(ptms)) {
    ptms <- rep.int(list(peptr_ptm_list()), times = length(sequence))
  }
  c(sequence, count, position, ptms) %<-% vec_recycle_common(sequence, count, position, ptms)

  new_peptide(
    sequence = sequence,
    count = count,
    position = position,
    ptms = ptms
  )
}

setOldClass(c("peptr_peptide", "vctrs_vctr"))


# Class check ----


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

# Formatting ----

vec_ptype_full.peptr_peptide <- function(x, ...) {
  paste0("peptide")
}

vec_ptype_abbr.peptr_peptide <- function(x, ...) {
  "pept"
}

#' @export
#' @importFrom vctrs field
format.peptr_peptide <- function(x, ...) {
  sequence <- field(x, "sequence")
  position <- field(x, "position")
  count <- field(x, "count")
  ptms <- field(x, "ptms") # TODO: do something with that
  out <- format_peptide(sequence, position, count)
  out[is.na(sequence)] <- NA
  out
}


# Casting ----


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

#' @method vec_ptype2.peptr_peptide default
#' @export
#' @importFrom vctrs vec_default_ptype2
vec_ptype2.peptr_peptide.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_peptide
#' @export
#' @export vec_cast.peptr_peptide
vec_cast.peptr_peptide <- function(x, to, ...) {
  UseMethod("vec_cast.peptr_peptide")
}

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

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

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