tests/regression.R

In fanc: Penalized Likelihood Factor Analysis via Nonconvex Penalty

suppressPackageStartupMessages(library(fanc))

expect_error <- function(expr, pattern) {
    message <- tryCatch({
        force(expr)
        NULL
    }, error=function(e) conditionMessage(e))
    stopifnot(!is.null(message), grepl(pattern, message, fixed=TRUE))
}

expect_warning <- function(expr, pattern) {
    messages <- character()
    withCallingHandlers(
        force(expr),
        warning=function(w) {
            messages <<- c(messages, conditionMessage(w))
            invokeRestart("muffleWarning")
        }
    )
    stopifnot(any(grepl(pattern, messages, fixed=TRUE)))
}

set.seed(42)
x <- matrix(rnorm(240), 60, 4)
colnames(x) <- c(
    "plain",
    "quote\"",
    "</script><script>alert(1)</script>",
    "line\nname"
)

fit.control <- list(
    length.rho=2,
    ncand.initial=1,
    ncand.initial.prenet=1,
    maxit.initial=10,
    maxit.em=40,
    maxit.cd=40,
    maxit.bfgs=40
)

## A supplied rho matrix intentionally retains its column order when gamma is
## sorted. This is established fanc behavior and must not be changed.
rho.mc <- matrix(c(0.9, 0.3, 0.7, 0.2), 2, 2)
fit.mc <- fanc(
    x, 2, rho=rho.mc, gamma=c(2, Inf), type="MC",
    control=fit.control
)
stopifnot(identical(fit.mc$gamma, c(Inf, 2)))
stopifnot(isTRUE(all.equal(unname(fit.mc$rho), rho.mc)))

fit.prenet.scalar <- fanc(
    x, 2, gamma=c(0.8, 0.5), type="prenet",
    control=c(fit.control, list(max.rho=1))
)
stopifnot(isTRUE(all.equal(fit.prenet.scalar$rho[1, ], c(1, 1))))

fit.prenet.vector <- fanc(
    x, 2, gamma=c(0.8, 0.5), type="prenet",
    control=c(fit.control, list(max.rho=c(1, 0.7)))
)
stopifnot(isTRUE(all.equal(fit.prenet.vector$rho[1, ], c(1, 0.7))))

fit.enet.scalar <- fanc(
    x, 2, gamma=c(0.8, 0.5), type="enet",
    control=c(fit.control, list(max.rho=0.9))
)
stopifnot(isTRUE(all.equal(fit.enet.scalar$rho[1, ], c(0.9, 0.9))))

fit.enet.vector <- fanc(
    x, 2, gamma=c(0.8, 0.5), type="enet",
    control=c(fit.control, list(max.rho=c(0.9, 0.6)))
)
stopifnot(isTRUE(all.equal(fit.enet.vector$rho[1, ], c(0.9, 0.6))))

expect_error(
    fanc(
        x, 2, gamma=c(0.8, 0.5), type="prenet",
        control=c(fit.control, list(max.rho=c(1, 0.8, 0.6)))
    ),
    "must be one or equal to the number of gamma values"
)

expect_error(out(fit.mc, 0.9, Inf, df.method="typo"),
             "\"df.method\" must be")
expect_error(select(fit.mc, df.method="typo"),
             "\"df.method\" must be")
expect_error(plot(fit.mc, df.method="typo", viewer="base"),
             "'df.method' must be")

scores.out <- out(fit.mc, 0.9, Inf, scores=TRUE)$scores
scores.select <- select(fit.mc, gamma=Inf, scores=TRUE)$scores
stopifnot(identical(dim(scores.out), c(nrow(x), 2L)))
stopifnot(identical(dim(scores.select), c(nrow(x), 2L)))

cov.with.n <- fanc(
    covmat=cov(x), factors=2, n.obs=nrow(x),
    rho=rho.mc, gamma=c(Inf, 2), type="MC", control=fit.control
)
expect_error(out(cov.with.n, 0.9, Inf, scores=TRUE),
             "original data matrix is unavailable")
expect_error(select(cov.with.n, gamma=Inf, scores=TRUE),
             "original data matrix is unavailable")

