CRAN Package Check Results for Package WhatIf

Last updated on 2020-03-07 11:48:33 CET.

Flavor	Version	T_install	T_check	T_total	Status
r-devel-linux-x86_64-debian-clang	1.5-9	15.12	146.23	161.35	ERROR
r-devel-linux-x86_64-debian-gcc	1.5-9	14.47	111.84	126.31	ERROR
r-devel-linux-x86_64-fedora-clang	1.5-9			191.01	ERROR
r-devel-linux-x86_64-fedora-gcc	1.5-9			187.14	ERROR
r-devel-windows-ix86+x86_64	1.5-9	64.00	139.00	203.00	OK
r-devel-windows-ix86+x86_64-gcc8	1.5-9	40.00	127.00	167.00	OK
r-patched-linux-x86_64	1.5-9	12.05	116.59	128.64	OK
r-patched-solaris-x86	1.5-9			252.80	OK
r-release-linux-x86_64	1.5-9	10.71	115.06	125.77	OK
r-release-windows-ix86+x86_64	1.5-9	29.00	117.00	146.00	OK
r-release-osx-x86_64	1.5-9				OK
r-oldrel-windows-ix86+x86_64	1.5-9	15.00	115.00	130.00	OK
r-oldrel-osx-x86_64	1.5-9				OK

Check Details

Version: 1.5-9
Check: examples
Result: ERROR
    Running examples in 'WhatIf-Ex.R' failed
    The error most likely occurred in:

    > base::assign(".ptime", proc.time(), pos = "CheckExEnv")
    > ### Name: plot.whatif
    > ### Title: Plot Cumulative Frequencies of Distances for "whatif" Objects
    > ### Aliases: plot.whatif
    > ### Keywords: hplot
    >
    > ### ** Examples
    >
    > ## Create example data sets and counterfactuals
    > my.cfact <- matrix(rnorm(3*5), ncol = 5)
    > my.data <- matrix(rnorm(100*5), ncol = 5)
    >
    > ## Evaluate counterfactuals
    > my.result <- whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
    Preprocessing data ...
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    WhatIf
     --- call from context ---
    whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
     --- call from argument ---
    if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data)
     --- R stacktrace ---
    where 1: whatif(data = my.data, cfact = my.cfact, mc.cores = 1)

     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (formula = NULL, data, cfact, range = NULL, freq = NULL,
     nearby = 1, distance = "gower", miss = "list", choice = "both",
     return.inputs = FALSE, return.distance = FALSE, mc.cores = detectCores(),
     ...)
    {
     if (mc.cores <= 0)
     stop("mc.cores must be an integer greater than 0.", call. = FALSE)
     message("Preprocessing data ...")
     if (grepl("Zelig*", class(data)) & missing(cfact))
     cfact <- zelig_setx_to_df(data)
     if (grepl("Zelig*", class(data)) & !missing(cfact)) {
     formula <- formula(delete.response(terms(data$formula)))
     data <- data$zelig.out$z.out[[1]]$model
     }
     if (!((is.character(cfact) && is.vector(cfact) && length(cfact) ==
     1) || is.data.frame(cfact) || (is.matrix(cfact) && !is.character(cfact)))) {
     stop("'cfact' must be either a string, a R data frame, or a R non-character matrix")
     }
     if (is.character(cfact)) {
     cfact <- read.table(cfact)
     }
     if (dim(cfact)[1] == 0) {
     stop("no counterfactuals supplied: 'cfact' contains zero rows")
     }
     if (!any(complete.cases(cfact))) {
     stop("there are no cases in 'cfact' without missing values")
     }
     if ("(Intercept)" %in% dimnames(cfact)[[2]]) {
     cfact <- cfact[, -(which(dimnames(cfact)[[2]] == "(Intercept)"))]
     }
     if (is.list(data) && !(is.data.frame(data))) {
     if (!((("formula" %in% names(data)) || ("terms" %in%
     names(data))) && (("data" %in% names(data)) || ("model" %in%
     names(data))))) {
     stop("the list supplied to 'data' is not a valid output object")
     }
     tt <- terms(data)
     attr(tt, "intercept") <- rep(0, length(attr(tt, "intercept")))
     if ("data" %in% names(data)) {
     if (is.data.frame(data$data)) {
     data <- model.matrix(tt, model.frame(tt, data = data$data,
     na.action = NULL))
     }
     else {
     data <- model.matrix(tt, model.frame(tt, data = eval(data$data,
     envir = .GlobalEnv), na.action = NULL))
     }
     }
     else {
     data <- model.matrix(tt, data = data$model)
     }
     if (!(is.matrix(data))) {
     stop("observed covariate data could not be extracted from output object")
     }
     rm(tt)
     }
     else {
     if (!((is.character(data) && is.vector(data) && length(data) ==
     1) || is.data.frame(data) || (is.matrix(data) &&
     !is.character(data)))) {
     stop("'data' must be either a string, a R data frame, a R non-character matrix, or an output object")
     }
     if (is.character(data)) {
     data <- read.table(data)
     }
     }
     if (dim(data)[1] == 0) {
     stop("no observed covariate data supplied: 'data' contains zero rows")
     }
     if (!any(complete.cases(data))) {
     stop("there are no cases in 'data' without missing values")
     }
     if (!(is.null(formula))) {
     if (identical(class(formula), "formula")) {
     if (!(is.data.frame(as.data.frame(data)))) {
     stop("'data' must be coercable to a data frame in order to use 'formula'")
     }
     if (!(is.data.frame(as.data.frame(cfact)))) {
     stop("'cfact' must be coercable to a data frame in order to use 'formula'")
     }
     formula <- update.formula(formula, ~. - 1)
     ttvar <- all.vars(formula)
     for (i in 1:length(ttvar)) {
     if (!(ttvar[i] %in% dimnames(data)[[2]])) {
     stop("variables in 'formula' either unlabeled or not present in 'data'")
     }
     if (!(ttvar[i] %in% dimnames(cfact)[[2]])) {
     stop("variable(s) in 'formula' either unlabeled or not present in 'cfact'")
     }
     }
     rm(ttvar)
     data <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(data), na.action = NULL))
     cfact <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(cfact), na.action = NULL))
     }
     else {
     stop("'formula' must be of class 'formula'")
     }
     }
     if (!(identical(complete.cases(cfact), rep(TRUE, dim(cfact)[1])))) {
     cfact <- na.omit(cfact)
     message("Note: counterfactuals with missing values eliminated from cfact")
     }
     if (is.data.frame(data)) {
     if (is.character(as.matrix(data))) {
     stop("observed covariate data not coercable to numeric matrix due to character column(s)")
     }
     data <- suppressWarnings(data.matrix(data))
     }
     else {
     data <- data.matrix(as.data.frame(data))
     }
     if (is.data.frame(cfact)) {
     if (is.character(as.matrix(cfact))) {
     stop("counterfactual data not coercable to numeric matrix due to character column(s)")
     }
     cfact <- suppressWarnings(data.matrix(cfact))
     }
     else {
     cfact <- data.matrix(as.data.frame(cfact))
     }
     if (!(is.matrix(data) && is.numeric(data))) {
     stop("observed covariate data not coercable to numeric matrix")
     }
     if (!(is.matrix(cfact) && is.numeric(cfact))) {
     stop("counterfactual data not coercable to numeric matrix")
     }
     na.fail(cfact)
     if (!identical(ncol(cfact), ncol(data))) {
     stop("number of columns of 'cfact' and 'data' are not equal")
     }
     if (!(is.null(range))) {
     if (!(is.vector(range) && is.numeric(range))) {
     stop("'range' must be a numeric vector")
     }
     if (!identical(length(range), ncol(data))) {
     stop("length of 'range' does not equal number of columns of 'data'")
     }
     }
     if (!(is.null(freq))) {
     if (!(is.vector(freq) && is.numeric(freq))) {
     stop("'freq' must be a numeric vector")
     }
     na.fail(freq)
     }
     if (!(is.null(nearby))) {
     if (!(is.numeric(nearby) && is.vector(nearby) && length(nearby) ==
     1 && nearby >= 0)) {
     stop("'nearby' must be numeric, greater than or equal to 0, and a scalar")
     }
     }
     if (!(identical(miss, "list") || identical(miss, "case"))) {
     stop("'miss' must be either ''case'' or ''list''")
     }
     if (!(identical(distance, "gower") || identical(distance,
     "euclidian"))) {
     stop("'distance' must be either ''gower'' or ''euclidian''")
     }
     if (!(identical(choice, "both") || identical(choice, "hull") ||
     identical(choice, "distance"))) {
     stop("'choice' must be either ''both'', ''hull'', or ''distance''")
     }
     if (!(is.logical(return.inputs))) {
     stop("'return.inputs' must be logical, i.e. either TRUE or FALSE")
     }
     if (!(is.logical(return.distance))) {
     stop("'return.distance' must be logical, i.e. either TRUE or FALSE")
     }
     n = nrow(data)
     convex.hull.test <- function(x, z, mc.cores = mc.cores) {
     one_core_pb <- mc.cores == 1
     n <- nrow(x)
     k <- ncol(x)
     m <- nrow(z)
     if (one_core_pb && m == 1)
     one_core_pb <- FALSE
     if (one_core_pb)
     pb <- txtProgressBar(min = 1, max = m, style = 3)
     A <- rbind(t(x), rep(1, n))
     C <- c(rep(0, n))
     D <- c(rep("=", k + 1))
     in_ch <- function(i, one_core_pb = FALSE) {
     B <- c(z[i, ], 1)
     lp.result <- lp(objective.in = C, const.mat = A,
     const.dir = D, const.rhs = B)
     if (one_core_pb)
     setTxtProgressBar(pb, i)
     if (lp.result$status == 0)
     return(TRUE)
     else return(FALSE)
     }
     if (one_core_pb) {
     hull <- sapply(1:m, in_ch, one_core_pb = one_core_pb)
     }
     else {
     if (.Platform$OS.type == "windows")
     hull <- mclapply(1:m, in_ch, mc.cores = mc.cores)
     else hull <- pbmclapply(1:m, in_ch, mc.cores = mc.cores)
     hull <- unlist(hull)
     }
     if (one_core_pb)
     close(pb)
     return(hull)
     }
     calc.gd <- function(dat, cf, range) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat = t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- abs(dat - cf[i, ])/range
     if (any(range == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     dist[i, ] <- colMeans(temp, na.rm = T)
     }
     return(t(dist))
     }
     calc.ed <- function(dat, cf) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat <- t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- (dat - cf[i, ])^2
     dist[i, ] <- (colSums(temp))
     }
     return(t(dist))
     }
     geom.var <- function(dat, rang) {
     n <- nrow(dat)
     dat <- t(dat)
     ff <- function(x) {
     temp <- abs(dat - x)/rang
     if (any(rang == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     tmp <- sum(colMeans(temp, na.rm = TRUE))
     return(tmp)
     }
     sum.gd.x <- sum(apply(dat, 2, ff), na.rm = TRUE)
     gv.x <- (0.5 * sum.gd.x)/(n^2)
     return(gv.x)
     }
     calc.cumfreq <- function(freq, dist) {
     m <- length(freq)
     n <- ncol(dist)
     res <- matrix(0, n, m)
     for (i in 1:m) res[, i] <- (colSums(dist <= freq[i]))/nrow(dist)
     return(res)
     }
     if (identical(miss, "list")) {
     data <- na.omit(data)
     n <- nrow(data)
     }
     if ((choice == "both") | (choice == "hull")) {
     message("Performing convex hull test ...")
     test.result <- convex.hull.test(x = na.omit(data), z = cfact,
     mc.cores = mc.cores)
     }
     if ((choice == "both") | (choice == "distance")) {
     message("Calculating distances ....")
     if (identical(distance, "gower")) {
     samp.range <- apply(data, 2, max, na.rm = TRUE) -
     apply(data, 2, min, na.rm = TRUE)
     if (!is.null(range)) {
     w <- which(!is.na(range))
     samp.range[w] <- range[w]
     }
     if (identical(TRUE, any(samp.range == 0))) {
     message("Note: range of at least one variable equals zero")
     }
     dist <- calc.gd(dat = data, cf = cfact, range = samp.range)
     }
     else {
     dist <- calc.ed(dat = na.omit(data), cf = cfact)
     }
     message("Calculating the geometric variance...")
     if (identical(distance, "gower")) {
     gv.x <- geom.var(dat = data, rang = samp.range)
     }
     else {
     gv.x <- 0.5 * mean(calc.ed(dat = na.omit(data), cf = na.omit(data)))
     }
     if (identical(miss, "case") && identical(distance, "euclidian")) {
     summary <- colSums(dist <= nearby * gv.x) * (1/nrow(na.omit(data)))
     }
     else {
     summary <- colSums(dist <= nearby * gv.x) * (1/n)
     }
     message("Calculating cumulative frequencies ...")
     if (is.null(freq)) {
     if (identical(distance, "gower")) {
     freqdist <- seq(0, 1, by = 0.05)
     }
     else {
     min.ed <- min(dist)
     max.ed <- max(dist)
     freqdist <- round(seq(min.ed, max.ed, by = (max.ed -
     min.ed)/20), 2)
     }
     }
     else {
     freqdist <- freq
     }
     cumfreq <- calc.cumfreq(freq = freqdist, dist = dist)
     dimnames(cumfreq) <- list(seq(1, nrow(cfact), by = 1),
     freqdist)
     }
     message("Finishing up ...")
     if (return.inputs) {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), dist = t(dist), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result)
     }
     }
     else {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), in.hull = test.result,
     dist = t(dist), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), in.hull = test.result,
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), in.hull = test.result)
     }
     }
     class(out) <- "whatif"
     return(invisible(out))
    }
    <bytecode: 0x11739e78>
    <environment: namespace:WhatIf>
     --- function search by body ---
    Function whatif in namespace WhatIf has this body.
     ----------- END OF FAILURE REPORT --------------
    Error in if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data) :
     the condition has length > 1
    Calls: whatif
    Execution halted
Flavor: r-devel-linux-x86_64-debian-clang

