R/input_checks.R

In CCMMR: Minimization of the Convex Clustering Loss Function

.check_array <- function(array, ndim, input_name)
{
    if (ndim == 1) {
        if (!is.vector(array) || !is.numeric(array)) {
            message = paste("Expected 1D numeric vector for", input_name)
            stop(message)
        }
    } else if (ndim == 2) {
        if (!is.matrix(array) || !is.numeric(array)) {
            message = paste("Expected 2D numeric matrix for", input_name)
            stop(message)
        }
    }

    if (sum(is.na(array)) > 0) {
        message = paste("Input", input_name, "contains NaN")
        stop(message)
    }
}


.check_scalar <- function(scalar, positive, input_name, upper_bound = NULL)
{
    if (positive && is.null(upper_bound)) {
        message = paste("Expected positive numeric value for", input_name)
    } else if (positive) {
        message = paste("Expected positive numeric value below", upper_bound,
                        "for", input_name)
    } else if (!positive && is.null(upper_bound)) {
        message = paste("Expected nonnegative numeric value for", input_name)
    } else {
        message = paste("Expected nonnegative numeric value below", upper_bound,
                        "for", input_name)
    }

    if (length(scalar) != 1 || !is.numeric(scalar)) {
        stop(message)
    }

    if (positive && scalar <= 0) {
        stop(message)
    } else if (scalar < 0) {
        stop(message)
    }

    if (!is.null(upper_bound)) {
        if (scalar >= upper_bound) {
            stop(message)
        }
    }
}


.check_int <- function(scalar, positive, input_name)
{
    if (positive) {
        message = paste("Expected positive integer for", input_name)
    } else {
        message = paste("Expected nonnegative integer for", input_name)
    }

    if (length(scalar) != 1 || !is.numeric(scalar)) {
        stop(message)
    } else if (scalar != as.integer(scalar)) {
        stop(message)
    }

    if (positive && scalar <= 0) {
        stop(message)
    } else if (scalar < 0) {
        stop(message)
    }
}


.check_boolean <- function(boolean, input_name)
{
    if (length(boolean) != 1 || !is.logical(boolean)) {
        message = paste("Expected logical for", input_name)
        stop(message)
    }
}


.check_cluster_targets <- function(low, high, n) {
    .check_int(low, TRUE, "target_low")
    .check_int(high, TRUE, "target_high")

    if (high > n) {
        message = "Expected target_high <= nrow(X)"
        stop(message)
    }

    if (low > high) {
        message = "Expected target_low <= target_high"
        stop(message)
    }
}


.check_weights <- function(obj)
{
    if (!is(obj, "sparseweights")) {
        message = paste("Expected sparseweights object for W (generated by",
                        "sparse_weights(...))")
        stop(message)
    }
}


.check_lambdas <- function(lambdas)
{
    .check_array(lambdas, 1, "lambdas")

    if (any(diff(lambdas) <= 0)) {
        message = "Expected monotonically increasing values for lambdas"
        stop(message)
    }

    if (any(lambdas < 0)) {
        message = "Expected nonnegative values for lambdas"
        stop(message)
    }
}


.check_cvxclust <- function(obj, input_name)
{
    if (!is(obj, "cvxclust")) {
        message = paste("Expected cvxclust object for", input_name,
                        "(generated by convex_clustering(...) or",
                        "convex_clusterpath(...))")
        stop(message)
    }
}