tests/testthat/function.R

In proxyC: Computes Proximity in Large Sparse Matrices

require(Matrix)

mat_test <- rsparsematrix(100, 50, 0.5)
mat_test[1, ] <- 0.0 # set sum(x) == 0
mat_test[2, ] <- 0.5 # set sd(x) == 0
mat_test[3, ] <- 0.0001 # set sd(x) == 0

# returns TRUE where values are affected by vectors with all zero
is_all0 <- function(x, y = x, margin = 1) {
    if (margin == 1) {
        r1 <- outer(rowZeros(x) == ncol(x), rep(TRUE, nrow(y)))
        r2 <- outer(rep(TRUE, nrow(x)), rowZeros(y) == ncol(y))
    } else {
        r1 <- outer(colZeros(x) == nrow(x), rep(TRUE, ncol(y)))
        r2 <- outer(rep(TRUE, ncol(x)), colZeros(y) == nrow(y))
    }
    return(r1 | r2)
}

# returns TRUE where values are affected by vectors with zero variance
is_sd0 <- function(x, y = x, margin = 1) {
    if (margin == 1) {
        r1 <- outer(rowSds(x) == 0, rep(TRUE, nrow(y)))
        r2 <- outer(rep(TRUE, nrow(x)), rowSds(y) == 0)
    } else {
        r1 <- outer(colSds(x) == 0, rep(TRUE, ncol(y)))
        r2 <- outer(rep(TRUE, ncol(x)), colSds(y) == 0)
    }
    return(r1 | r2)
}

test_simil <- function(x, method, margin, ignore_upper = FALSE, ignore_diag = TRUE, use_nan = FALSE, ...) {

    method_nan <- c("cosine", "correlation") # methods affected by all = 0 or sd = 0

    # test with only x
    suppressWarnings({
        s1 <- as.matrix(simil(x, method = method, margin = margin, use_nan = use_nan, ...))
    })
    s2 <- proxy::as.matrix(proxy::simil(as.matrix(x),
                                        method = method, by_rows = margin == 1, diag = TRUE, ...))

    if (use_nan) {
        if (method %in% method_nan) {
            s2[is_all0(x, x, margin = margin)] <- NaN
            if (method == "correlation")
                s2[is_sd0(x, x, margin = margin)] <- NaN
        }
    }
    if (ignore_diag)
        diag(s1) <- diag(s2) <- 0
    if (ignore_upper)
        s1[upper.tri(s1, TRUE)] <- s2[upper.tri(s2, TRUE)] <- 0

    expect_equal(as.numeric(s1), as.numeric(s2), tolerance = 0.001)

    # test with x and y, different size
    if (margin == 1) {
        y <- x[sample(nrow(x), pmin(nrow(x), 10)),]
    } else {
        y <- x[,sample(ncol(x), pmin(ncol(x), 10))]
    }

    suppressWarnings({
        s3 <- as.matrix(simil(x, y, method = method, margin = margin, use_nan = use_nan, ...))
    })
    s4 <- as.matrix(proxy::simil(as.matrix(x), as.matrix(y),
                                 method = method, by_rows = margin == 1, diag = TRUE, ...))

    if (use_nan) {
        if (method %in% method_nan) {
            s4[is_all0(x, y, margin = margin)] <- NaN
            if (method == "correlation")
                s4[is_sd0(x, y, margin = margin)] <- NaN
        }
    }
    if (ignore_diag)
        diag(s3) <- diag(s4) <- 0
    if (ignore_upper)
        s3[upper.tri(s3, TRUE)] <- s4[upper.tri(s4, TRUE)] <- 0
    expect_equal(as.numeric(s3), as.numeric(s4), tolerance = 0.001)


    # test with x and y, same size
    if (margin == 1) {
        y <- x[sample(nrow(x)),]
    } else {
        y <- x[,sample(ncol(x))]
    }

    suppressWarnings({
        s5 <- as.matrix(simil(x, y, method = method, margin = margin, use_nan = use_nan, ...))
    })
    s6 <- as.matrix(proxy::simil(as.matrix(x), as.matrix(y),
                                 method = method, by_rows = margin == 1, diag = TRUE, ...))
    if (use_nan) {
        if (method %in% method_nan) {
            s6[is_all0(x, y, margin = margin)] <- NaN
            if (method == "correlation")
                s6[is_sd0(x, y, margin = margin)] <- NaN
        }
    }
    if (ignore_diag)
        diag(s5) <- diag(s6) <- 0
    if (ignore_upper)
        s5[upper.tri(s5, TRUE)] <- s6[upper.tri(s6, TRUE)] <- 0
    expect_equal(as.numeric(s5), as.numeric(s6), tolerance = 0.001)
}


test_dist <- function(x, method, margin, ignore_upper = FALSE, ...) {

    # test with only x
    suppressWarnings({
        s1 <- as.matrix(dist(x, method = method, margin = margin, ...))
    })
    s2 <- as.matrix(proxy::dist(as.matrix(x),
                                method = method, by_rows = margin == 1, diag = TRUE, ...))

    if (ignore_upper)
        s1[upper.tri(s1, TRUE)] <- s2[upper.tri(s2, TRUE)] <- 0
    expect_equal(as.numeric(s1), as.numeric(s2), tolerance = 0.001)

    # test with x and y, different size
    if (margin == 1) {
        y <- x[sample(nrow(x), pmin(nrow(x), 10)),]
    } else {
        y <- x[,sample(ncol(x), pmin(ncol(x), 10))]
    }

    suppressWarnings({
        s3 <- as.matrix(dist(x, y, method = method, margin = margin, ...))
    })
    s4 <- as.matrix(proxy::dist(as.matrix(x), as.matrix(y),
                                method = method, by_rows = margin == 1, diag = TRUE, ...))
    if (ignore_upper)
        s3[upper.tri(s3, TRUE)] <- s4[upper.tri(s4, TRUE)] <- 0
    expect_equal(as.numeric(s3), as.numeric(s4), tolerance = 0.001)

    # test with x and y, same size
    if (margin == 1) {
        y <- x[sample(nrow(x)),]
    } else {
        y <- x[,sample(ncol(x))]
    }

    suppressWarnings({
        s5 <- as.matrix(dist(x, y, method = method, margin = margin, ...))
    })
    s6 <- as.matrix(proxy::dist(as.matrix(x), as.matrix(y),
                                method = method, by_rows = margin == 1, diag = TRUE, ...))
    if (ignore_upper)
        s5[upper.tri(s5, TRUE)] <- s6[upper.tri(s5, TRUE)] <- 0
    expect_equal(as.numeric(s5), as.numeric(s6), tolerance = 0.001)
}