Version: 1.5-9
Check: examples
Result: ERROR
    Running examples in ‘WhatIf-Ex.R’ failed
    The error most likely occurred in:

    > base::assign(".ptime", proc.time(), pos = "CheckExEnv")
    > ### Name: plot.whatif
    > ### Title: Plot Cumulative Frequencies of Distances for "whatif" Objects
    > ### Aliases: plot.whatif
    > ### Keywords: hplot
    >
    > ### ** Examples
    >
    > ## Create example data sets and counterfactuals
    > my.cfact <- matrix(rnorm(3*5), ncol = 5)
    > my.data <- matrix(rnorm(100*5), ncol = 5)
    >
    > ## Evaluate counterfactuals
    > my.result <- whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
    Preprocessing data ...
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    WhatIf
     --- call from context ---
    whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
     --- call from argument ---
    if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data)
     --- R stacktrace ---
    where 1: whatif(data = my.data, cfact = my.cfact, mc.cores = 1)

     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (formula = NULL, data, cfact, range = NULL, freq = NULL,
     nearby = 1, distance = "gower", miss = "list", choice = "both",
     return.inputs = FALSE, return.distance = FALSE, mc.cores = detectCores(),
     ...)
    {
     if (mc.cores <= 0)
     stop("mc.cores must be an integer greater than 0.", call. = FALSE)
     message("Preprocessing data ...")
     if (grepl("Zelig*", class(data)) & missing(cfact))
     cfact <- zelig_setx_to_df(data)
     if (grepl("Zelig*", class(data)) & !missing(cfact)) {
     formula <- formula(delete.response(terms(data$formula)))
     data <- data$zelig.out$z.out[[1]]$model
     }
     if (!((is.character(cfact) && is.vector(cfact) && length(cfact) ==
     1) || is.data.frame(cfact) || (is.matrix(cfact) && !is.character(cfact)))) {
     stop("'cfact' must be either a string, a R data frame, or a R non-character matrix")
     }
     if (is.character(cfact)) {
     cfact <- read.table(cfact)
     }
     if (dim(cfact)[1] == 0) {
     stop("no counterfactuals supplied: 'cfact' contains zero rows")
     }
     if (!any(complete.cases(cfact))) {
     stop("there are no cases in 'cfact' without missing values")
     }
     if ("(Intercept)" %in% dimnames(cfact)[[2]]) {
     cfact <- cfact[, -(which(dimnames(cfact)[[2]] == "(Intercept)"))]
     }
     if (is.list(data) && !(is.data.frame(data))) {
     if (!((("formula" %in% names(data)) || ("terms" %in%
     names(data))) && (("data" %in% names(data)) || ("model" %in%
     names(data))))) {
     stop("the list supplied to 'data' is not a valid output object")
     }
     tt <- terms(data)
     attr(tt, "intercept") <- rep(0, length(attr(tt, "intercept")))
     if ("data" %in% names(data)) {
     if (is.data.frame(data$data)) {
     data <- model.matrix(tt, model.frame(tt, data = data$data,
     na.action = NULL))
     }
     else {
     data <- model.matrix(tt, model.frame(tt, data = eval(data$data,
     envir = .GlobalEnv), na.action = NULL))
     }
     }
     else {
     data <- model.matrix(tt, data = data$model)
     }
     if (!(is.matrix(data))) {
     stop("observed covariate data could not be extracted from output object")
     }
     rm(tt)
     }
     else {
     if (!((is.character(data) && is.vector(data) && length(data) ==
     1) || is.data.frame(data) || (is.matrix(data) &&
     !is.character(data)))) {
     stop("'data' must be either a string, a R data frame, a R non-character matrix, or an output object")
     }
     if (is.character(data)) {
     data <- read.table(data)
     }
     }
     if (dim(data)[1] == 0) {
     stop("no observed covariate data supplied: 'data' contains zero rows")
     }
     if (!any(complete.cases(data))) {
     stop("there are no cases in 'data' without missing values")
     }
     if (!(is.null(formula))) {
     if (identical(class(formula), "formula")) {
     if (!(is.data.frame(as.data.frame(data)))) {
     stop("'data' must be coercable to a data frame in order to use 'formula'")
     }
     if (!(is.data.frame(as.data.frame(cfact)))) {
     stop("'cfact' must be coercable to a data frame in order to use 'formula'")
     }
     formula <- update.formula(formula, ~. - 1)
     ttvar <- all.vars(formula)
     for (i in 1:length(ttvar)) {
     if (!(ttvar[i] %in% dimnames(data)[[2]])) {
     stop("variables in 'formula' either unlabeled or not present in 'data'")
     }
     if (!(ttvar[i] %in% dimnames(cfact)[[2]])) {
     stop("variable(s) in 'formula' either unlabeled or not present in 'cfact'")
     }
     }
     rm(ttvar)
     data <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(data), na.action = NULL))
     cfact <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(cfact), na.action = NULL))
     }
     else {
     stop("'formula' must be of class 'formula'")
     }
     }
     if (!(identical(complete.cases(cfact), rep(TRUE, dim(cfact)[1])))) {
     cfact <- na.omit(cfact)
     message("Note: counterfactuals with missing values eliminated from cfact")
     }
     if (is.data.frame(data)) {
     if (is.character(as.matrix(data))) {
     stop("observed covariate data not coercable to numeric matrix due to character column(s)")
     }
     data <- suppressWarnings(data.matrix(data))
     }
     else {
     data <- data.matrix(as.data.frame(data))
     }
     if (is.data.frame(cfact)) {
     if (is.character(as.matrix(cfact))) {
     stop("counterfactual data not coercable to numeric matrix due to character column(s)")
     }
     cfact <- suppressWarnings(data.matrix(cfact))
     }
     else {
     cfact <- data.matrix(as.data.frame(cfact))
     }
     if (!(is.matrix(data) && is.numeric(data))) {
     stop("observed covariate data not coercable to numeric matrix")
     }
     if (!(is.matrix(cfact) && is.numeric(cfact))) {
     stop("counterfactual data not coercable to numeric matrix")
     }
     na.fail(cfact)
     if (!identical(ncol(cfact), ncol(data))) {
     stop("number of columns of 'cfact' and 'data' are not equal")
     }
     if (!(is.null(range))) {
     if (!(is.vector(range) && is.numeric(range))) {
     stop("'range' must be a numeric vector")
     }
     if (!identical(length(range), ncol(data))) {
     stop("length of 'range' does not equal number of columns of 'data'")
     }
     }
     if (!(is.null(freq))) {
     if (!(is.vector(freq) && is.numeric(freq))) {
     stop("'freq' must be a numeric vector")
     }
     na.fail(freq)
     }
     if (!(is.null(nearby))) {
     if (!(is.numeric(nearby) && is.vector(nearby) && length(nearby) ==
     1 && nearby >= 0)) {
     stop("'nearby' must be numeric, greater than or equal to 0, and a scalar")
     }
     }
     if (!(identical(miss, "list") || identical(miss, "case"))) {
     stop("'miss' must be either ''case'' or ''list''")
     }
     if (!(identical(distance, "gower") || identical(distance,
     "euclidian"))) {
     stop("'distance' must be either ''gower'' or ''euclidian''")
     }
     if (!(identical(choice, "both") || identical(choice, "hull") ||
     identical(choice, "distance"))) {
     stop("'choice' must be either ''both'', ''hull'', or ''distance''")
     }
     if (!(is.logical(return.inputs))) {
     stop("'return.inputs' must be logical, i.e. either TRUE or FALSE")
     }
     if (!(is.logical(return.distance))) {
     stop("'return.distance' must be logical, i.e. either TRUE or FALSE")
     }
     n = nrow(data)
     convex.hull.test <- function(x, z, mc.cores = mc.cores) {
     one_core_pb <- mc.cores == 1
     n <- nrow(x)
     k <- ncol(x)
     m <- nrow(z)
     if (one_core_pb && m == 1)
     one_core_pb <- FALSE
     if (one_core_pb)
     pb <- txtProgressBar(min = 1, max = m, style = 3)
     A <- rbind(t(x), rep(1, n))
     C <- c(rep(0, n))
     D <- c(rep("=", k + 1))
     in_ch <- function(i, one_core_pb = FALSE) {
     B <- c(z[i, ], 1)
     lp.result <- lp(objective.in = C, const.mat = A,
     const.dir = D, const.rhs = B)
     if (one_core_pb)
     setTxtProgressBar(pb, i)
     if (lp.result$status == 0)
     return(TRUE)
     else return(FALSE)
     }
     if (one_core_pb) {
     hull <- sapply(1:m, in_ch, one_core_pb = one_core_pb)
     }
     else {
     if (.Platform$OS.type == "windows")
     hull <- mclapply(1:m, in_ch, mc.cores = mc.cores)
     else hull <- pbmclapply(1:m, in_ch, mc.cores = mc.cores)
     hull <- unlist(hull)
     }
     if (one_core_pb)
     close(pb)
     return(hull)
     }
     calc.gd <- function(dat, cf, range) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat = t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- abs(dat - cf[i, ])/range
     if (any(range == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     dist[i, ] <- colMeans(temp, na.rm = T)
     }
     return(t(dist))
     }
     calc.ed <- function(dat, cf) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat <- t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- (dat - cf[i, ])^2
     dist[i, ] <- (colSums(temp))
     }
     return(t(dist))
     }
     geom.var <- function(dat, rang) {
     n <- nrow(dat)
     dat <- t(dat)
     ff <- function(x) {
     temp <- abs(dat - x)/rang
     if (any(rang == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     tmp <- sum(colMeans(temp, na.rm = TRUE))
     return(tmp)
     }
     sum.gd.x <- sum(apply(dat, 2, ff), na.rm = TRUE)
     gv.x <- (0.5 * sum.gd.x)/(n^2)
     return(gv.x)
     }
     calc.cumfreq <- function(freq, dist) {
     m <- length(freq)
     n <- ncol(dist)
     res <- matrix(0, n, m)
     for (i in 1:m) res[, i] <- (colSums(dist <= freq[i]))/nrow(dist)
     return(res)
     }
     if (identical(miss, "list")) {
     data <- na.omit(data)
     n <- nrow(data)
     }
     if ((choice == "both") | (choice == "hull")) {
     message("Performing convex hull test ...")
     test.result <- convex.hull.test(x = na.omit(data), z = cfact,
     mc.cores = mc.cores)
     }
     if ((choice == "both") | (choice == "distance")) {
     message("Calculating distances ....")
     if (identical(distance, "gower")) {
     samp.range <- apply(data, 2, max, na.rm = TRUE) -
     apply(data, 2, min, na.rm = TRUE)
     if (!is.null(range)) {
     w <- which(!is.na(range))
     samp.range[w] <- range[w]
     }
     if (identical(TRUE, any(samp.range == 0))) {
     message("Note: range of at least one variable equals zero")
     }
     dist <- calc.gd(dat = data, cf = cfact, range = samp.range)
     }
     else {
     dist <- calc.ed(dat = na.omit(data), cf = cfact)
     }
     message("Calculating the geometric variance...")
     if (identical(distance, "gower")) {
     gv.x <- geom.var(dat = data, rang = samp.range)
     }
     else {
     gv.x <- 0.5 * mean(calc.ed(dat = na.omit(data), cf = na.omit(data)))
     }
     if (identical(miss, "case") && identical(distance, "euclidian")) {
     summary <- colSums(dist <= nearby * gv.x) * (1/nrow(na.omit(data)))
     }
     else {
     summary <- colSums(dist <= nearby * gv.x) * (1/n)
     }
     message("Calculating cumulative frequencies ...")
     if (is.null(freq)) {
     if (identical(distance, "gower")) {
     freqdist <- seq(0, 1, by = 0.05)
     }
     else {
     min.ed <- min(dist)
     max.ed <- max(dist)
     freqdist <- round(seq(min.ed, max.ed, by = (max.ed -
     min.ed)/20), 2)
     }
     }
     else {
     freqdist <- freq
     }
     cumfreq <- calc.cumfreq(freq = freqdist, dist = dist)
     dimnames(cumfreq) <- list(seq(1, nrow(cfact), by = 1),
     freqdist)
     }
     message("Finishing up ...")
     if (return.inputs) {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), dist = t(dist), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result)
     }
     }
     else {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), in.hull = test.result,
     dist = t(dist), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), in.hull = test.result,
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), in.hull = test.result)
     }
     }
     class(out) <- "whatif"
     return(invisible(out))
    }
    <bytecode: 0x55a4b85d1970>
    <environment: namespace:WhatIf>
     --- function search by body ---
    Function whatif in namespace WhatIf has this body.
     ----------- END OF FAILURE REPORT --------------
    Error in if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data) :
     the condition has length > 1
    Calls: whatif
    Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc

