checks.R

#' @title Checks functions
#' 
#' @name checks
#' @rdname checks
#' 
#' @description 
#' 
#' Internal functions to validate the nature/structure of (m)cool files or 
#' `HiCExperiment` objects.
#' All these check functions should return a logical.
#' 
#' @param path Path of a (m)cool file
#' @param contacts A `HiCExperiment` object
#' @param use.scores Name of scores to check
#' @param resolution Resolution
#' @param pair Pairs object with length of 1
#' @param bed Path to regions file generated by HiC-Pro
#' @param ... `HiCExperiment` object, arguments passed on by other functions
#' @return Logical
#' @keywords internal
NULL

################################################################################
######################### CHECKS FOR COOL-BASED HICEXPERIMENTS #################
################################################################################

#' @rdname checks

.check_cool_file <- function(path) {
    if (!file.exists(path) | {
        isTRUE(nzchar(Sys.readlink(path), keepNA = TRUE)) & 
        !file.exists(Sys.readlink(path))
    }) {
        stop('File not found. Aborting now')
    }
    if (!{.is_cool(path) | .is_mcool(path)}) {
        stop('Provided file is not a .cool/.mcool file.\n  Aborting now.')
    }
    TRUE
}

#' @rdname checks

.check_cool_format <- function(path, resolution, ...) {
    if (.is_mcool(path)) {
        res <- .lsCoolResolutions(path)
        if (is.null(resolution)) {
            stop("File is in .mcool format, a resolution must be provided.\n", paste0('  Available resolutions: ', paste0(res, collapse = ', '), '.'))
        }
        if (!resolution %in% res) {
            stop("Resolution not stored in cool file.\n", paste0('  Available resolutions: ', paste0(res, collapse = ', '), '.'))
        }
    }
    if (.is_cool(path)) {
        correctRes <- .lsCoolResolutions(path)
        if (!is.null(resolution)) {
            if (resolution != correctRes) {
                stop("File is in .cool format, please do not specify any resolution. Aborting now.")
            }
        }
    }
    TRUE
}

#' @rdname checks

.is_mcool <- function(path) {
    if (!.is_hdf5(path)) return(FALSE)
    x <- .lsCoolFiles(path)
    all(grepl('^/resolutions', x))
}

#' @rdname checks

.is_cool <- function(path) {
    if (!.is_hdf5(path)) return(FALSE)
    x <- .lsCoolFiles(path)
    all(!grepl('^/resolutions', x))
}

.is_hdf5 <- function(path) {
    .Call("_H5Fis_hdf5", path, PACKAGE = 'rhdf5')
}

################################################################################
######################### CHECKS FOR HIC-BASED HICEXPERIMENTS ##################
################################################################################

#' @rdname checks

.check_hic_file <- function(path) {
    if (!file.exists(path) | {
        isTRUE(nzchar(Sys.readlink(path), keepNA = TRUE)) & 
        !file.exists(Sys.readlink(path))
    }) {
        stop('File not found. Aborting now')
    }
    if (!{.is_hic(path)}) {
        stop('Provided file is not a .hic file.\n  Aborting now.')
    }
    TRUE
}

#' @rdname checks

.check_hic_format <- function(path, resolution, ...) {
    res <- .lsHicResolutions(path)
    if (is.null(resolution)) {
        stop("File is in .hic format, a resolution must be provided.\n", paste0('  Available resolutions: ', paste0(res, collapse = ', '), '.'))
    }
    if (!resolution %in% res) {
        stop("Resolution not stored in .hic file.\n", paste0('  Available resolutions: ', paste0(res, collapse = ', '), '.'))
    }
    TRUE
}

#' @rdname checks

.is_hic <- function(path) {
    path <- gsub('~', Sys.getenv('HOME'), path)
    tryCatch(
        expr = {strawr::readHicChroms(path); TRUE}, 
        error = function(e) {
            FALSE
        },
        warning = function(e) {
            FALSE
        }
    )
}

################################################################################
######################### CHECKS FOR HICPRO-BASED HICEXPERIMENTS ###############
################################################################################

#' @rdname checks

.check_hicpro_files <- function(path, bed) {
    if (!file.exists(path) | {
        isTRUE(nzchar(Sys.readlink(path), keepNA = TRUE)) & 
        !file.exists(Sys.readlink(path))
    }) {
        stop('Matrix file not found. Aborting now')
    }
    if (!{.is_hicpro_matrix(path)}) {
        stop('Provided matrix is not an HiC-Pro file.\n  Aborting now.')
    }
    if (!is.null(bed)) {
        if (!file.exists(bed) | {
            isTRUE(nzchar(Sys.readlink(bed), keepNA = TRUE)) & 
            !file.exists(Sys.readlink(bed))
        }) {
            stop('Regions file not found. Aborting now')
        }
        if (!{.is_hicpro_regions(bed)}) {
            stop('Provided regions are not an HiC-Pro file.\n  Aborting now.')
        }
    }
    TRUE
}

#' @rdname checks

.is_hicpro_matrix <- function(path) {
    tryCatch(
        expr = {
            x <- vroom::vroom(
                file = path, 
                col_names = FALSE, 
                n_max = 1000, 
                show_col_types = FALSE, 
                progress = FALSE
            )
            {
                is.numeric(x[[1]]) & 
                is.numeric(x[[2]]) & 
                is.numeric(x[[3]]) & 
                ncol(x) == 3 & 
                all(x >= 0)
            }
        }, 
        error = function(e) {
            FALSE
        },
        warning = function(e) {
            FALSE
        }
    )
}

#' @rdname checks

.is_hicpro_regions <- function(bed) {
    tryCatch(
        expr = {
            x <- vroom::vroom(
                file = bed, 
                col_names = FALSE, 
                n_max = 1000, 
                show_col_types = FALSE, 
                progress = FALSE
            )
            {
                {is.numeric(x[[1]]) | is.character(x[[1]])} & 
                is.numeric(x[[2]]) & 
                is.numeric(x[[3]]) & 
                {ncol(x) == 3 | ncol(x) == 4} & 
                all(x[, c(2, 3)] >= 0) & 
                all(x[,3] > x[,2]) &
                length(unique(x[,3] - x[,2]))
            }
        }, 
        error = function(e) {
            FALSE
        },
        warning = function(e) {
            FALSE
        }
    )
}

################################################################################
######################### CHECKS FOR HICEXPERIMENT OBJECTS #####################
################################################################################

#' @rdname checks

.check_resolution <- function(contacts, resolution) {
    availableRes <- resolutions(contacts)
    if (!resolution %in% availableRes) 
        stop(paste0("Resolution not stored in the matrix file.\n  Available resolutions: ", paste0(availableRes, collapse = ', '), '.'))
    TRUE
}

#' @rdname checks

.check_scores <- function(contacts, use.scores) {
    nscores <- names(scores(contacts))
    if (!use.scores %in% nscores) 
        stop(paste0("Queried scores not found."))
    TRUE
}

################################################################################
######################### OTHER CHECKS #########################################
################################################################################

#' @rdname checks

.is_square <- function(pair) {
    w1 <- GenomicRanges::width(S4Vectors::first(pair))
    w2 <- GenomicRanges::width(S4Vectors::second(pair))
    if (w1 != w2) {
        stop("Provided pair is not square.")
    }
    TRUE
}