R/checkIds.R

In graumannlab/readat: Functionality to Read and Manipulate SomaLogic ADAT files

# See http://www.uniprot.org/help/accession_numbers
UNIPROT_ID <-
    "^(?:[OPQ][0-9][A-Z0-9]{3}[0-9]|[A-NR-Z][0-9](?:[A-Z][A-Z0-9]{2}[0-9]){1,2})$"

ENTREZ_GENE_ID <- "^(?:[0-9]+)$"

# From http://www.genenames.org/about/guidelines#genesymbols
## 1. The initial character of the symbol should always be a letter.
## 2. Subsequent characters may be other letters, or if necessary, Arabic
##    numerals.
## 3. No punctuation may be used, with the exception of hyphens in specific
##    families and locus types

# From http://www.genenames.org/about/guidelines#specificusage
# @, # punctuation character allowed (all other allowed prefixes/suffixes are
# letters)

# From http://www.genenames.org/about/guidelines#Appendix1
# When referring to splice variants, the symbol can be followed by an
# underscore and the lower case letter "v" then a consecutive number
# This last rule is fudged a little to allow arbitrary letters and numbers after
# the underscore.  There are quite a few cases of hyphen then number in the
# EBI HGNC HS dataset
# ftp://ftp.ebi.ac.uk/pub/databases/genenames/new/tsv/hgnc_complete_set.txt

# In the broader scheme of things, Entrez Gene Symbols have no common pattern.
# ftp://ftp.ncbi.nih.gov/gene/DATA/GENE_INFO/All_Data.gene_info.gz
ENTREZ_GENE_SYMBOL <- "^(?:[A-Z][A-Z0-9]*)(?:[_-][A-Z0-9]+)*[#@]?$"

# Predicates
#' @importFrom assertive.base call_and_name
#' @importFrom assertive.base set_cause
#' @importFrom stringi stri_detect_regex
is_uniprot_id <- function(x)
{
    x <- as.character(x)
    call_and_name(
        function(x)
        {
            ok <- stri_detect_regex(x, UNIPROT_ID)
            set_cause(ok, "bad format")
        },
        x
    )
}

is_entrez_gene_id <- function(x)
{
    x <- as.character(x)
    call_and_name(
        function(x)
        {
            ok <- stri_detect_regex(x, ENTREZ_GENE_ID)
            set_cause(ok, "bad format")
        },
        x
    )
}

is_entrez_gene_symbol <- function(x)
{
    x <- as.character(x)
    call_and_name(
        function(x)
        {
            ok <- stri_detect_regex(
                x,
                paste0(ENTREZ_GENE_SYMBOL, "|^Human-virus$"),
                case_insensitive = TRUE
            )
            set_cause(ok, "bad format")
        },
        x
    )
}

# assertions
#' @importFrom assertive.base get_name_in_parent
#' @importFrom assertive.base assert_engine
assert_all_are_uniprot_ids <- function(x, na_ignore = FALSE,
    severity = getOption("assertive.severity", "stop"))
{
    msg <- gettextf(
        "The values of %s are not all UniProt IDs.",
        get_name_in_parent(x),
        domain = "R-readat"
    )

    assert_engine(
        is_uniprot_id,
        x,
        msg = msg,
        na_ignore = na_ignore,
        severity = severity
    )
}

assert_all_are_entrez_gene_ids <- function(x, na_ignore = FALSE,
    severity = getOption("assertive.severity", "stop"))
{
    msg <- gettextf(
        "The values of %s are not all Entrez Gene IDs.",
        get_name_in_parent(x),
        domain = "R-readat"
    )

    assert_engine(
        is_entrez_gene_id,
        x,
        msg = msg,
        na_ignore = na_ignore,
        severity = severity
    )
}

assert_all_are_entrez_gene_symbols <- function(x, na_ignore = FALSE,
    severity = getOption("assertive.severity", "stop"))
{
    msg <- gettextf(
        "The values of %s are not all Entrez Gene symbols.",
        get_name_in_parent(x),
        domain = "R-readat"
    )
    assert_engine(
        is_entrez_gene_symbol,
        x,
        msg = msg,
        na_ignore = na_ignore,
        severity = severity
    )
}

# High-level checks.

#' Check that the IDs are genuine
#'
#' Checks on character vectors to see if they contain valid UniProt IDs,
#' Entrez Gene IDs, and Entrez Gene symbols.
#' @param sequenceData A data.table of sequence data.  It Should contain columns
#' named "UniProt", "EntrezGeneID", and "EntrezGeneSymbol".
#' @return The character vector of IDs/symbols is silently returned, but the
#' functions are mostly invoked for the side effect of throwing a warning if
#' there are any bad elements.
#' @noRd
#' @importFrom dplyr %>%
checkUniprotIds <- function(sequenceData)
{
    upIds <- strsplit(
        as.character(sequenceData$UniProt),
        " ",
        fixed = TRUE
    ) %>%
        unlist(use.names = FALSE)
    assert_all_are_uniprot_ids(
        ignoreHce(upIds), na_ignore = TRUE, severity = "warning"
    )
}

checkEntrezGeneIds <- function(sequenceData)
{
    egIds <- strsplit(
        as.character(sequenceData$EntrezGeneID),
        " ",
        fixed = TRUE
    ) %>%
        unlist(use.names = FALSE)
    assert_all_are_entrez_gene_ids(
        ignoreHce(egIds), na_ignore = TRUE, severity = "warning"
    )
}


checkEntrezGeneSymbols <- function(sequenceData)
{
    egSymbols <- strsplit(
        as.character(sequenceData$EntrezGeneSymbol),
        " ",
        fixed = TRUE
    ) %>%
        unlist(use.names = FALSE)
    assert_all_are_entrez_gene_symbols(
        ignoreHce(egSymbols), na_ignore = TRUE, severity = "warning"
    )
}

#' @importFrom stringi stri_detect_regex
ignoreHce <- function(x)
{
    x[stri_detect_regex(x, "^HCE[[:digit:]]{6}$")] <- NA_character_
    x
}