Version: 1.5-9
Check: tests
Result: ERROR
     Running ‘testthat.R’ [16s/25s]
    Running the tests in ‘tests/testthat.R’ failed.
    Complete output:
     > library(testthat)
     > library(WhatIf)
     > library(Zelig)
     Loading required package: survival
     >
     > test_check("WhatIf")

     |
     | | 0%
     |
     |= | 1%
     |
     |= | 2%
     |
     |== | 2%
     |
     |== | 3%
     |
     |=== | 4%
     |
     |=== | 5%
     |
     |==== | 6%
     |
     |===== | 7%
     |
     |====== | 8%
     |
     |====== | 9%
     |
     |======= | 10%
     |
     |======== | 11%
     |
     |======== | 12%
     |
     |========= | 12%
     |
     |========= | 13%
     |
     |========== | 14%
     |
     |========== | 15%
     |
     |=========== | 16%
     |
     |============ | 17%
     |
     |============= | 18%
     |
     |============= | 19%
     |
     |============== | 20%
     |
     |============== | 21%
     |
     |=============== | 21%
     |
     |================ | 22%
     |
     |================ | 23%
     |
     |================= | 24%
     |
     |================= | 25%
     |
     |================== | 26%
     |
     |=================== | 26%
     |
     |=================== | 27%
     |
     |==================== | 28%
     |
     |==================== | 29%
     |
     |===================== | 30%
     |
     |===================== | 31%
     |
     |====================== | 31%
     |
     |======================= | 32%
     |
     |======================= | 33%
     |
     |======================== | 34%
     |
     |======================== | 35%
     |
     |========================= | 36%
     |
     |========================== | 37%
     |
     |=========================== | 38%
     |
     |=========================== | 39%
     |
     |============================ | 40%
     |
     |============================= | 41%
     |
     |============================== | 42%
     |
     |============================== | 43%
     |
     |=============================== | 44%
     |
     |=============================== | 45%
     |
     |================================ | 45%
     |
     |================================ | 46%
     |
     |================================= | 47%
     |
     |================================== | 48%
     |
     |================================== | 49%
     |
     |=================================== | 50%
     |
     |==================================== | 51%
     |
     |==================================== | 52%
     |
     |===================================== | 53%
     |
     |====================================== | 54%
     |
     |====================================== | 55%
     |
     |======================================= | 55%
     |
     |======================================= | 56%
     |
     |======================================== | 57%
     |
     |======================================== | 58%
     |
     |========================================= | 59%
     |
     |========================================== | 60%
     |
     |=========================================== | 61%
     |
     |=========================================== | 62%
     |
     |============================================ | 63%
     |
     |============================================= | 64%
     |
     |============================================== | 65%
     |
     |============================================== | 66%
     |
     |=============================================== | 67%
     |
     |=============================================== | 68%
     |
     |================================================ | 69%
     |
     |================================================= | 69%
     |
     |================================================= | 70%
     |
     |================================================== | 71%
     |
     |================================================== | 72%
     |
     |=================================================== | 73%
     |
     |=================================================== | 74%
     |
     |==================================================== | 74%
     |
     |===================================================== | 75%
     |
     |===================================================== | 76%
     |
     |====================================================== | 77%
     |
     |====================================================== | 78%
     |
     |======================================================= | 79%
     |
     |======================================================== | 79%
     |
     |======================================================== | 80%
     |
     |========================================================= | 81%
     |
     |========================================================= | 82%
     |
     |========================================================== | 83%
     |
     |=========================================================== | 84%
     |
     |============================================================ | 85%
     |
     |============================================================ | 86%
     |
     |============================================================= | 87%
     |
     |============================================================= | 88%
     |
     |============================================================== | 88%
     |
     |============================================================== | 89%
     |
     |=============================================================== | 90%
     |
     |================================================================ | 91%
     |
     |================================================================ | 92%
     |
     |================================================================= | 93%
     |
     |================================================================== | 94%
     |
     |=================================================================== | 95%
     |
     |=================================================================== | 96%
     |
     |==================================================================== | 97%
     |
     |==================================================================== | 98%
     |
     |===================================================================== | 98%
     |
     |===================================================================== | 99%
     |
     |======================================================================| 100%
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
     :
     --- package (from environment) ---
     WhatIf
     --- call from context ---
     whatif(data = my.data, cfact = matrix(my.cfact[1, ], nrow = 1),
     mc.cores = 1)
     --- call from argument ---
     if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data)
     --- R stacktrace ---
     where 1: whatif(data = my.data, cfact = matrix(my.cfact[1, ], nrow = 1),
     mc.cores = 1)
     where 2: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
     where 3: withCallingHandlers({
     code
     NULL
     }, error = function(cnd) {
     if (can_entrace(cnd)) {
     cnd <- cnd_entrace(cnd)
     }
     return_from(env, cnd)
     })
     where 4: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
     ...)
     where 5: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
     where 6 at testthat/test-whatif_convexhull.R#5: expect_error(whatif(data = my.data, cfact = matrix(my.cfact[1,
     ], nrow = 1), mc.cores = 1), NA)
     where 7: eval(code, test_env)
     where 8: eval(code, test_env)
     where 9: withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error)
     where 10: doTryCatch(return(expr), name, parentenv, handler)
     where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
     where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
     where 13: doTryCatch(return(expr), name, parentenv, handler)
     where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
     names[nh], parentenv, handlers[[nh]])
     where 15: tryCatchList(expr, classes, parentenv, handlers)
     where 16: tryCatch(withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error), error = handle_fatal,
     skip = function(e) {
     })
     where 17: test_code(desc, code, env = parent.frame())
     where 18 at testthat/test-whatif_convexhull.R#1: test_that("REQUIRE TEST whatif with 1 counterfactual", {
     my.cfact <- matrix(rnorm(3 * 5), ncol = 5)
     my.data <- matrix(rnorm(100 * 5), ncol = 5)
     expect_error(whatif(data = my.data, cfact = matrix(my.cfact[1,
     ], nrow = 1), mc.cores = 1), NA)
     })
     where 19: eval(code, test_env)
     where 20: eval(code, test_env)
     where 21: withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error)
     where 22: doTryCatch(return(expr), name, parentenv, handler)
     where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
     where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
     where 25: doTryCatch(return(expr), name, parentenv, handler)
     where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
     names[nh], parentenv, handlers[[nh]])
     where 27: tryCatchList(expr, classes, parentenv, handlers)
     where 28: tryCatch(withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error), error = handle_fatal,
     skip = function(e) {
     })
     where 29: test_code(NULL, exprs, env)
     where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
     where 31: force(code)
     where 32: doWithOneRestart(return(expr), restart)
     where 33: withOneRestart(expr, restarts[[1L]])
     where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
     where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
     {
     reporter$start_file(basename(path))
     lister$start_file(basename(path))
     source_file(path, new.env(parent = env), chdir = TRUE,
     wrap = wrap)
     reporter$.end_context()
     reporter$end_file()
     })
     where 36: FUN(X[[i]], ...)
     where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
     start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
     where 38: force(code)
     where 39: doWithOneRestart(return(expr), restart)
     where 40: withOneRestart(expr, restarts[[1L]])
     where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
     where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
     test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
     load_helpers = FALSE, wrap = wrap))
     where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
     stop_on_warning = stop_on_warning, wrap = wrap)
     where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
     ..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
     wrap = wrap)
     where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
     reporter = reporter, ..., stop_on_failure = stop_on_failure,
     stop_on_warning = stop_on_warning, wrap = wrap)
     where 46: test_check("WhatIf")

     --- value of length: 2 type: logical ---
     [1] FALSE FALSE
     --- function from context ---
     function (formula = NULL, data, cfact, range = NULL, freq = NULL,
     nearby = 1, distance = "gower", miss = "list", choice = "both",
     return.inputs = FALSE, return.distance = FALSE, mc.cores = detectCores(),
     ...)
     {
     if (mc.cores <= 0)
     stop("mc.cores must be an integer greater than 0.", call. = FALSE)
     message("Preprocessing data ...")
     if (grepl("Zelig*", class(data)) & missing(cfact))
     cfact <- zelig_setx_to_df(data)
     if (grepl("Zelig*", class(data)) & !missing(cfact)) {
     formula <- formula(delete.response(terms(data$formula)))
     data <- data$zelig.out$z.out[[1]]$model
     }
     if (!((is.character(cfact) && is.vector(cfact) && length(cfact) ==
     1) || is.data.frame(cfact) || (is.matrix(cfact) && !is.character(cfact)))) {
     stop("'cfact' must be either a string, a R data frame, or a R non-character matrix")
     }
     if (is.character(cfact)) {
     cfact <- read.table(cfact)
     }
     if (dim(cfact)[1] == 0) {
     stop("no counterfactuals supplied: 'cfact' contains zero rows")
     }
     if (!any(complete.cases(cfact))) {
     stop("there are no cases in 'cfact' without missing values")
     }
     if ("(Intercept)" %in% dimnames(cfact)[[2]]) {
     cfact <- cfact[, -(which(dimnames(cfact)[[2]] == "(Intercept)"))]
     }
     if (is.list(data) && !(is.data.frame(data))) {
     if (!((("formula" %in% names(data)) || ("terms" %in%
     names(data))) && (("data" %in% names(data)) || ("model" %in%
     names(data))))) {
     stop("the list supplied to 'data' is not a valid output object")
     }
     tt <- terms(data)
     attr(tt, "intercept") <- rep(0, length(attr(tt, "intercept")))
     if ("data" %in% names(data)) {
     if (is.data.frame(data$data)) {
     data <- model.matrix(tt, model.frame(tt, data = data$data,
     na.action = NULL))
     }
     else {
     data <- model.matrix(tt, model.frame(tt, data = eval(data$data,
     envir = .GlobalEnv), na.action = NULL))
     }
     }
     else {
     data <- model.matrix(tt, data = data$model)
     }
     if (!(is.matrix(data))) {
     stop("observed covariate data could not be extracted from output object")
     }
     rm(tt)
     }
     else {
     if (!((is.character(data) && is.vector(data) && length(data) ==
     1) || is.data.frame(data) || (is.matrix(data) &&
     !is.character(data)))) {
     stop("'data' must be either a string, a R data frame, a R non-character matrix, or an output object")
     }
     if (is.character(data)) {
     data <- read.table(data)
     }
     }
     if (dim(data)[1] == 0) {
     stop("no observed covariate data supplied: 'data' contains zero rows")
     }
     if (!any(complete.cases(data))) {
     stop("there are no cases in 'data' without missing values")
     }
     if (!(is.null(formula))) {
     if (identical(class(formula), "formula")) {
     if (!(is.data.frame(as.data.frame(data)))) {
     stop("'data' must be coercable to a data frame in order to use 'formula'")
     }
     if (!(is.data.frame(as.data.frame(cfact)))) {
     stop("'cfact' must be coercable to a data frame in order to use 'formula'")
     }
     formula <- update.formula(formula, ~. - 1)
     ttvar <- all.vars(formula)
     for (i in 1:length(ttvar)) {
     if (!(ttvar[i] %in% dimnames(data)[[2]])) {
     stop("variables in 'formula' either unlabeled or not present in 'data'")
     }
     if (!(ttvar[i] %in% dimnames(cfact)[[2]])) {
     stop("variable(s) in 'formula' either unlabeled or not present in 'cfact'")
     }
     }
     rm(ttvar)
     data <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(data), na.action = NULL))
     cfact <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(cfact), na.action = NULL))
     }
     else {
     stop("'formula' must be of class 'formula'")
     }
     }
     if (!(identical(complete.cases(cfact), rep(TRUE, dim(cfact)[1])))) {
     cfact <- na.omit(cfact)
     message("Note: counterfactuals with missing values eliminated from cfact")
     }
     if (is.data.frame(data)) {
     if (is.character(as.matrix(data))) {
     stop("observed covariate data not coercable to numeric matrix due to character column(s)")
     }
     data <- suppressWarnings(data.matrix(data))
     }
     else {
     data <- data.matrix(as.data.frame(data))
     }
     if (is.data.frame(cfact)) {
     if (is.character(as.matrix(cfact))) {
     stop("counterfactual data not coercable to numeric matrix due to character column(s)")
     }
     cfact <- suppressWarnings(data.matrix(cfact))
     }
     else {
     cfact <- data.matrix(as.data.frame(cfact))
     }
     if (!(is.matrix(data) && is.numeric(data))) {
     stop("observed covariate data not coercable to numeric matrix")
     }
     if (!(is.matrix(cfact) && is.numeric(cfact))) {
     stop("counterfactual data not coercable to numeric matrix")
     }
     na.fail(cfact)
     if (!identical(ncol(cfact), ncol(data))) {
     stop("number of columns of 'cfact' and 'data' are not equal")
     }
     if (!(is.null(range))) {
     if (!(is.vector(range) && is.numeric(range))) {
     stop("'range' must be a numeric vector")
     }
     if (!identical(length(range), ncol(data))) {
     stop("length of 'range' does not equal number of columns of 'data'")
     }
     }
     if (!(is.null(freq))) {
     if (!(is.vector(freq) && is.numeric(freq))) {
     stop("'freq' must be a numeric vector")
     }
     na.fail(freq)
     }
     if (!(is.null(nearby))) {
     if (!(is.numeric(nearby) && is.vector(nearby) && length(nearby) ==
     1 && nearby >= 0)) {
     stop("'nearby' must be numeric, greater than or equal to 0, and a scalar")
     }
     }
     if (!(identical(miss, "list") || identical(miss, "case"))) {
     stop("'miss' must be either ''case'' or ''list''")
     }
     if (!(identical(distance, "gower") || identical(distance,
     "euclidian"))) {
     stop("'distance' must be either ''gower'' or ''euclidian''")
     }
     if (!(identical(choice, "both") || identical(choice, "hull") ||
     identical(choice, "distance"))) {
     stop("'choice' must be either ''both'', ''hull'', or ''distance''")
     }
     if (!(is.logical(return.inputs))) {
     stop("'return.inputs' must be logical, i.e. either TRUE or FALSE")
     }
     if (!(is.logical(return.distance))) {
     stop("'return.distance' must be logical, i.e. either TRUE or FALSE")
     }
     n = nrow(data)
     convex.hull.test <- function(x, z, mc.cores = mc.cores) {
     one_core_pb <- mc.cores == 1
     n <- nrow(x)
     k <- ncol(x)
     m <- nrow(z)
     if (one_core_pb && m == 1)
     one_core_pb <- FALSE
     if (one_core_pb)
     pb <- txtProgressBar(min = 1, max = m, style = 3)
     A <- rbind(t(x), rep(1, n))
     C <- c(rep(0, n))
     D <- c(rep("=", k + 1))
     in_ch <- function(i, one_core_pb = FALSE) {
     B <- c(z[i, ], 1)
     lp.result <- lp(objective.in = C, const.mat = A,
     const.dir = D, const.rhs = B)
     if (one_core_pb)
     setTxtProgressBar(pb, i)
     if (lp.result$status == 0)
     return(TRUE)
     else return(FALSE)
     }
     if (one_core_pb) {
     hull <- sapply(1:m, in_ch, one_core_pb = one_core_pb)
     }
     else {
     if (.Platform$OS.type == "windows")
     hull <- mclapply(1:m, in_ch, mc.cores = mc.cores)
     else hull <- pbmclapply(1:m, in_ch, mc.cores = mc.cores)
     hull <- unlist(hull)
     }
     if (one_core_pb)
     close(pb)
     return(hull)
     }
     calc.gd <- function(dat, cf, range) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat = t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- abs(dat - cf[i, ])/range
     if (any(range == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     dist[i, ] <- colMeans(temp, na.rm = T)
     }
     return(t(dist))
     }
     calc.ed <- function(dat, cf) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat <- t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- (dat - cf[i, ])^2
     dist[i, ] <- (colSums(temp))
     }
     return(t(dist))
     }
     geom.var <- function(dat, rang) {
     n <- nrow(dat)
     dat <- t(dat)
     ff <- function(x) {
     temp <- abs(dat - x)/rang
     if (any(rang == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     tmp <- sum(colMeans(temp, na.rm = TRUE))
     return(tmp)
     }
     sum.gd.x <- sum(apply(dat, 2, ff), na.rm = TRUE)
     gv.x <- (0.5 * sum.gd.x)/(n^2)
     return(gv.x)
     }
     calc.cumfreq <- function(freq, dist) {
     m <- length(freq)
     n <- ncol(dist)
     res <- matrix(0, n, m)
     for (i in 1:m) res[, i] <- (colSums(dist <= freq[i]))/nrow(dist)
     return(res)
     }
     if (identical(miss, "list")) {
     data <- na.omit(data)
     n <- nrow(data)
     }
     if ((choice == "both") | (choice == "hull")) {
     message("Performing convex hull test ...")
     test.result <- convex.hull.test(x = na.omit(data), z = cfact,
     mc.cores = mc.cores)
     }
     if ((choice == "both") | (choice == "distance")) {
     message("Calculating distances ....")
     if (identical(distance, "gower")) {
     samp.range <- apply(data, 2, max, na.rm = TRUE) -
     apply(data, 2, min, na.rm = TRUE)
     if (!is.null(range)) {
     w <- which(!is.na(range))
     samp.range[w] <- range[w]
     }
     if (identical(TRUE, any(samp.range == 0))) {
     message("Note: range of at least one variable equals zero")
     }
     dist <- calc.gd(dat = data, cf = cfact, range = samp.range)
     }
     else {
     dist <- calc.ed(dat = na.omit(data), cf = cfact)
     }
     message("Calculating the geometric variance...")
     if (identical(distance, "gower")) {
     gv.x <- geom.var(dat = data, rang = samp.range)
     }
     else {
     gv.x <- 0.5 * mean(calc.ed(dat = na.omit(data), cf = na.omit(data)))
     }
     if (identical(miss, "case") && identical(distance, "euclidian")) {
     summary <- colSums(dist <= nearby * gv.x) * (1/nrow(na.omit(data)))
     }
     else {
     summary <- colSums(dist <= nearby * gv.x) * (1/n)
     }
     message("Calculating cumulative frequencies ...")
     if (is.null(freq)) {
     if (identical(distance, "gower")) {
     freqdist <- seq(0, 1, by = 0.05)
     }
     else {
     min.ed <- min(dist)
     max.ed <- max(dist)
     freqdist <- round(seq(min.ed, max.ed, by = (max.ed -
     min.ed)/20), 2)
     }
     }
     else {
     freqdist <- freq
     }
     cumfreq <- calc.cumfreq(freq = freqdist, dist = dist)
     dimnames(cumfreq) <- list(seq(1, nrow(cfact), by = 1),
     freqdist)
     }
     message("Finishing up ...")
     if (return.inputs) {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), dist = t(dist), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result)
     }
     }
     else {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), in.hull = test.result,
     dist = t(dist), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), in.hull = test.result,
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), in.hull = test.result)
     }
     }
     class(out) <- "whatif"
     return(invisible(out))
     }
     <bytecode: 0x55cfb0e27aa0>
     <environment: namespace:WhatIf>
     --- function search by body ---
     Function whatif in namespace WhatIf has this body.
     ----------- END OF FAILURE REPORT --------------
     ── 1. Failure: REQUIRE TEST whatif with 1 counterfactual (@test-whatif_convexhul
     `whatif(...)` threw an error.
     Message: the condition has length > 1
     Class: simpleError/error/condition
     Backtrace:
     1. testthat::expect_error(...)
     6. WhatIf::whatif(...)

     [1] "3 cores"
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/
     ══ testthat results ═══════════════════════════════════════════════════════════
     [ OK: 16 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 1 ]
     1. Failure: REQUIRE TEST whatif with 1 counterfactual (@test-whatif_convexhull.R#5)

     Error: testthat unit tests failed
     Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc

Version: 1.5-9
Check: examples
Result: ERROR
    Running examples in ‘WhatIf-Ex.R’ failed
    The error most likely occurred in:

    > ### Name: plot.whatif
    > ### Title: Plot Cumulative Frequencies of Distances for "whatif" Objects
    > ### Aliases: plot.whatif
    > ### Keywords: hplot
    >
    > ### ** Examples
    >
    > ## Create example data sets and counterfactuals
    > my.cfact <- matrix(rnorm(3*5), ncol = 5)
    > my.data <- matrix(rnorm(100*5), ncol = 5)
    >
    > ## Evaluate counterfactuals
    > my.result <- whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
    Preprocessing data ...
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    WhatIf
     --- call from context ---
    whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
     --- call from argument ---
    if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data)
     --- R stacktrace ---
    where 1: whatif(data = my.data, cfact = my.cfact, mc.cores = 1)

     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (formula = NULL, data, cfact, range = NULL, freq = NULL,
     nearby = 1, distance = "gower", miss = "list", choice = "both",
     return.inputs = FALSE, return.distance = FALSE, mc.cores = detectCores(),
     ...)
    {
     if (mc.cores <= 0)
     stop("mc.cores must be an integer greater than 0.", call. = FALSE)
     message("Preprocessing data ...")
     if (grepl("Zelig*", class(data)) & missing(cfact))
     cfact <- zelig_setx_to_df(data)
     if (grepl("Zelig*", class(data)) & !missing(cfact)) {
     formula <- formula(delete.response(terms(data$formula)))
     data <- data$zelig.out$z.out[[1]]$model
     }
     if (!((is.character(cfact) && is.vector(cfact) && length(cfact) ==
     1) || is.data.frame(cfact) || (is.matrix(cfact) && !is.character(cfact)))) {
     stop("'cfact' must be either a string, a R data frame, or a R non-character matrix")
     }
     if (is.character(cfact)) {
     cfact <- read.table(cfact)
     }
     if (dim(cfact)[1] == 0) {
     stop("no counterfactuals supplied: 'cfact' contains zero rows")
     }
     if (!any(complete.cases(cfact))) {
     stop("there are no cases in 'cfact' without missing values")
     }
     if ("(Intercept)" %in% dimnames(cfact)[[2]]) {
     cfact <- cfact[, -(which(dimnames(cfact)[[2]] == "(Intercept)"))]
     }
     if (is.list(data) && !(is.data.frame(data))) {
     if (!((("formula" %in% names(data)) || ("terms" %in%
     names(data))) && (("data" %in% names(data)) || ("model" %in%
     names(data))))) {
     stop("the list supplied to 'data' is not a valid output object")
     }
     tt <- terms(data)
     attr(tt, "intercept") <- rep(0, length(attr(tt, "intercept")))
     if ("data" %in% names(data)) {
     if (is.data.frame(data$data)) {
     data <- model.matrix(tt, model.frame(tt, data = data$data,
     na.action = NULL))
     }
     else {
     data <- model.matrix(tt, model.frame(tt, data = eval(data$data,
     envir = .GlobalEnv), na.action = NULL))
     }
     }
     else {
     data <- model.matrix(tt, data = data$model)
     }
     if (!(is.matrix(data))) {
     stop("observed covariate data could not be extracted from output object")
     }
     rm(tt)
     }
     else {
     if (!((is.character(data) && is.vector(data) && length(data) ==
     1) || is.data.frame(data) || (is.matrix(data) &&
     !is.character(data)))) {
     stop("'data' must be either a string, a R data frame, a R non-character matrix, or an output object")
     }
     if (is.character(data)) {
     data <- read.table(data)
     }
     }
     if (dim(data)[1] == 0) {
     stop("no observed covariate data supplied: 'data' contains zero rows")
     }
     if (!any(complete.cases(data))) {
     stop("there are no cases in 'data' without missing values")
     }
     if (!(is.null(formula))) {
     if (identical(class(formula), "formula")) {
     if (!(is.data.frame(as.data.frame(data)))) {
     stop("'data' must be coercable to a data frame in order to use 'formula'")
     }
     if (!(is.data.frame(as.data.frame(cfact)))) {
     stop("'cfact' must be coercable to a data frame in order to use 'formula'")
     }
     formula <- update.formula(formula, ~. - 1)
     ttvar <- all.vars(formula)
     for (i in 1:length(ttvar)) {
     if (!(ttvar[i] %in% dimnames(data)[[2]])) {
     stop("variables in 'formula' either unlabeled or not present in 'data'")
     }
     if (!(ttvar[i] %in% dimnames(cfact)[[2]])) {
     stop("variable(s) in 'formula' either unlabeled or not present in 'cfact'")
     }
     }
     rm(ttvar)
     data <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(data), na.action = NULL))
     cfact <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(cfact), na.action = NULL))
     }
     else {
     stop("'formula' must be of class 'formula'")
     }
     }
     if (!(identical(complete.cases(cfact), rep(TRUE, dim(cfact)[1])))) {
     cfact <- na.omit(cfact)
     message("Note: counterfactuals with missing values eliminated from cfact")
     }
     if (is.data.frame(data)) {
     if (is.character(as.matrix(data))) {
     stop("observed covariate data not coercable to numeric matrix due to character column(s)")
     }
     data <- suppressWarnings(data.matrix(data))
     }
     else {
     data <- data.matrix(as.data.frame(data))
     }
     if (is.data.frame(cfact)) {
     if (is.character(as.matrix(cfact))) {
     stop("counterfactual data not coercable to numeric matrix due to character column(s)")
     }
     cfact <- suppressWarnings(data.matrix(cfact))
     }
     else {
     cfact <- data.matrix(as.data.frame(cfact))
     }
     if (!(is.matrix(data) && is.numeric(data))) {
     stop("observed covariate data not coercable to numeric matrix")
     }
     if (!(is.matrix(cfact) && is.numeric(cfact))) {
     stop("counterfactual data not coercable to numeric matrix")
     }
     na.fail(cfact)
     if (!identical(ncol(cfact), ncol(data))) {
     stop("number of columns of 'cfact' and 'data' are not equal")
     }
     if (!(is.null(range))) {
     if (!(is.vector(range) && is.numeric(range))) {
     stop("'range' must be a numeric vector")
     }
     if (!identical(length(range), ncol(data))) {
     stop("length of 'range' does not equal number of columns of 'data'")
     }
     }
     if (!(is.null(freq))) {
     if (!(is.vector(freq) && is.numeric(freq))) {
     stop("'freq' must be a numeric vector")
     }
     na.fail(freq)
     }
     if (!(is.null(nearby))) {
     if (!(is.numeric(nearby) && is.vector(nearby) && length(nearby) ==
     1 && nearby >= 0)) {
     stop("'nearby' must be numeric, greater than or equal to 0, and a scalar")
     }
     }
     if (!(identical(miss, "list") || identical(miss, "case"))) {
     stop("'miss' must be either ''case'' or ''list''")
     }
     if (!(identical(distance, "gower") || identical(distance,
     "euclidian"))) {
     stop("'distance' must be either ''gower'' or ''euclidian''")
     }
     if (!(identical(choice, "both") || identical(choice, "hull") ||
     identical(choice, "distance"))) {
     stop("'choice' must be either ''both'', ''hull'', or ''distance''")
     }
     if (!(is.logical(return.inputs))) {
     stop("'return.inputs' must be logical, i.e. either TRUE or FALSE")
     }
     if (!(is.logical(return.distance))) {
     stop("'return.distance' must be logical, i.e. either TRUE or FALSE")
     }
     n = nrow(data)
     convex.hull.test <- function(x, z, mc.cores = mc.cores) {
     one_core_pb <- mc.cores == 1
     n <- nrow(x)
     k <- ncol(x)
     m <- nrow(z)
     if (one_core_pb && m == 1)
     one_core_pb <- FALSE
     if (one_core_pb)
     pb <- txtProgressBar(min = 1, max = m, style = 3)
     A <- rbind(t(x), rep(1, n))
     C <- c(rep(0, n))
     D <- c(rep("=", k + 1))
     in_ch <- function(i, one_core_pb = FALSE) {
     B <- c(z[i, ], 1)
     lp.result <- lp(objective.in = C, const.mat = A,
     const.dir = D, const.rhs = B)
     if (one_core_pb)
     setTxtProgressBar(pb, i)
     if (lp.result$status == 0)
     return(TRUE)
     else return(FALSE)
     }
     if (one_core_pb) {
     hull <- sapply(1:m, in_ch, one_core_pb = one_core_pb)
     }
     else {
     if (.Platform$OS.type == "windows")
     hull <- mclapply(1:m, in_ch, mc.cores = mc.cores)
     else hull <- pbmclapply(1:m, in_ch, mc.cores = mc.cores)
     hull <- unlist(hull)
     }
     if (one_core_pb)
     close(pb)
     return(hull)
     }
     calc.gd <- function(dat, cf, range) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat = t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- abs(dat - cf[i, ])/range
     if (any(range == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     dist[i, ] <- colMeans(temp, na.rm = T)
     }
     return(t(dist))
     }
     calc.ed <- function(dat, cf) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat <- t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- (dat - cf[i, ])^2
     dist[i, ] <- (colSums(temp))
     }
     return(t(dist))
     }
     geom.var <- function(dat, rang) {
     n <- nrow(dat)
     dat <- t(dat)
     ff <- function(x) {
     temp <- abs(dat - x)/rang
     if (any(rang == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     tmp <- sum(colMeans(temp, na.rm = TRUE))
     return(tmp)
     }
     sum.gd.x <- sum(apply(dat, 2, ff), na.rm = TRUE)
     gv.x <- (0.5 * sum.gd.x)/(n^2)
     return(gv.x)
     }
     calc.cumfreq <- function(freq, dist) {
     m <- length(freq)
     n <- ncol(dist)
     res <- matrix(0, n, m)
     for (i in 1:m) res[, i] <- (colSums(dist <= freq[i]))/nrow(dist)
     return(res)
     }
     if (identical(miss, "list")) {
     data <- na.omit(data)
     n <- nrow(data)
     }
     if ((choice == "both") | (choice == "hull")) {
     message("Performing convex hull test ...")
     test.result <- convex.hull.test(x = na.omit(data), z = cfact,
     mc.cores = mc.cores)
     }
     if ((choice == "both") | (choice == "distance")) {
     message("Calculating distances ....")
     if (identical(distance, "gower")) {
     samp.range <- apply(data, 2, max, na.rm = TRUE) -
     apply(data, 2, min, na.rm = TRUE)
     if (!is.null(range)) {
     w <- which(!is.na(range))
     samp.range[w] <- range[w]
     }
     if (identical(TRUE, any(samp.range == 0))) {
     message("Note: range of at least one variable equals zero")
     }
     dist <- calc.gd(dat = data, cf = cfact, range = samp.range)
     }
     else {
     dist <- calc.ed(dat = na.omit(data), cf = cfact)
     }
     message("Calculating the geometric variance...")
     if (identical(distance, "gower")) {
     gv.x <- geom.var(dat = data, rang = samp.range)
     }
     else {
     gv.x <- 0.5 * mean(calc.ed(dat = na.omit(data), cf = na.omit(data)))
     }
     if (identical(miss, "case") && identical(distance, "euclidian")) {
     summary <- colSums(dist <= nearby * gv.x) * (1/nrow(na.omit(data)))
     }
     else {
     summary <- colSums(dist <= nearby * gv.x) * (1/n)
     }
     message("Calculating cumulative frequencies ...")
     if (is.null(freq)) {
     if (identical(distance, "gower")) {
     freqdist <- seq(0, 1, by = 0.05)
     }
     else {
     min.ed <- min(dist)
     max.ed <- max(dist)
     freqdist <- round(seq(min.ed, max.ed, by = (max.ed -
     min.ed)/20), 2)
     }
     }
     else {
     freqdist <- freq
     }
     cumfreq <- calc.cumfreq(freq = freqdist, dist = dist)
     dimnames(cumfreq) <- list(seq(1, nrow(cfact), by = 1),
     freqdist)
     }
     message("Finishing up ...")
     if (return.inputs) {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), dist = t(dist), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result)
     }
     }
     else {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), in.hull = test.result,
     dist = t(dist), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), in.hull = test.result,
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), in.hull = test.result)
     }
     }
     class(out) <- "whatif"
     return(invisible(out))
    }
    <bytecode: 0x10021d30>
    <environment: namespace:WhatIf>
     --- function search by body ---
    Function whatif in namespace WhatIf has this body.
     ----------- END OF FAILURE REPORT --------------
    Error in if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data) :
     the condition has length > 1
    Calls: whatif
    Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang

