R version 3.6.0 (2019-04-26) -- "Planting of a Tree"
Copyright (C) 2019 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

  Natural language support but running in an English locale

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> pkgname <- "fchk"
> source(file.path(R.home("share"), "R", "examples-header.R"))
> options(warn = 1)
> base::assign(".ExTimings", "fchk-Ex.timings", pos = 'CheckExEnv')
> base::cat("name\tuser\tsystem\telapsed\n", file=base::get(".ExTimings", pos = 'CheckExEnv'))
> base::assign(".format_ptime",
+ function(x) {
+   if(!is.na(x[4L])) x[1L] <- x[1L] + x[4L]
+   if(!is.na(x[5L])) x[2L] <- x[2L] + x[5L]
+   options(OutDec = '.')
+   format(x[1L:3L], digits = 7L)
+ },
+ pos = 'CheckExEnv')
> 
> ### * </HEADER>
> library('fchk')
> 
> base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
> base::assign(".old_wd", base::getwd(), pos = 'CheckExEnv')
> cleanEx()
> nameEx("fchk")
> ### * fchk
> 
> flush(stderr()); flush(stdout())
> 
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: fchk
> ### Title: Run tests, where possible, on user objective function
> ### Aliases: fchk
> ### Keywords: check
> 
> ### ** Examples
> 
> # Want to illustrate each case.
> # Ben Bolker idea for a function that is NOT scalar
> 
> benbad<-function(x, y){
+    # y may be provided with different structures
+    f<-(x-y)^2
+ } # very simple, but ...
> 
> print(Sys.getenv("_R_CHECK_LENGTH_1_LOGIC2_", unset="unset"))
[1] "package:_R_CHECK_PACKAGE_NAME_,abort,verbose"
> a=1:3 || 1:3
> cat("a=", a, "\n")
a= TRUE 
> y<-1:10
> x<-c(1)
> cat("test benbad() with y=1:10, x=c(1)\n")
test benbad() with y=1:10, x=c(1)
> tryfc01 <- try(fc01<-fchk(x, benbad, trace=3, y), silent=TRUE)
fchk: ffn =
function (x, y) 
{
    f <- (x - y)^2
}
fchk: xpar:[1] 1
fchk: dots:[[1]]
 [1]  1  2  3  4  5  6  7  8  9 10

about to call ffn(xpar, ...)
ffn:function (x, y) 
{
    f <- (x - y)^2
}
xpar & dots:[1] 1
[[1]]
 [1]  1  2  3  4  5  6  7  8  9 10

test in fchk: [1]  0  1  4  9 16 25 36 49 64 81
Function value at supplied parameters = [1]  0  1  4  9 16 25 36 49 64 81
 num [1:10] 0 1 4 9 16 25 36 49 64 81
NULL
[1] TRUE
Function evaluation returns a vector not a scalar 
 ----------- FAILURE REPORT -------------- 
 --- failure: length > 1 in coercion to logical ---
 --- srcref --- 
: 
 --- package (from environment) --- 
fchk
 --- call from context --- 
fchk(x, benbad, trace = 3, y)
 --- call from argument --- 
is.infinite(fval) || is.na(fval)
 --- R stacktrace ---
where 1: fchk(x, benbad, trace = 3, y)
where 2: doTryCatch(return(expr), name, parentenv, handler)
where 3: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 4: tryCatchList(expr, classes, parentenv, handlers)
where 5: tryCatch(expr, error = function(e) {
    call <- conditionCall(e)
    if (!is.null(call)) {
        if (identical(call[[1L]], quote(doTryCatch))) 
            call <- sys.call(-4L)
        dcall <- deparse(call)[1L]
        prefix <- paste("Error in", dcall, ": ")
        LONG <- 75L
        sm <- strsplit(conditionMessage(e), "\n")[[1L]]
        w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w")
        if (is.na(w)) 
            w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], 
                type = "b")
        if (w > LONG) 
            prefix <- paste0(prefix, "\n  ")
    }
    else prefix <- "Error : "
    msg <- paste0(prefix, conditionMessage(e), "\n")
    .Internal(seterrmessage(msg[1L]))
    if (!silent && isTRUE(getOption("show.error.messages"))) {
        cat(msg, file = outFile)
        .Internal(printDeferredWarnings())
    }
    invisible(structure(msg, class = "try-error", condition = e))
})
where 6: try(fc01 <- fchk(x, benbad, trace = 3, y), silent = TRUE)

 --- value of length: 10 type: logical ---
 [1] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
 --- function from context --- 
function (xpar, ffn, trace = 0, ...) 
{
    maxard10 <- function(one, two) {
        result <- max(abs((one - two)/(abs(one) + abs(two) + 
            10)))
        return(result)
    }
    if (trace > 2) {
        cat("fchk: ffn =\n")
        print(ffn)
        cat("fchk: xpar:")
        print(xpar)
        cat("fchk: dots:")
        print(list(...))
    }
    infeasible <- FALSE
    excode <- 0
    msg <- "fchk OK"
    if (trace > 1) {
        cat("about to call ffn(xpar, ...)\n")
        cat("ffn:")
        print(ffn)
        cat("xpar & dots:")
        print(xpar)
        print(list(...))
    }
    test <- try(fval <- ffn(xpar, ...))
    if (trace > 1) {
        cat("test in fchk:")
        print(test)
    }
    if (inherits(test, "try-error")) {
        fval <- NA
        attr(fval, "inadmissible") <- TRUE
    }
    if (trace > 0) {
        cat("Function value at supplied parameters =")
        print(fval)
        print(str(fval))
        print(is.vector(fval))
    }
    if (!is.null(attr(fval, "inadmissible")) && (attr(fval, "inadmissible"))) {
        infeasible <- TRUE
        excode <- -1
        msg <- "Function evaluation returns INADMISSIBLE"
        if (trace > 0) 
            cat(msg, "\n")
    }
    if (is.vector(fval)) {
        if (length(fval) > 1) {
            excode <- -4
            msg <- "Function evaluation returns a vector not a scalar"
            infeasible <- TRUE
            if (trace > 0) 
                cat(msg, "\n")
        }
    }
    if (is.list(fval)) {
        excode <- -4
        msg <- "Function evaluation returns a list not a scalar"
        infeasible <- TRUE
        if (trace > 0) 
            cat(msg, "\n")
    }
    if (is.matrix(fval)) {
        excode <- -4
        msg <- "Function evaluation returns a matrix list not a scalar"
        infeasible <- TRUE
        if (trace > 0) 
            cat(msg, "\n")
    }
    if (is.array(fval)) {
        excode <- -4
        msg <- "Function evaluation returns an array not a scalar"
        infeasible <- TRUE
        if (trace > 0) 
            cat(msg, "\n")
    }
    if ((length(fval) != 1) && !(is.vector(fval))) {
        excode <- -4
        msg <- "Function returned not length 1, despite not vector, matrix or array"
        infeasible <- TRUE
        if (trace > 0) 
            cat(msg, "\n")
    }
    if (!(is.numeric(fval))) {
        excode <- -1
        msg <- "Function evaluation returned non-numeric value"
        infeasible <- TRUE
        if (trace > 0) 
            cat(msg, "\n")
    }
    if (is.infinite(fval) || is.na(fval)) {
        excode <- -1
        msg <- "Function evaluation returned Inf or NA (non-computable)"
        infeasible <- TRUE
        if (trace > 0) 
            cat(msg, "\n")
    }
    if (trace > 0) 
        cat("Function at given point=", fval, "\n")
    answer <- list(fval = fval, infeasible = infeasible, excode = excode, 
        msg = msg)
}
<bytecode: 0x3be9c78>
<environment: namespace:fchk>
 --- function search by body ---
Function fchk in namespace fchk has this body.
 ----------- END OF FAILURE REPORT -------------- 
Fatal error: length > 1 in coercion to logical