cov.without.n <- fanc(
    covmat=cov(x), factors=2,
    rho=rho.mc, gamma=c(Inf, 2), type="MC", control=fit.control
)
unavailable <- c(
    "BIC", "BIC.H", "EBIC", "AIC", "CAIC",
    "GFI", "AGFI", "SRMR", "RMSEA", "CFI",
    "BIC_dfnonzero", "EBIC_dfnonzero", "AIC_dfnonzero",
    "CAIC_dfnonzero", "AGFI_dfnonzero", "RMSEA_dfnonzero",
    "CFI_dfnonzero", "Npflag"
)
stopifnot(is.null(cov.without.n$x))
stopifnot(all(vapply(unavailable, function(name) {
    is.null(cov.without.n[[name]])
}, logical(1))))
expect_error(select(cov.without.n),
             "Data matrix or the number of observations is needed")

html.file <- tempfile(fileext=".html")
plot(
    fit.mc, viewer="html", file=html.file, Window.Height=700,
    rho.index=2, gamma.index=2
)
html <- paste(readLines(html.file, warn=FALSE), collapse="\n")
unlink(html.file)
stopifnot(!grepl("</script><script>alert(1)</script>", html, fixed=TRUE))
stopifnot(grepl("\\u003C/script\\u003E", html, fixed=TRUE))
stopifnot(grepl("\"height\":[[:space:]]*700", html))
stopifnot(grepl("\"initialR\":1", html, fixed=TRUE))
stopifnot(grepl("\"initialG\":1", html, fixed=TRUE))

html.file <- tempfile(fileext=".html")
plot(cov.without.n, viewer="html", file=html.file)
html <- paste(readLines(html.file, warn=FALSE), collapse="\n")
unlink(html.file)
stopifnot(grepl(
    "\"crit\":{\"AIC\":null,\"BIC\":null,\"CAIC\":null,\"EBIC\":null}",
    html, fixed=TRUE
))
stopifnot(grepl("b.disabled=argmin(b.dataset.c)==null;", html, fixed=TRUE))

expect_error(plot(fit.mc, Window.Height=NA_real_, viewer="base"),
             "'Window.Height' must be")
expect_error(plot(fit.mc, rho.index=1.5, viewer="base"),
             "'rho.index' must be a single integer")
expect_error(plot(fit.mc, gamma.index=3, viewer="base"),
             "'gamma.index' must be between")

fit.nonfinite <- fit.mc
fit.nonfinite$loadings[[1]][[1]][1, 1] <- Inf
expect_error(plot(fit.nonfinite, viewer="base"),
             "All factor loadings must be finite")

fit.one <- fanc(
    x, 1, rho=matrix(c(0.5, 0.1), 2, 1), gamma=Inf, type="MC",
    control=fit.control
)
plot.info <- getFromNamespace("fanc_plot_info", "fanc")(
    fit.one, 500, "path", "active"
)
layout <- getFromNamespace("fanc_path_layout", "fanc")(plot.info)
stopifnot(identical(unname(layout$x.fac), layout$width / 2))

plot.info.min <- getFromNamespace("fanc_plot_info", "fanc")(
    fit.one, 250, "path", "active"
)
plot.info.max <- getFromNamespace("fanc_plot_info", "fanc")(
    fit.one, 2000, "path", "active"
)
layout.min <- getFromNamespace("fanc_path_layout", "fanc")(plot.info.min)
layout.max <- getFromNamespace("fanc_path_layout", "fanc")(plot.info.max)
stopifnot(identical(layout.min$height, 500))
stopifnot(identical(layout.min, layout.max))

fit.seven <- fit.mc
fit.seven$factors <- 7
fit.seven$loadings <- lapply(fit.seven$loadings, function(gamma.path) {
    lapply(gamma.path, function(loadings) {
        ans <- Matrix::Matrix(matrix(seq_len(8 * 7) / 100, 8, 7),
                              sparse=TRUE)
        dimnames(ans) <- list(
            paste0("Variable_", seq_len(8)),
            paste0("Factor_", seq_len(7))
        )
        ans
    })
})
plot.info.seven <- getFromNamespace("fanc_plot_info", "fanc")(
    fit.seven, 500, NULL, "active"
)
stopifnot(identical(plot.info.seven$type, "heatmap"))
expect_warning(
    getFromNamespace("fanc_plot_info", "fanc")(
        fit.seven, 500, "path", "active"
    ),
    "seven or more factors"
)

clean.label <- getFromNamespace("fanc_base_clean_label", "fanc")
abbreviate.label <- getFromNamespace("fanc_base_abbreviate_label", "fanc")
stopifnot(identical(clean.label("line\nbreak\ttab"), "line break tab"))
stopifnot(identical(abbreviate.label("abcdefghijk", 8), "abcde..."))