Version: 1.5-9
Check: tests
Result: ERROR
     Running ‘testthat.R’ [23s/29s]
    Running the tests in ‘tests/testthat.R’ failed.
    Complete output:
     > library(testthat)
     > library(WhatIf)
     > library(Zelig)
     Loading required package: survival
     >
     > test_check("WhatIf")

     |
     | | 0%
     |
     |= | 1%
     |
     |= | 2%
     |
     |== | 2%
     |
     |== | 3%
     |
     |=== | 4%
     |
     |=== | 5%
     |
     |==== | 6%
     |
     |===== | 7%
     |
     |====== | 8%
     |
     |====== | 9%
     |
     |======= | 10%
     |
     |======== | 11%
     |
     |======== | 12%
     |
     |========= | 12%
     |
     |========= | 13%
     |
     |========== | 14%
     |
     |========== | 15%
     |
     |=========== | 16%
     |
     |============ | 17%
     |
     |============= | 18%
     |
     |============= | 19%
     |
     |============== | 20%
     |
     |============== | 21%
     |
     |=============== | 21%
     |
     |================ | 22%
     |
     |================ | 23%
     |
     |================= | 24%
     |
     |================= | 25%
     |
     |================== | 26%
     |
     |=================== | 26%
     |
     |=================== | 27%
     |
     |==================== | 28%
     |
     |==================== | 29%
     |
     |===================== | 30%
     |
     |===================== | 31%
     |
     |====================== | 31%
     |
     |======================= | 32%
     |
     |======================= | 33%
     |
     |======================== | 34%
     |
     |======================== | 35%
     |
     |========================= | 36%
     |
     |========================== | 37%
     |
     |=========================== | 38%
     |
     |=========================== | 39%
     |
     |============================ | 40%
     |
     |============================= | 41%
     |
     |============================== | 42%
     |
     |============================== | 43%
     |
     |=============================== | 44%
     |
     |=============================== | 45%
     |
     |================================ | 45%
     |
     |================================ | 46%
     |
     |================================= | 47%
     |
     |================================== | 48%
     |
     |================================== | 49%
     |
     |=================================== | 50%
     |
     |==================================== | 51%
     |
     |==================================== | 52%
     |
     |===================================== | 53%
     |
     |====================================== | 54%
     |
     |====================================== | 55%
     |
     |======================================= | 55%
     |
     |======================================= | 56%
     |
     |======================================== | 57%
     |
     |======================================== | 58%
     |
     |========================================= | 59%
     |
     |========================================== | 60%
     |
     |=========================================== | 61%
     |
     |=========================================== | 62%
     |
     |============================================ | 63%
     |
     |============================================= | 64%
     |
     |============================================== | 65%
     |
     |============================================== | 66%
     |
     |=============================================== | 67%
     |
     |=============================================== | 68%
     |
     |================================================ | 69%
     |
     |================================================= | 69%
     |
     |================================================= | 70%
     |
     |================================================== | 71%
     |
     |================================================== | 72%
     |
     |=================================================== | 73%
     |
     |=================================================== | 74%
     |
     |==================================================== | 74%
     |
     |===================================================== | 75%
     |
     |===================================================== | 76%
     |
     |====================================================== | 77%
     |
     |====================================================== | 78%
     |
     |======================================================= | 79%
     |
     |======================================================== | 79%
     |
     |======================================================== | 80%
     |
     |========================================================= | 81%
     |
     |========================================================= | 82%
     |
     |========================================================== | 83%
     |
     |=========================================================== | 84%
     |
     |============================================================ | 85%
     |
     |============================================================ | 86%
     |
     |============================================================= | 87%
     |
     |============================================================= | 88%
     |
     |============================================================== | 88%
     |
     |============================================================== | 89%
     |
     |=============================================================== | 90%
     |
     |================================================================ | 91%
     |
     |================================================================ | 92%
     |
     |================================================================= | 93%
     |
     |================================================================== | 94%
     |
     |=================================================================== | 95%
     |
     |=================================================================== | 96%
     |
     |==================================================================== | 97%
     |
     |==================================================================== | 98%
     |
     |===================================================================== | 98%
     |
     |===================================================================== | 99%
     |
     |======================================================================| 100%
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
     :
     --- package (from environment) ---
     WhatIf
     --- call from context ---
     whatif(data = my.data, cfact = matrix(my.cfact[1, ], nrow = 1),
     mc.cores = 1)
     --- call from argument ---
     if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data)
     --- R stacktrace ---
     where 1: whatif(data = my.data, cfact = matrix(my.cfact[1, ], nrow = 1),
     mc.cores = 1)
     where 2: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
     where 3: withCallingHandlers({
     code
     NULL
     }, error = function(cnd) {
     if (can_entrace(cnd)) {
     cnd <- cnd_entrace(cnd)
     }
     return_from(env, cnd)
     })
     where 4: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
     ...)
     where 5: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
     where 6 at testthat/test-whatif_convexhull.R#5: expect_error(whatif(data = my.data, cfact = matrix(my.cfact[1,
     ], nrow = 1), mc.cores = 1), NA)
     where 7: eval(code, test_env)
     where 8: eval(code, test_env)
     where 9: withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error)
     where 10: doTryCatch(return(expr), name, parentenv, handler)
     where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
     where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
     where 13: doTryCatch(return(expr), name, parentenv, handler)
     where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
     names[nh], parentenv, handlers[[nh]])
     where 15: tryCatchList(expr, classes, parentenv, handlers)
     where 16: tryCatch(withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error), error = handle_fatal,
     skip = function(e) {
     })
     where 17: test_code(desc, code, env = parent.frame())
     where 18 at testthat/test-whatif_convexhull.R#1: test_that("REQUIRE TEST whatif with 1 counterfactual", {
     my.cfact <- matrix(rnorm(3 * 5), ncol = 5)
     my.data <- matrix(rnorm(100 * 5), ncol = 5)
     expect_error(whatif(data = my.data, cfact = matrix(my.cfact[1,
     ], nrow = 1), mc.cores = 1), NA)
     })
     where 19: eval(code, test_env)
     where 20: eval(code, test_env)
     where 21: withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error)
     where 22: doTryCatch(return(expr), name, parentenv, handler)
     where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
     where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
     where 25: doTryCatch(return(expr), name, parentenv, handler)
     where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
     names[nh], parentenv, handlers[[nh]])
     where 27: tryCatchList(expr, classes, parentenv, handlers)
     where 28: tryCatch(withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error), error = handle_fatal,
     skip = function(e) {
     })
     where 29: test_code(NULL, exprs, env)
     where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
     where 31: force(code)
     where 32: doWithOneRestart(return(expr), restart)
     where 33: withOneRestart(expr, restarts[[1L]])
     where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
     where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
     {
     reporter$start_file(basename(path))
     lister$start_file(basename(path))
     source_file(path, new.env(parent = env), chdir = TRUE,
     wrap = wrap)
     reporter$.end_context()
     reporter$end_file()
     })
     where 36: FUN(X[[i]], ...)
     where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
     start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
     where 38: force(code)
     where 39: doWithOneRestart(return(expr), restart)
     where 40: withOneRestart(expr, restarts[[1L]])
     where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
     where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
     test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
     load_helpers = FALSE, wrap = wrap))
     where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
     stop_on_warning = stop_on_warning, wrap = wrap)
     where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
     ..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
     wrap = wrap)
     where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
     reporter = reporter, ..., stop_on_failure = stop_on_failure,
     stop_on_warning = stop_on_warning, wrap = wrap)
     where 46: test_check("WhatIf")

     --- value of length: 2 type: logical ---
     [1] FALSE FALSE
     --- function from context ---
     function (formula = NULL, data, cfact, range = NULL, freq = NULL,
     nearby = 1, distance = "gower", miss = "list", choice = "both",
     return.inputs = FALSE, return.distance = FALSE, mc.cores = detectCores(),
     ...)
     {
     if (mc.cores <= 0)
     stop("mc.cores must be an integer greater than 0.", call. = FALSE)
     message("Preprocessing data ...")
     if (grepl("Zelig*", class(data)) & missing(cfact))
     cfact <- zelig_setx_to_df(data)
     if (grepl("Zelig*", class(data)) & !missing(cfact)) {
     formula <- formula(delete.response(terms(data$formula)))
     data <- data$zelig.out$z.out[[1]]$model
     }
     if (!((is.character(cfact) && is.vector(cfact) && length(cfact) ==
     1) || is.data.frame(cfact) || (is.matrix(cfact) && !is.character(cfact)))) {
     stop("'cfact' must be either a string, a R data frame, or a R non-character matrix")
     }
     if (is.character(cfact)) {
     cfact <- read.table(cfact)
     }
     if (dim(cfact)[1] == 0) {
     stop("no counterfactuals supplied: 'cfact' contains zero rows")
     }
     if (!any(complete.cases(cfact))) {
     stop("there are no cases in 'cfact' without missing values")
     }
     if ("(Intercept)" %in% dimnames(cfact)[[2]]) {
     cfact <- cfact[, -(which(dimnames(cfact)[[2]] == "(Intercept)"))]
     }
     if (is.list(data) && !(is.data.frame(data))) {
     if (!((("formula" %in% names(data)) || ("terms" %in%
     names(data))) && (("data" %in% names(data)) || ("model" %in%
     names(data))))) {
     stop("the list supplied to 'data' is not a valid output object")
     }
     tt <- terms(data)
     attr(tt, "intercept") <- rep(0, length(attr(tt, "intercept")))
     if ("data" %in% names(data)) {
     if (is.data.frame(data$data)) {
     data <- model.matrix(tt, model.frame(tt, data = data$data,
     na.action = NULL))
     }
     else {
     data <- model.matrix(tt, model.frame(tt, data = eval(data$data,
     envir = .GlobalEnv), na.action = NULL))
     }
     }
     else {
     data <- model.matrix(tt, data = data$model)
     }
     if (!(is.matrix(data))) {
     stop("observed covariate data could not be extracted from output object")
     }
     rm(tt)
     }
     else {
     if (!((is.character(data) && is.vector(data) && length(data) ==
     1) || is.data.frame(data) || (is.matrix(data) &&
     !is.character(data)))) {
     stop("'data' must be either a string, a R data frame, a R non-character matrix, or an output object")
     }
     if (is.character(data)) {
     data <- read.table(data)
     }
     }
     if (dim(data)[1] == 0) {
     stop("no observed covariate data supplied: 'data' contains zero rows")
     }
     if (!any(complete.cases(data))) {
     stop("there are no cases in 'data' without missing values")
     }
     if (!(is.null(formula))) {
     if (identical(class(formula), "formula")) {
     if (!(is.data.frame(as.data.frame(data)))) {
     stop("'data' must be coercable to a data frame in order to use 'formula'")
     }
     if (!(is.data.frame(as.data.frame(cfact)))) {
     stop("'cfact' must be coercable to a data frame in order to use 'formula'")
     }
     formula <- update.formula(formula, ~. - 1)
     ttvar <- all.vars(formula)
     for (i in 1:length(ttvar)) {
     if (!(ttvar[i] %in% dimnames(data)[[2]])) {
     stop("variables in 'formula' either unlabeled or not present in 'data'")
     }
     if (!(ttvar[i] %in% dimnames(cfact)[[2]])) {
     stop("variable(s) in 'formula' either unlabeled or not present in 'cfact'")
     }
     }
     rm(ttvar)
     data <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(data), na.action = NULL))
     cfact <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(cfact), na.action = NULL))
     }
     else {
     stop("'formula' must be of class 'formula'")
     }
     }
     if (!(identical(complete.cases(cfact), rep(TRUE, dim(cfact)[1])))) {
     cfact <- na.omit(cfact)
     message("Note: counterfactuals with missing values eliminated from cfact")
     }
     if (is.data.frame(data)) {
     if (is.character(as.matrix(data))) {
     stop("observed covariate data not coercable to numeric matrix due to character column(s)")
     }
     data <- suppressWarnings(data.matrix(data))
     }
     else {
     data <- data.matrix(as.data.frame(data))
     }
     if (is.data.frame(cfact)) {
     if (is.character(as.matrix(cfact))) {
     stop("counterfactual data not coercable to numeric matrix due to character column(s)")
     }
     cfact <- suppressWarnings(data.matrix(cfact))
     }
     else {
     cfact <- data.matrix(as.data.frame(cfact))
     }
     if (!(is.matrix(data) && is.numeric(data))) {
     stop("observed covariate data not coercable to numeric matrix")
     }
     if (!(is.matrix(cfact) && is.numeric(cfact))) {
     stop("counterfactual data not coercable to numeric matrix")
     }
     na.fail(cfact)
     if (!identical(ncol(cfact), ncol(data))) {
     stop("number of columns of 'cfact' and 'data' are not equal")
     }
     if (!(is.null(range))) {
     if (!(is.vector(range) && is.numeric(range))) {
     stop("'range' must be a numeric vector")
     }
     if (!identical(length(range), ncol(data))) {
     stop("length of 'range' does not equal number of columns of 'data'")
     }
     }
     if (!(is.null(freq))) {
     if (!(is.vector(freq) && is.numeric(freq))) {
     stop("'freq' must be a numeric vector")
     }
     na.fail(freq)
     }
     if (!(is.null(nearby))) {
     if (!(is.numeric(nearby) && is.vector(nearby) && length(nearby) ==
     1 && nearby >= 0)) {
     stop("'nearby' must be numeric, greater than or equal to 0, and a scalar")
     }
     }
     if (!(identical(miss, "list") || identical(miss, "case"))) {
     stop("'miss' must be either ''case'' or ''list''")
     }
     if (!(identical(distance, "gower") || identical(distance,
     "euclidian"))) {
     stop("'distance' must be either ''gower'' or ''euclidian''")
     }
     if (!(identical(choice, "both") || identical(choice, "hull") ||
     identical(choice, "distance"))) {
     stop("'choice' must be either ''both'', ''hull'', or ''distance''")
     }
     if (!(is.logical(return.inputs))) {
     stop("'return.inputs' must be logical, i.e. either TRUE or FALSE")
     }
     if (!(is.logical(return.distance))) {
     stop("'return.distance' must be logical, i.e. either TRUE or FALSE")
     }
     n = nrow(data)
     convex.hull.test <- function(x, z, mc.cores = mc.cores) {
     one_core_pb <- mc.cores == 1
     n <- nrow(x)
     k <- ncol(x)
     m <- nrow(z)
     if (one_core_pb && m == 1)
     one_core_pb <- FALSE
     if (one_core_pb)
     pb <- txtProgressBar(min = 1, max = m, style = 3)
     A <- rbind(t(x), rep(1, n))
     C <- c(rep(0, n))
     D <- c(rep("=", k + 1))
     in_ch <- function(i, one_core_pb = FALSE) {
     B <- c(z[i, ], 1)
     lp.result <- lp(objective.in = C, const.mat = A,
     const.dir = D, const.rhs = B)
     if (one_core_pb)
     setTxtProgressBar(pb, i)
     if (lp.result$status == 0)
     return(TRUE)
     else return(FALSE)
     }
     if (one_core_pb) {
     hull <- sapply(1:m, in_ch, one_core_pb = one_core_pb)
     }
     else {
     if (.Platform$OS.type == "windows")
     hull <- mclapply(1:m, in_ch, mc.cores = mc.cores)
     else hull <- pbmclapply(1:m, in_ch, mc.cores = mc.cores)
     hull <- unlist(hull)
     }
     if (one_core_pb)
     close(pb)
     return(hull)
     }
     calc.gd <- function(dat, cf, range) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat = t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- abs(dat - cf[i, ])/range
     if (any(range == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     dist[i, ] <- colMeans(temp, na.rm = T)
     }
     return(t(dist))
     }
     calc.ed <- function(dat, cf) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat <- t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- (dat - cf[i, ])^2
     dist[i, ] <- (colSums(temp))
     }
     return(t(dist))
     }
     geom.var <- function(dat, rang) {
     n <- nrow(dat)
     dat <- t(dat)
     ff <- function(x) {
     temp <- abs(dat - x)/rang
     if (any(rang == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     tmp <- sum(colMeans(temp, na.rm = TRUE))
     return(tmp)
     }
     sum.gd.x <- sum(apply(dat, 2, ff), na.rm = TRUE)
     gv.x <- (0.5 * sum.gd.x)/(n^2)
     return(gv.x)
     }
     calc.cumfreq <- function(freq, dist) {
     m <- length(freq)
     n <- ncol(dist)
     res <- matrix(0, n, m)
     for (i in 1:m) res[, i] <- (colSums(dist <= freq[i]))/nrow(dist)
     return(res)
     }
     if (identical(miss, "list")) {
     data <- na.omit(data)
     n <- nrow(data)
     }
     if ((choice == "both") | (choice == "hull")) {
     message("Performing convex hull test ...")
     test.result <- convex.hull.test(x = na.omit(data), z = cfact,
     mc.cores = mc.cores)
     }
     if ((choice == "both") | (choice == "distance")) {
     message("Calculating distances ....")
     if (identical(distance, "gower")) {
     samp.range <- apply(data, 2, max, na.rm = TRUE) -
     apply(data, 2, min, na.rm = TRUE)
     if (!is.null(range)) {
     w <- which(!is.na(range))
     samp.range[w] <- range[w]
     }
     if (identical(TRUE, any(samp.range == 0))) {
     message("Note: range of at least one variable equals zero")
     }
     dist <- calc.gd(dat = data, cf = cfact, range = samp.range)
     }
     else {
     dist <- calc.ed(dat = na.omit(data), cf = cfact)
     }
     message("Calculating the geometric variance...")
     if (identical(distance, "gower")) {
     gv.x <- geom.var(dat = data, rang = samp.range)
     }
     else {
     gv.x <- 0.5 * mean(calc.ed(dat = na.omit(data), cf = na.omit(data)))
     }
     if (identical(miss, "case") && identical(distance, "euclidian")) {
     summary <- colSums(dist <= nearby * gv.x) * (1/nrow(na.omit(data)))
     }
     else {
     summary <- colSums(dist <= nearby * gv.x) * (1/n)
     }
     message("Calculating cumulative frequencies ...")
     if (is.null(freq)) {
     if (identical(distance, "gower")) {
     freqdist <- seq(0, 1, by = 0.05)
     }
     else {
     min.ed <- min(dist)
     max.ed <- max(dist)
     freqdist <- round(seq(min.ed, max.ed, by = (max.ed -
     min.ed)/20), 2)
     }
     }
     else {
     freqdist <- freq
     }
     cumfreq <- calc.cumfreq(freq = freqdist, dist = dist)
     dimnames(cumfreq) <- list(seq(1, nrow(cfact), by = 1),
     freqdist)
     }
     message("Finishing up ...")
     if (return.inputs) {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), dist = t(dist), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result)
     }
     }
     else {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), in.hull = test.result,
     dist = t(dist), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), in.hull = test.result,
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), in.hull = test.result)
     }
     }
     class(out) <- "whatif"
     return(invisible(out))
     }
     <bytecode: 0xf4e09a0>
     <environment: namespace:WhatIf>
     --- function search by body ---
     Function whatif in namespace WhatIf has this body.
     ----------- END OF FAILURE REPORT --------------
     ── 1. Failure: REQUIRE TEST whatif with 1 counterfactual (@test-whatif_convexhul
     `whatif(...)` threw an error.
     Message: the condition has length > 1
     Class: simpleError/error/condition
     Backtrace:
     1. testthat::expect_error(...)
     6. WhatIf::whatif(...)

     [1] "3 cores"
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/
     ══ testthat results ═══════════════════════════════════════════════════════════
     [ OK: 16 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 1 ]
     1. Failure: REQUIRE TEST whatif with 1 counterfactual (@test-whatif_convexhull.R#5)

     Error: testthat unit tests failed
     Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang

Version: 1.5-9
Check: examples
Result: ERROR
    Running examples in ‘WhatIf-Ex.R’ failed
    The error most likely occurred in:

    > ### Name: plot.whatif
    > ### Title: Plot Cumulative Frequencies of Distances for "whatif" Objects
    > ### Aliases: plot.whatif
    > ### Keywords: hplot
    >
    > ### ** Examples
    >
    > ## Create example data sets and counterfactuals
    > my.cfact <- matrix(rnorm(3*5), ncol = 5)
    > my.data <- matrix(rnorm(100*5), ncol = 5)
    >
    > ## Evaluate counterfactuals
    > my.result <- whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
    Preprocessing data ...
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    WhatIf
     --- call from context ---
    whatif(data = my.data, cfact = my.cfact, mc.cores = 1)
     --- call from argument ---
    if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data)
     --- R stacktrace ---
    where 1: whatif(data = my.data, cfact = my.cfact, mc.cores = 1)

     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (formula = NULL, data, cfact, range = NULL, freq = NULL,
     nearby = 1, distance = "gower", miss = "list", choice = "both",
     return.inputs = FALSE, return.distance = FALSE, mc.cores = detectCores(),
     ...)
    {
     if (mc.cores <= 0)
     stop("mc.cores must be an integer greater than 0.", call. = FALSE)
     message("Preprocessing data ...")
     if (grepl("Zelig*", class(data)) & missing(cfact))
     cfact <- zelig_setx_to_df(data)
     if (grepl("Zelig*", class(data)) & !missing(cfact)) {
     formula <- formula(delete.response(terms(data$formula)))
     data <- data$zelig.out$z.out[[1]]$model
     }
     if (!((is.character(cfact) && is.vector(cfact) && length(cfact) ==
     1) || is.data.frame(cfact) || (is.matrix(cfact) && !is.character(cfact)))) {
     stop("'cfact' must be either a string, a R data frame, or a R non-character matrix")
     }
     if (is.character(cfact)) {
     cfact <- read.table(cfact)
     }
     if (dim(cfact)[1] == 0) {
     stop("no counterfactuals supplied: 'cfact' contains zero rows")
     }
     if (!any(complete.cases(cfact))) {
     stop("there are no cases in 'cfact' without missing values")
     }
     if ("(Intercept)" %in% dimnames(cfact)[[2]]) {
     cfact <- cfact[, -(which(dimnames(cfact)[[2]] == "(Intercept)"))]
     }
     if (is.list(data) && !(is.data.frame(data))) {
     if (!((("formula" %in% names(data)) || ("terms" %in%
     names(data))) && (("data" %in% names(data)) || ("model" %in%
     names(data))))) {
     stop("the list supplied to 'data' is not a valid output object")
     }
     tt <- terms(data)
     attr(tt, "intercept") <- rep(0, length(attr(tt, "intercept")))
     if ("data" %in% names(data)) {
     if (is.data.frame(data$data)) {
     data <- model.matrix(tt, model.frame(tt, data = data$data,
     na.action = NULL))
     }
     else {
     data <- model.matrix(tt, model.frame(tt, data = eval(data$data,
     envir = .GlobalEnv), na.action = NULL))
     }
     }
     else {
     data <- model.matrix(tt, data = data$model)
     }
     if (!(is.matrix(data))) {
     stop("observed covariate data could not be extracted from output object")
     }
     rm(tt)
     }
     else {
     if (!((is.character(data) && is.vector(data) && length(data) ==
     1) || is.data.frame(data) || (is.matrix(data) &&
     !is.character(data)))) {
     stop("'data' must be either a string, a R data frame, a R non-character matrix, or an output object")
     }
     if (is.character(data)) {
     data <- read.table(data)
     }
     }
     if (dim(data)[1] == 0) {
     stop("no observed covariate data supplied: 'data' contains zero rows")
     }
     if (!any(complete.cases(data))) {
     stop("there are no cases in 'data' without missing values")
     }
     if (!(is.null(formula))) {
     if (identical(class(formula), "formula")) {
     if (!(is.data.frame(as.data.frame(data)))) {
     stop("'data' must be coercable to a data frame in order to use 'formula'")
     }
     if (!(is.data.frame(as.data.frame(cfact)))) {
     stop("'cfact' must be coercable to a data frame in order to use 'formula'")
     }
     formula <- update.formula(formula, ~. - 1)
     ttvar <- all.vars(formula)
     for (i in 1:length(ttvar)) {
     if (!(ttvar[i] %in% dimnames(data)[[2]])) {
     stop("variables in 'formula' either unlabeled or not present in 'data'")
     }
     if (!(ttvar[i] %in% dimnames(cfact)[[2]])) {
     stop("variable(s) in 'formula' either unlabeled or not present in 'cfact'")
     }
     }
     rm(ttvar)
     data <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(data), na.action = NULL))
     cfact <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(cfact), na.action = NULL))
     }
     else {
     stop("'formula' must be of class 'formula'")
     }
     }
     if (!(identical(complete.cases(cfact), rep(TRUE, dim(cfact)[1])))) {
     cfact <- na.omit(cfact)
     message("Note: counterfactuals with missing values eliminated from cfact")
     }
     if (is.data.frame(data)) {
     if (is.character(as.matrix(data))) {
     stop("observed covariate data not coercable to numeric matrix due to character column(s)")
     }
     data <- suppressWarnings(data.matrix(data))
     }
     else {
     data <- data.matrix(as.data.frame(data))
     }
     if (is.data.frame(cfact)) {
     if (is.character(as.matrix(cfact))) {
     stop("counterfactual data not coercable to numeric matrix due to character column(s)")
     }
     cfact <- suppressWarnings(data.matrix(cfact))
     }
     else {
     cfact <- data.matrix(as.data.frame(cfact))
     }
     if (!(is.matrix(data) && is.numeric(data))) {
     stop("observed covariate data not coercable to numeric matrix")
     }
     if (!(is.matrix(cfact) && is.numeric(cfact))) {
     stop("counterfactual data not coercable to numeric matrix")
     }
     na.fail(cfact)
     if (!identical(ncol(cfact), ncol(data))) {
     stop("number of columns of 'cfact' and 'data' are not equal")
     }
     if (!(is.null(range))) {
     if (!(is.vector(range) && is.numeric(range))) {
     stop("'range' must be a numeric vector")
     }
     if (!identical(length(range), ncol(data))) {
     stop("length of 'range' does not equal number of columns of 'data'")
     }
     }
     if (!(is.null(freq))) {
     if (!(is.vector(freq) && is.numeric(freq))) {
     stop("'freq' must be a numeric vector")
     }
     na.fail(freq)
     }
     if (!(is.null(nearby))) {
     if (!(is.numeric(nearby) && is.vector(nearby) && length(nearby) ==
     1 && nearby >= 0)) {
     stop("'nearby' must be numeric, greater than or equal to 0, and a scalar")
     }
     }
     if (!(identical(miss, "list") || identical(miss, "case"))) {
     stop("'miss' must be either ''case'' or ''list''")
     }
     if (!(identical(distance, "gower") || identical(distance,
     "euclidian"))) {
     stop("'distance' must be either ''gower'' or ''euclidian''")
     }
     if (!(identical(choice, "both") || identical(choice, "hull") ||
     identical(choice, "distance"))) {
     stop("'choice' must be either ''both'', ''hull'', or ''distance''")
     }
     if (!(is.logical(return.inputs))) {
     stop("'return.inputs' must be logical, i.e. either TRUE or FALSE")
     }
     if (!(is.logical(return.distance))) {
     stop("'return.distance' must be logical, i.e. either TRUE or FALSE")
     }
     n = nrow(data)
     convex.hull.test <- function(x, z, mc.cores = mc.cores) {
     one_core_pb <- mc.cores == 1
     n <- nrow(x)
     k <- ncol(x)
     m <- nrow(z)
     if (one_core_pb && m == 1)
     one_core_pb <- FALSE
     if (one_core_pb)
     pb <- txtProgressBar(min = 1, max = m, style = 3)
     A <- rbind(t(x), rep(1, n))
     C <- c(rep(0, n))
     D <- c(rep("=", k + 1))
     in_ch <- function(i, one_core_pb = FALSE) {
     B <- c(z[i, ], 1)
     lp.result <- lp(objective.in = C, const.mat = A,
     const.dir = D, const.rhs = B)
     if (one_core_pb)
     setTxtProgressBar(pb, i)
     if (lp.result$status == 0)
     return(TRUE)
     else return(FALSE)
     }
     if (one_core_pb) {
     hull <- sapply(1:m, in_ch, one_core_pb = one_core_pb)
     }
     else {
     if (.Platform$OS.type == "windows")
     hull <- mclapply(1:m, in_ch, mc.cores = mc.cores)
     else hull <- pbmclapply(1:m, in_ch, mc.cores = mc.cores)
     hull <- unlist(hull)
     }
     if (one_core_pb)
     close(pb)
     return(hull)
     }
     calc.gd <- function(dat, cf, range) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat = t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- abs(dat - cf[i, ])/range
     if (any(range == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     dist[i, ] <- colMeans(temp, na.rm = T)
     }
     return(t(dist))
     }
     calc.ed <- function(dat, cf) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat <- t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- (dat - cf[i, ])^2
     dist[i, ] <- (colSums(temp))
     }
     return(t(dist))
     }
     geom.var <- function(dat, rang) {
     n <- nrow(dat)
     dat <- t(dat)
     ff <- function(x) {
     temp <- abs(dat - x)/rang
     if (any(rang == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     tmp <- sum(colMeans(temp, na.rm = TRUE))
     return(tmp)
     }
     sum.gd.x <- sum(apply(dat, 2, ff), na.rm = TRUE)
     gv.x <- (0.5 * sum.gd.x)/(n^2)
     return(gv.x)
     }
     calc.cumfreq <- function(freq, dist) {
     m <- length(freq)
     n <- ncol(dist)
     res <- matrix(0, n, m)
     for (i in 1:m) res[, i] <- (colSums(dist <= freq[i]))/nrow(dist)
     return(res)
     }
     if (identical(miss, "list")) {
     data <- na.omit(data)
     n <- nrow(data)
     }
     if ((choice == "both") | (choice == "hull")) {
     message("Performing convex hull test ...")
     test.result <- convex.hull.test(x = na.omit(data), z = cfact,
     mc.cores = mc.cores)
     }
     if ((choice == "both") | (choice == "distance")) {
     message("Calculating distances ....")
     if (identical(distance, "gower")) {
     samp.range <- apply(data, 2, max, na.rm = TRUE) -
     apply(data, 2, min, na.rm = TRUE)
     if (!is.null(range)) {
     w <- which(!is.na(range))
     samp.range[w] <- range[w]
     }
     if (identical(TRUE, any(samp.range == 0))) {
     message("Note: range of at least one variable equals zero")
     }
     dist <- calc.gd(dat = data, cf = cfact, range = samp.range)
     }
     else {
     dist <- calc.ed(dat = na.omit(data), cf = cfact)
     }
     message("Calculating the geometric variance...")
     if (identical(distance, "gower")) {
     gv.x <- geom.var(dat = data, rang = samp.range)
     }
     else {
     gv.x <- 0.5 * mean(calc.ed(dat = na.omit(data), cf = na.omit(data)))
     }
     if (identical(miss, "case") && identical(distance, "euclidian")) {
     summary <- colSums(dist <= nearby * gv.x) * (1/nrow(na.omit(data)))
     }
     else {
     summary <- colSums(dist <= nearby * gv.x) * (1/n)
     }
     message("Calculating cumulative frequencies ...")
     if (is.null(freq)) {
     if (identical(distance, "gower")) {
     freqdist <- seq(0, 1, by = 0.05)
     }
     else {
     min.ed <- min(dist)
     max.ed <- max(dist)
     freqdist <- round(seq(min.ed, max.ed, by = (max.ed -
     min.ed)/20), 2)
     }
     }
     else {
     freqdist <- freq
     }
     cumfreq <- calc.cumfreq(freq = freqdist, dist = dist)
     dimnames(cumfreq) <- list(seq(1, nrow(cfact), by = 1),
     freqdist)
     }
     message("Finishing up ...")
     if (return.inputs) {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), dist = t(dist), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result)
     }
     }
     else {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), in.hull = test.result,
     dist = t(dist), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), in.hull = test.result,
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), in.hull = test.result)
     }
     }
     class(out) <- "whatif"
     return(invisible(out))
    }
    <bytecode: 0x112a8a20>
    <environment: namespace:WhatIf>
     --- function search by body ---
    Function whatif in namespace WhatIf has this body.
     ----------- END OF FAILURE REPORT --------------
    Error in if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data) :
     the condition has length > 1
    Calls: whatif
    Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc

Version: 1.5-9
Check: tests
Result: ERROR
     Running ‘testthat.R’ [24s/28s]
    Running the tests in ‘tests/testthat.R’ failed.
    Complete output:
     > library(testthat)
     > library(WhatIf)
     > library(Zelig)
     Loading required package: survival
     >
     > test_check("WhatIf")

     |
     | | 0%
     |
     |= | 1%
     |
     |= | 2%
     |
     |== | 2%
     |
     |== | 3%
     |
     |=== | 4%
     |
     |=== | 5%
     |
     |==== | 6%
     |
     |===== | 7%
     |
     |====== | 8%
     |
     |====== | 9%
     |
     |======= | 10%
     |
     |======== | 11%
     |
     |======== | 12%
     |
     |========= | 12%
     |
     |========= | 13%
     |
     |========== | 14%
     |
     |========== | 15%
     |
     |=========== | 16%
     |
     |============ | 17%
     |
     |============= | 18%
     |
     |============= | 19%
     |
     |============== | 20%
     |
     |============== | 21%
     |
     |=============== | 21%
     |
     |================ | 22%
     |
     |================ | 23%
     |
     |================= | 24%
     |
     |================= | 25%
     |
     |================== | 26%
     |
     |=================== | 26%
     |
     |=================== | 27%
     |
     |==================== | 28%
     |
     |==================== | 29%
     |
     |===================== | 30%
     |
     |===================== | 31%
     |
     |====================== | 31%
     |
     |======================= | 32%
     |
     |======================= | 33%
     |
     |======================== | 34%
     |
     |======================== | 35%
     |
     |========================= | 36%
     |
     |========================== | 37%
     |
     |=========================== | 38%
     |
     |=========================== | 39%
     |
     |============================ | 40%
     |
     |============================= | 41%
     |
     |============================== | 42%
     |
     |============================== | 43%
     |
     |=============================== | 44%
     |
     |=============================== | 45%
     |
     |================================ | 45%
     |
     |================================ | 46%
     |
     |================================= | 47%
     |
     |================================== | 48%
     |
     |================================== | 49%
     |
     |=================================== | 50%
     |
     |==================================== | 51%
     |
     |==================================== | 52%
     |
     |===================================== | 53%
     |
     |====================================== | 54%
     |
     |====================================== | 55%
     |
     |======================================= | 55%
     |
     |======================================= | 56%
     |
     |======================================== | 57%
     |
     |======================================== | 58%
     |
     |========================================= | 59%
     |
     |========================================== | 60%
     |
     |=========================================== | 61%
     |
     |=========================================== | 62%
     |
     |============================================ | 63%
     |
     |============================================= | 64%
     |
     |============================================== | 65%
     |
     |============================================== | 66%
     |
     |=============================================== | 67%
     |
     |=============================================== | 68%
     |
     |================================================ | 69%
     |
     |================================================= | 69%
     |
     |================================================= | 70%
     |
     |================================================== | 71%
     |
     |================================================== | 72%
     |
     |=================================================== | 73%
     |
     |=================================================== | 74%
     |
     |==================================================== | 74%
     |
     |===================================================== | 75%
     |
     |===================================================== | 76%
     |
     |====================================================== | 77%
     |
     |====================================================== | 78%
     |
     |======================================================= | 79%
     |
     |======================================================== | 79%
     |
     |======================================================== | 80%
     |
     |========================================================= | 81%
     |
     |========================================================= | 82%
     |
     |========================================================== | 83%
     |
     |=========================================================== | 84%
     |
     |============================================================ | 85%
     |
     |============================================================ | 86%
     |
     |============================================================= | 87%
     |
     |============================================================= | 88%
     |
     |============================================================== | 88%
     |
     |============================================================== | 89%
     |
     |=============================================================== | 90%
     |
     |================================================================ | 91%
     |
     |================================================================ | 92%
     |
     |================================================================= | 93%
     |
     |================================================================== | 94%
     |
     |=================================================================== | 95%
     |
     |=================================================================== | 96%
     |
     |==================================================================== | 97%
     |
     |==================================================================== | 98%
     |
     |===================================================================== | 98%
     |
     |===================================================================== | 99%
     |
     |======================================================================| 100%
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
     :
     --- package (from environment) ---
     WhatIf
     --- call from context ---
     whatif(data = my.data, cfact = matrix(my.cfact[1, ], nrow = 1),
     mc.cores = 1)
     --- call from argument ---
     if (grepl("Zelig*", class(data)) & missing(cfact)) cfact <- zelig_setx_to_df(data)
     --- R stacktrace ---
     where 1: whatif(data = my.data, cfact = matrix(my.cfact[1, ], nrow = 1),
     mc.cores = 1)
     where 2: eval_bare(quo_get_expr(.quo), quo_get_env(.quo))
     where 3: withCallingHandlers({
     code
     NULL
     }, error = function(cnd) {
     if (can_entrace(cnd)) {
     cnd <- cnd_entrace(cnd)
     }
     return_from(env, cnd)
     })
     where 4: .capture(act$val <- eval_bare(quo_get_expr(.quo), quo_get_env(.quo)),
     ...)
     where 5: quasi_capture(enquo(object), label, capture_error, entrace = TRUE)
     where 6 at testthat/test-whatif_convexhull.R#5: expect_error(whatif(data = my.data, cfact = matrix(my.cfact[1,
     ], nrow = 1), mc.cores = 1), NA)
     where 7: eval(code, test_env)
     where 8: eval(code, test_env)
     where 9: withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error)
     where 10: doTryCatch(return(expr), name, parentenv, handler)
     where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
     where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
     where 13: doTryCatch(return(expr), name, parentenv, handler)
     where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
     names[nh], parentenv, handlers[[nh]])
     where 15: tryCatchList(expr, classes, parentenv, handlers)
     where 16: tryCatch(withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error), error = handle_fatal,
     skip = function(e) {
     })
     where 17: test_code(desc, code, env = parent.frame())
     where 18 at testthat/test-whatif_convexhull.R#1: test_that("REQUIRE TEST whatif with 1 counterfactual", {
     my.cfact <- matrix(rnorm(3 * 5), ncol = 5)
     my.data <- matrix(rnorm(100 * 5), ncol = 5)
     expect_error(whatif(data = my.data, cfact = matrix(my.cfact[1,
     ], nrow = 1), mc.cores = 1), NA)
     })
     where 19: eval(code, test_env)
     where 20: eval(code, test_env)
     where 21: withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error)
     where 22: doTryCatch(return(expr), name, parentenv, handler)
     where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
     where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
     where 25: doTryCatch(return(expr), name, parentenv, handler)
     where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
     names[nh], parentenv, handlers[[nh]])
     where 27: tryCatchList(expr, classes, parentenv, handlers)
     where 28: tryCatch(withCallingHandlers({
     eval(code, test_env)
     if (!handled && !is.null(test)) {
     skip_empty()
     }
     }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
     message = handle_message, error = handle_error), error = handle_fatal,
     skip = function(e) {
     })
     where 29: test_code(NULL, exprs, env)
     where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
     where 31: force(code)
     where 32: doWithOneRestart(return(expr), restart)
     where 33: withOneRestart(expr, restarts[[1L]])
     where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
     where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
     {
     reporter$start_file(basename(path))
     lister$start_file(basename(path))
     source_file(path, new.env(parent = env), chdir = TRUE,
     wrap = wrap)
     reporter$.end_context()
     reporter$end_file()
     })
     where 36: FUN(X[[i]], ...)
     where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
     start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
     where 38: force(code)
     where 39: doWithOneRestart(return(expr), restart)
     where 40: withOneRestart(expr, restarts[[1L]])
     where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
     where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
     test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
     load_helpers = FALSE, wrap = wrap))
     where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
     stop_on_warning = stop_on_warning, wrap = wrap)
     where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
     ..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
     wrap = wrap)
     where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
     reporter = reporter, ..., stop_on_failure = stop_on_failure,
     stop_on_warning = stop_on_warning, wrap = wrap)
     where 46: test_check("WhatIf")

     --- value of length: 2 type: logical ---
     [1] FALSE FALSE
     --- function from context ---
     function (formula = NULL, data, cfact, range = NULL, freq = NULL,
     nearby = 1, distance = "gower", miss = "list", choice = "both",
     return.inputs = FALSE, return.distance = FALSE, mc.cores = detectCores(),
     ...)
     {
     if (mc.cores <= 0)
     stop("mc.cores must be an integer greater than 0.", call. = FALSE)
     message("Preprocessing data ...")
     if (grepl("Zelig*", class(data)) & missing(cfact))
     cfact <- zelig_setx_to_df(data)
     if (grepl("Zelig*", class(data)) & !missing(cfact)) {
     formula <- formula(delete.response(terms(data$formula)))
     data <- data$zelig.out$z.out[[1]]$model
     }
     if (!((is.character(cfact) && is.vector(cfact) && length(cfact) ==
     1) || is.data.frame(cfact) || (is.matrix(cfact) && !is.character(cfact)))) {
     stop("'cfact' must be either a string, a R data frame, or a R non-character matrix")
     }
     if (is.character(cfact)) {
     cfact <- read.table(cfact)
     }
     if (dim(cfact)[1] == 0) {
     stop("no counterfactuals supplied: 'cfact' contains zero rows")
     }
     if (!any(complete.cases(cfact))) {
     stop("there are no cases in 'cfact' without missing values")
     }
     if ("(Intercept)" %in% dimnames(cfact)[[2]]) {
     cfact <- cfact[, -(which(dimnames(cfact)[[2]] == "(Intercept)"))]
     }
     if (is.list(data) && !(is.data.frame(data))) {
     if (!((("formula" %in% names(data)) || ("terms" %in%
     names(data))) && (("data" %in% names(data)) || ("model" %in%
     names(data))))) {
     stop("the list supplied to 'data' is not a valid output object")
     }
     tt <- terms(data)
     attr(tt, "intercept") <- rep(0, length(attr(tt, "intercept")))
     if ("data" %in% names(data)) {
     if (is.data.frame(data$data)) {
     data <- model.matrix(tt, model.frame(tt, data = data$data,
     na.action = NULL))
     }
     else {
     data <- model.matrix(tt, model.frame(tt, data = eval(data$data,
     envir = .GlobalEnv), na.action = NULL))
     }
     }
     else {
     data <- model.matrix(tt, data = data$model)
     }
     if (!(is.matrix(data))) {
     stop("observed covariate data could not be extracted from output object")
     }
     rm(tt)
     }
     else {
     if (!((is.character(data) && is.vector(data) && length(data) ==
     1) || is.data.frame(data) || (is.matrix(data) &&
     !is.character(data)))) {
     stop("'data' must be either a string, a R data frame, a R non-character matrix, or an output object")
     }
     if (is.character(data)) {
     data <- read.table(data)
     }
     }
     if (dim(data)[1] == 0) {
     stop("no observed covariate data supplied: 'data' contains zero rows")
     }
     if (!any(complete.cases(data))) {
     stop("there are no cases in 'data' without missing values")
     }
     if (!(is.null(formula))) {
     if (identical(class(formula), "formula")) {
     if (!(is.data.frame(as.data.frame(data)))) {
     stop("'data' must be coercable to a data frame in order to use 'formula'")
     }
     if (!(is.data.frame(as.data.frame(cfact)))) {
     stop("'cfact' must be coercable to a data frame in order to use 'formula'")
     }
     formula <- update.formula(formula, ~. - 1)
     ttvar <- all.vars(formula)
     for (i in 1:length(ttvar)) {
     if (!(ttvar[i] %in% dimnames(data)[[2]])) {
     stop("variables in 'formula' either unlabeled or not present in 'data'")
     }
     if (!(ttvar[i] %in% dimnames(cfact)[[2]])) {
     stop("variable(s) in 'formula' either unlabeled or not present in 'cfact'")
     }
     }
     rm(ttvar)
     data <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(data), na.action = NULL))
     cfact <- model.matrix(formula, data = model.frame(formula,
     as.data.frame(cfact), na.action = NULL))
     }
     else {
     stop("'formula' must be of class 'formula'")
     }
     }
     if (!(identical(complete.cases(cfact), rep(TRUE, dim(cfact)[1])))) {
     cfact <- na.omit(cfact)
     message("Note: counterfactuals with missing values eliminated from cfact")
     }
     if (is.data.frame(data)) {
     if (is.character(as.matrix(data))) {
     stop("observed covariate data not coercable to numeric matrix due to character column(s)")
     }
     data <- suppressWarnings(data.matrix(data))
     }
     else {
     data <- data.matrix(as.data.frame(data))
     }
     if (is.data.frame(cfact)) {
     if (is.character(as.matrix(cfact))) {
     stop("counterfactual data not coercable to numeric matrix due to character column(s)")
     }
     cfact <- suppressWarnings(data.matrix(cfact))
     }
     else {
     cfact <- data.matrix(as.data.frame(cfact))
     }
     if (!(is.matrix(data) && is.numeric(data))) {
     stop("observed covariate data not coercable to numeric matrix")
     }
     if (!(is.matrix(cfact) && is.numeric(cfact))) {
     stop("counterfactual data not coercable to numeric matrix")
     }
     na.fail(cfact)
     if (!identical(ncol(cfact), ncol(data))) {
     stop("number of columns of 'cfact' and 'data' are not equal")
     }
     if (!(is.null(range))) {
     if (!(is.vector(range) && is.numeric(range))) {
     stop("'range' must be a numeric vector")
     }
     if (!identical(length(range), ncol(data))) {
     stop("length of 'range' does not equal number of columns of 'data'")
     }
     }
     if (!(is.null(freq))) {
     if (!(is.vector(freq) && is.numeric(freq))) {
     stop("'freq' must be a numeric vector")
     }
     na.fail(freq)
     }
     if (!(is.null(nearby))) {
     if (!(is.numeric(nearby) && is.vector(nearby) && length(nearby) ==
     1 && nearby >= 0)) {
     stop("'nearby' must be numeric, greater than or equal to 0, and a scalar")
     }
     }
     if (!(identical(miss, "list") || identical(miss, "case"))) {
     stop("'miss' must be either ''case'' or ''list''")
     }
     if (!(identical(distance, "gower") || identical(distance,
     "euclidian"))) {
     stop("'distance' must be either ''gower'' or ''euclidian''")
     }
     if (!(identical(choice, "both") || identical(choice, "hull") ||
     identical(choice, "distance"))) {
     stop("'choice' must be either ''both'', ''hull'', or ''distance''")
     }
     if (!(is.logical(return.inputs))) {
     stop("'return.inputs' must be logical, i.e. either TRUE or FALSE")
     }
     if (!(is.logical(return.distance))) {
     stop("'return.distance' must be logical, i.e. either TRUE or FALSE")
     }
     n = nrow(data)
     convex.hull.test <- function(x, z, mc.cores = mc.cores) {
     one_core_pb <- mc.cores == 1
     n <- nrow(x)
     k <- ncol(x)
     m <- nrow(z)
     if (one_core_pb && m == 1)
     one_core_pb <- FALSE
     if (one_core_pb)
     pb <- txtProgressBar(min = 1, max = m, style = 3)
     A <- rbind(t(x), rep(1, n))
     C <- c(rep(0, n))
     D <- c(rep("=", k + 1))
     in_ch <- function(i, one_core_pb = FALSE) {
     B <- c(z[i, ], 1)
     lp.result <- lp(objective.in = C, const.mat = A,
     const.dir = D, const.rhs = B)
     if (one_core_pb)
     setTxtProgressBar(pb, i)
     if (lp.result$status == 0)
     return(TRUE)
     else return(FALSE)
     }
     if (one_core_pb) {
     hull <- sapply(1:m, in_ch, one_core_pb = one_core_pb)
     }
     else {
     if (.Platform$OS.type == "windows")
     hull <- mclapply(1:m, in_ch, mc.cores = mc.cores)
     else hull <- pbmclapply(1:m, in_ch, mc.cores = mc.cores)
     hull <- unlist(hull)
     }
     if (one_core_pb)
     close(pb)
     return(hull)
     }
     calc.gd <- function(dat, cf, range) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat = t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- abs(dat - cf[i, ])/range
     if (any(range == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     dist[i, ] <- colMeans(temp, na.rm = T)
     }
     return(t(dist))
     }
     calc.ed <- function(dat, cf) {
     n <- nrow(dat)
     m <- nrow(cf)
     dat <- t(dat)
     dist = matrix(0, m, n, dimnames = list(1:m, 1:n))
     for (i in 1:m) {
     temp <- (dat - cf[i, ])^2
     dist[i, ] <- (colSums(temp))
     }
     return(t(dist))
     }
     geom.var <- function(dat, rang) {
     n <- nrow(dat)
     dat <- t(dat)
     ff <- function(x) {
     temp <- abs(dat - x)/rang
     if (any(rang == 0)) {
     temp[is.nan(temp)] <- 0
     temp[temp == Inf] <- NA
     }
     tmp <- sum(colMeans(temp, na.rm = TRUE))
     return(tmp)
     }
     sum.gd.x <- sum(apply(dat, 2, ff), na.rm = TRUE)
     gv.x <- (0.5 * sum.gd.x)/(n^2)
     return(gv.x)
     }
     calc.cumfreq <- function(freq, dist) {
     m <- length(freq)
     n <- ncol(dist)
     res <- matrix(0, n, m)
     for (i in 1:m) res[, i] <- (colSums(dist <= freq[i]))/nrow(dist)
     return(res)
     }
     if (identical(miss, "list")) {
     data <- na.omit(data)
     n <- nrow(data)
     }
     if ((choice == "both") | (choice == "hull")) {
     message("Performing convex hull test ...")
     test.result <- convex.hull.test(x = na.omit(data), z = cfact,
     mc.cores = mc.cores)
     }
     if ((choice == "both") | (choice == "distance")) {
     message("Calculating distances ....")
     if (identical(distance, "gower")) {
     samp.range <- apply(data, 2, max, na.rm = TRUE) -
     apply(data, 2, min, na.rm = TRUE)
     if (!is.null(range)) {
     w <- which(!is.na(range))
     samp.range[w] <- range[w]
     }
     if (identical(TRUE, any(samp.range == 0))) {
     message("Note: range of at least one variable equals zero")
     }
     dist <- calc.gd(dat = data, cf = cfact, range = samp.range)
     }
     else {
     dist <- calc.ed(dat = na.omit(data), cf = cfact)
     }
     message("Calculating the geometric variance...")
     if (identical(distance, "gower")) {
     gv.x <- geom.var(dat = data, rang = samp.range)
     }
     else {
     gv.x <- 0.5 * mean(calc.ed(dat = na.omit(data), cf = na.omit(data)))
     }
     if (identical(miss, "case") && identical(distance, "euclidian")) {
     summary <- colSums(dist <= nearby * gv.x) * (1/nrow(na.omit(data)))
     }
     else {
     summary <- colSums(dist <= nearby * gv.x) * (1/n)
     }
     message("Calculating cumulative frequencies ...")
     if (is.null(freq)) {
     if (identical(distance, "gower")) {
     freqdist <- seq(0, 1, by = 0.05)
     }
     else {
     min.ed <- min(dist)
     max.ed <- max(dist)
     freqdist <- round(seq(min.ed, max.ed, by = (max.ed -
     min.ed)/20), 2)
     }
     }
     else {
     freqdist <- freq
     }
     cumfreq <- calc.cumfreq(freq = freqdist, dist = dist)
     dimnames(cumfreq) <- list(seq(1, nrow(cfact), by = 1),
     freqdist)
     }
     message("Finishing up ...")
     if (return.inputs) {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result, geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), dist = t(dist), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), inputs = list(data = data,
     cfact = cfact), in.hull = test.result)
     }
     }
     else {
     if (choice == "both") {
     if (return.distance) {
     out <- list(call = match.call(), in.hull = test.result,
     dist = t(dist), geom.var = gv.x, sum.stat = summary,
     cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), in.hull = test.result,
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "distance") {
     if (return.distance) {
     out <- list(call = match.call(), dist = t(dist),
     geom.var = gv.x, sum.stat = summary, cum.freq = cumfreq)
     }
     else {
     out <- list(call = match.call(), geom.var = gv.x,
     sum.stat = summary, cum.freq = cumfreq)
     }
     }
     if (choice == "hull") {
     out <- list(call = match.call(), in.hull = test.result)
     }
     }
     class(out) <- "whatif"
     return(invisible(out))
     }
     <bytecode: 0x10df6718>
     <environment: namespace:WhatIf>
     --- function search by body ---
     Function whatif in namespace WhatIf has this body.
     ----------- END OF FAILURE REPORT --------------
     ── 1. Failure: REQUIRE TEST whatif with 1 counterfactual (@test-whatif_convexhul
     `whatif(...)` threw an error.
     Message: the condition has length > 1
     Class: simpleError/error/condition
     Backtrace:
     1. testthat::expect_error(...)
     6. WhatIf::whatif(...)

     [1] "3 cores"
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%

     |
     | | 0%
     |
     |======== | 11%
     |
     |================ | 22%
     |
     |======================= | 33%
     |
     |=============================== | 44%
     |
     |======================================= | 56%
     |
     |=============================================== | 67%
     |
     |====================================================== | 78%
     |
     |============================================================== | 89%
     |
     |======================================================================| 100%
     How to cite this model in Zelig:
     R Core Team. 2007.
     ls: Least Squares Regression for Continuous Dependent Variables
     in Christine Choirat, Christopher Gandrud, James Honaker, Kosuke Imai, Gary King, and Olivia Lau,
     "Zelig: Everyone's Statistical Software," http://zeligproject.org/
     ══ testthat results ═══════════════════════════════════════════════════════════
     [ OK: 16 | SKIPPED: 0 | WARNINGS: 0 | FAILED: 1 ]
     1. Failure: REQUIRE TEST whatif with 1 counterfactual (@test-whatif_convexhull.R#5)

     Error: testthat unit tests failed
     Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc