CRAN Package Check Results for Package BreedingSchemeLanguage

Last updated on 2020-02-19 10:48:47 CET.

Flavor Version Tinstall Tcheck Ttotal Status Flags
r-devel-linux-x86_64-debian-clang 0.9.6 42.63 168.52 211.15 WARN
r-devel-linux-x86_64-debian-gcc 0.9.6 23.09 122.46 145.55 WARN
r-devel-linux-x86_64-fedora-clang 0.9.6 258.50 WARN
r-devel-linux-x86_64-fedora-gcc 0.9.6 237.69 WARN
r-devel-windows-ix86+x86_64 0.9.6 71.00 219.00 290.00 NOTE
r-devel-windows-ix86+x86_64-gcc8 0.9.6 114.00 290.00 404.00 NOTE
r-patched-linux-x86_64 0.9.6 29.43 195.74 225.17 OK
r-patched-solaris-x86 0.9.6 344.30 NOTE
r-release-linux-x86_64 0.9.6 27.87 195.85 223.72 OK
r-release-windows-ix86+x86_64 0.9.6 69.00 208.00 277.00 OK
r-release-osx-x86_64 0.9.6 NOTE
r-oldrel-windows-ix86+x86_64 0.9.6 61.00 174.00 235.00 OK
r-oldrel-osx-x86_64 0.9.6 NOTE

Check Details

Version: 0.9.6
Check: package vignettes
Result: NOTE
    Package vignette with placeholder title 'Vignette Title':
     'Optimize_parameter_vector.Rmd'
Flavors: r-devel-linux-x86_64-debian-clang, r-devel-linux-x86_64-debian-gcc, r-devel-windows-ix86+x86_64, r-devel-windows-ix86+x86_64-gcc8

Version: 0.9.6
Check: re-building of vignette outputs
Result: WARN
    Error(s) in re-building vignettes:
     ...
    --- re-building 'Intro_to_BSL.Rmd' using rmarkdown
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue(sharingInfo = "pedigree")
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Intro_to_BSL.Rmd", "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Intro_to_BSL", "UTF-8", "/tmp/RtmpdZlm9p/file5e70645f0644.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x10730ef0>
    <environment: 0x14d82d10>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 85-89 (Intro_to_BSL.Rmd)
    Error: processing vignette 'Intro_to_BSL.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building 'Intro_to_BSL.Rmd'
    
    --- re-building 'Load_existing_data.Rmd' using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Load_existing_data.Rmd", "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Load_existing_data", "UTF-8", "/tmp/RtmpdZlm9p/file5e707ff2f988.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x5f7def8>
    <environment: 0x5f54170>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 65-70 (Load_existing_data.Rmd)
    Error: processing vignette 'Load_existing_data.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building 'Load_existing_data.Rmd'
    
    --- re-building 'Optimize_parameter_vector.Rmd' using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(ei, envir)
    where 10: eval(ei, envir)
    where 11: withVisible(eval(ei, envir))
    where 12: source(schemeFileName, local = TRUE)
    where 13: testParameterOptimality(schemeFileName = schemeScriptPath, parmList = parmList,
     objectiveFunc = objFunc, budget = allowableBudget)
    where 14: eval(expr, envir, enclos)
    where 15: eval(expr, envir, enclos)
    where 16: withVisible(eval(expr, envir, enclos))
    where 17: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 18: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 19: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 20: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 21: evaluate::evaluate(...)
    where 22: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 23: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 24: block_exec(params)
    where 25: call_block(x)
    where 26: process_group.block(group)
    where 27: process_group(group)
    where 28: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 29: process_file(text, output)
    where 30: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 31: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 32: vweave_rmarkdown(...)
    where 33: engine$weave(file, quiet = quiet, encoding = enc)
    where 34: doTryCatch(return(expr), name, parentenv, handler)
    where 35: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 36: tryCatchList(expr, classes, parentenv, handlers)
    where 37: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 38: tools:::.buildOneVignette("Optimize_parameter_vector.Rmd", "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Optimize_parameter_vector", "UTF-8", "/tmp/RtmpdZlm9p/file5e701e182148.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x63bfd20>
    <environment: 0xcd1b528>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 68-106 (Optimize_parameter_vector.Rmd)
    Error: processing vignette 'Optimize_parameter_vector.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building 'Optimize_parameter_vector.Rmd'
    
    --- re-building 'Within_family_selection.Rmd' using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
    --- finished re-building 'Within_family_selection.Rmd'
    
    SUMMARY: processing the following files failed:
     'Intro_to_BSL.Rmd' 'Load_existing_data.Rmd'
     'Optimize_parameter_vector.Rmd'
    
    Error: Vignette re-building failed.
    Execution halted
Flavor: r-devel-linux-x86_64-debian-clang

Version: 0.9.6
Check: re-building of vignette outputs
Result: WARN
    Error(s) in re-building vignettes:
     ...
    --- re-building ‘Intro_to_BSL.Rmd’ using rmarkdown
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue(sharingInfo = "pedigree")
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Intro_to_BSL.Rmd", "/home/hornik/tmp/R.check/r-devel-gcc/Work/PKGS/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Intro_to_BSL", "UTF-8", "/home/hornik/tmp/scratch/RtmpLb7D9f/file21b5a257b32.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x55ba66d4ebf8>
    <environment: 0x55ba6a929eb8>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 85-89 (Intro_to_BSL.Rmd)
    Error: processing vignette 'Intro_to_BSL.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Intro_to_BSL.Rmd’
    
    --- re-building ‘Load_existing_data.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Load_existing_data.Rmd", "/home/hornik/tmp/R.check/r-devel-gcc/Work/PKGS/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Load_existing_data", "UTF-8", "/home/hornik/tmp/scratch/RtmpLb7D9f/file21b57488d210.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x55b9f2910c60>
    <environment: 0x55b9f28e2f20>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 65-70 (Load_existing_data.Rmd)
    Error: processing vignette 'Load_existing_data.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Load_existing_data.Rmd’
    
    --- re-building ‘Optimize_parameter_vector.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(ei, envir)
    where 10: eval(ei, envir)
    where 11: withVisible(eval(ei, envir))
    where 12: source(schemeFileName, local = TRUE)
    where 13: testParameterOptimality(schemeFileName = schemeScriptPath, parmList = parmList,
     objectiveFunc = objFunc, budget = allowableBudget)
    where 14: eval(expr, envir, enclos)
    where 15: eval(expr, envir, enclos)
    where 16: withVisible(eval(expr, envir, enclos))
    where 17: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 18: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 19: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 20: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 21: evaluate::evaluate(...)
    where 22: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 23: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 24: block_exec(params)
    where 25: call_block(x)
    where 26: process_group.block(group)
    where 27: process_group(group)
    where 28: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 29: process_file(text, output)
    where 30: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 31: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 32: vweave_rmarkdown(...)
    where 33: engine$weave(file, quiet = quiet, encoding = enc)
    where 34: doTryCatch(return(expr), name, parentenv, handler)
    where 35: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 36: tryCatchList(expr, classes, parentenv, handlers)
    where 37: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 38: tools:::.buildOneVignette("Optimize_parameter_vector.Rmd", "/home/hornik/tmp/R.check/r-devel-gcc/Work/PKGS/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Optimize_parameter_vector", "UTF-8", "/home/hornik/tmp/scratch/RtmpLb7D9f/file21b579077297.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x5582af0a9e58>
    <environment: 0x5582b0957c08>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 68-106 (Optimize_parameter_vector.Rmd)
    Error: processing vignette 'Optimize_parameter_vector.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Optimize_parameter_vector.Rmd’
    
    --- re-building ‘Within_family_selection.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
    --- finished re-building ‘Within_family_selection.Rmd’
    
    SUMMARY: processing the following files failed:
     ‘Intro_to_BSL.Rmd’ ‘Load_existing_data.Rmd’
     ‘Optimize_parameter_vector.Rmd’
    
    Error: Vignette re-building failed.
    Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc

Version: 0.9.6
Check: dependencies in R code
Result: NOTE
    Namespace in Imports field not imported from: ‘lme4’
     All declared Imports should be used.
Flavors: r-devel-linux-x86_64-fedora-clang, r-devel-linux-x86_64-fedora-gcc, r-patched-solaris-x86, r-release-osx-x86_64, r-oldrel-osx-x86_64

Version: 0.9.6
Check: re-building of vignette outputs
Result: WARN
    Error(s) in re-building vignettes:
    --- re-building ‘Intro_to_BSL.Rmd’ using rmarkdown
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue(sharingInfo = "pedigree")
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Intro_to_BSL.Rmd", "/data/gannet/ripley/R/packages/tests-clang/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Intro_to_BSL", "UTF-8", "/tmp/Rtmpc3wIiu/working_dir/Rtmp5OSybw/file3c4823ac8454.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x14876488>
    <environment: 0x129fcab8>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 85-89 (Intro_to_BSL.Rmd)
    Error: processing vignette 'Intro_to_BSL.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Intro_to_BSL.Rmd’
    
    --- re-building ‘Load_existing_data.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Load_existing_data.Rmd", "/data/gannet/ripley/R/packages/tests-clang/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Load_existing_data", "UTF-8", "/tmp/Rtmpc3wIiu/working_dir/Rtmp5OSybw/file3c485891636d.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x75d4a18>
    <environment: 0x75ab308>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 65-70 (Load_existing_data.Rmd)
    Error: processing vignette 'Load_existing_data.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Load_existing_data.Rmd’
    
    --- re-building ‘Optimize_parameter_vector.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(ei, envir)
    where 10: eval(ei, envir)
    where 11: withVisible(eval(ei, envir))
    where 12: source(schemeFileName, local = TRUE)
    where 13: testParameterOptimality(schemeFileName = schemeScriptPath, parmList = parmList,
     objectiveFunc = objFunc, budget = allowableBudget)
    where 14: eval(expr, envir, enclos)
    where 15: eval(expr, envir, enclos)
    where 16: withVisible(eval(expr, envir, enclos))
    where 17: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 18: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 19: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 20: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 21: evaluate::evaluate(...)
    where 22: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 23: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 24: block_exec(params)
    where 25: call_block(x)
    where 26: process_group.block(group)
    where 27: process_group(group)
    where 28: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 29: process_file(text, output)
    where 30: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 31: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 32: vweave_rmarkdown(...)
    where 33: engine$weave(file, quiet = quiet, encoding = enc)
    where 34: doTryCatch(return(expr), name, parentenv, handler)
    where 35: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 36: tryCatchList(expr, classes, parentenv, handlers)
    where 37: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 38: tools:::.buildOneVignette("Optimize_parameter_vector.Rmd", "/data/gannet/ripley/R/packages/tests-clang/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Optimize_parameter_vector", "UTF-8", "/tmp/Rtmpc3wIiu/working_dir/Rtmp5OSybw/file3c483b463751.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x55733f8>
    <environment: 0xb992460>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 68-106 (Optimize_parameter_vector.Rmd)
    Error: processing vignette 'Optimize_parameter_vector.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Optimize_parameter_vector.Rmd’
    
    --- re-building ‘Within_family_selection.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
    --- finished re-building ‘Within_family_selection.Rmd’
    
    SUMMARY: processing the following files failed:
     ‘Intro_to_BSL.Rmd’ ‘Load_existing_data.Rmd’
     ‘Optimize_parameter_vector.Rmd’
    
    Error: Vignette re-building failed.
    Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang

Version: 0.9.6
Check: re-building of vignette outputs
Result: WARN
    Error(s) in re-building vignettes:
    --- re-building ‘Intro_to_BSL.Rmd’ using rmarkdown
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue(sharingInfo = "pedigree")
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Intro_to_BSL.Rmd", "/data/gannet/ripley/R/packages/tests-devel/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Intro_to_BSL", "UTF-8", "/tmp/RtmpQLz0y2/working_dir/RtmpB4KaJW/file154173d3256a.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x16578d90>
    <environment: 0x161940c0>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 85-89 (Intro_to_BSL.Rmd)
    Error: processing vignette 'Intro_to_BSL.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Intro_to_BSL.Rmd’
    
    --- re-building ‘Load_existing_data.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(expr, envir, enclos)
    where 10: eval(expr, envir, enclos)
    where 11: withVisible(eval(expr, envir, enclos))
    where 12: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 13: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 14: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 15: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 16: evaluate::evaluate(...)
    where 17: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 18: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 19: block_exec(params)
    where 20: call_block(x)
    where 21: process_group.block(group)
    where 22: process_group(group)
    where 23: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 24: process_file(text, output)
    where 25: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 26: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 27: vweave_rmarkdown(...)
    where 28: engine$weave(file, quiet = quiet, encoding = enc)
    where 29: doTryCatch(return(expr), name, parentenv, handler)
    where 30: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 31: tryCatchList(expr, classes, parentenv, handlers)
    where 32: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 33: tools:::.buildOneVignette("Load_existing_data.Rmd", "/data/gannet/ripley/R/packages/tests-devel/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Load_existing_data", "UTF-8", "/tmp/RtmpQLz0y2/working_dir/RtmpB4KaJW/file15417a8bf7c.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x69beda8>
    <environment: 0x696ac28>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 65-70 (Load_existing_data.Rmd)
    Error: processing vignette 'Load_existing_data.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Load_existing_data.Rmd’
    
    --- re-building ‘Optimize_parameter_vector.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
     ----------- FAILURE REPORT --------------
     --- failure: the condition has length > 1 ---
     --- srcref ---
    :
     --- package (from environment) ---
    BreedingSchemeLanguage
     --- call from context ---
    kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
     --- call from argument ---
    if (class(K) == "dist") {
     K <- as.matrix(K)
    }
     --- R stacktrace ---
    where 1: kin.blup4.4(kbDat, geno = "phenoGID", pheno = "pValue", fixed = c("loc",
     "year"), K = K, reduce = mt1ObsPerGID, R = kbDat$error)
    where 2: FUN(X[[i]], ...)
    where 3: lapply(sims, predictValue.func, popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
    where 4: eval(substitute(expr), data, enclos = parent.frame())
    where 5: eval(substitute(expr), data, enclos = parent.frame())
    where 6: with.default(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 7: with(sEnv, {
     if (exists("totalCost")) {
     costs$popID <- ifelse(is.null(popID), max(budgetRec$popID),
     popID)
     totalCost <- totalCost + costs$predCost
     }
     if (!onlyCost) {
     if (nCore > 1) {
     snowfall::sfInit(parallel = T, cpus = nCore)
     sims <- snowfall::sfLapply(sims, predictValue.func,
     popID = popID, trainingPopID = trainingPopID,
     locations = locations, years = years, sharingInfo = sharingInfo)
     snowfall::sfStop()
     }
     else {
     sims <- lapply(sims, predictValue.func, popID = popID,
     trainingPopID = trainingPopID, locations = locations,
     years = years, sharingInfo = sharingInfo)
     }
     }
    })
    where 8: predictValue()
    where 9: eval(ei, envir)
    where 10: eval(ei, envir)
    where 11: withVisible(eval(ei, envir))
    where 12: source(schemeFileName, local = TRUE)
    where 13: testParameterOptimality(schemeFileName = schemeScriptPath, parmList = parmList,
     objectiveFunc = objFunc, budget = allowableBudget)
    where 14: eval(expr, envir, enclos)
    where 15: eval(expr, envir, enclos)
    where 16: withVisible(eval(expr, envir, enclos))
    where 17: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
     error = eHandler, message = mHandler)
    where 18: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
     enclos)), warning = wHandler, error = eHandler, message = mHandler))
    where 19: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
     envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
    where 20: evaluate_call(expr, parsed$src[[i]], envir = envir, enclos = enclos,
     debug = debug, last = i == length(out), use_try = stop_on_error !=
     2L, keep_warning = keep_warning, keep_message = keep_message,
     output_handler = output_handler, include_timing = include_timing)
    where 21: evaluate::evaluate(...)
    where 22: evaluate(code, envir = env, new_device = FALSE, keep_warning = !isFALSE(options$warning),
     keep_message = !isFALSE(options$message), stop_on_error = if (options$error &&
     options$include) 0L else 2L, output_handler = knit_handlers(options$render,
     options))
    where 23: in_dir(input_dir(), evaluate(code, envir = env, new_device = FALSE,
     keep_warning = !isFALSE(options$warning), keep_message = !isFALSE(options$message),
     stop_on_error = if (options$error && options$include) 0L else 2L,
     output_handler = knit_handlers(options$render, options)))
    where 24: block_exec(params)
    where 25: call_block(x)
    where 26: process_group.block(group)
    where 27: process_group(group)
    where 28: withCallingHandlers(if (tangle) process_tangle(group) else process_group(group),
     error = function(e) {
     setwd(wd)
     cat(res, sep = "\n", file = output %n% "")
     message("Quitting from lines ", paste(current_lines(i),
     collapse = "-"), " (", knit_concord$get("infile"),
     ") ")
     })
    where 29: process_file(text, output)
    where 30: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet)
    where 31: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
     output_dir = getwd(), ...)
    where 32: vweave_rmarkdown(...)
    where 33: engine$weave(file, quiet = quiet, encoding = enc)
    where 34: doTryCatch(return(expr), name, parentenv, handler)
    where 35: tryCatchOne(expr, names, parentenv, handlers[[1L]])
    where 36: tryCatchList(expr, classes, parentenv, handlers)
    where 37: tryCatch({
     engine$weave(file, quiet = quiet, encoding = enc)
     setwd(startdir)
     output <- find_vignette_product(name, by = "weave", engine = engine)
     if (!have.makefile && vignette_is_tex(output)) {
     texi2pdf(file = output, clean = FALSE, quiet = quiet)
     output <- find_vignette_product(name, by = "texi2pdf",
     engine = engine)
     }
    }, error = function(e) {
     OK <<- FALSE
     message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
     file, conditionMessage(e)))
    })
    where 38: tools:::.buildOneVignette("Optimize_parameter_vector.Rmd", "/data/gannet/ripley/R/packages/tests-devel/BreedingSchemeLanguage.Rcheck/vign_test/BreedingSchemeLanguage",
     TRUE, FALSE, "Optimize_parameter_vector", "UTF-8", "/tmp/RtmpQLz0y2/working_dir/RtmpB4KaJW/file15414b2433c1.rds")
    
     --- value of length: 2 type: logical ---
    [1] FALSE FALSE
     --- function from context ---
    function (data, geno, pheno, GAUSS = FALSE, K = NULL, fixed = NULL,
     covariate = NULL, PEV = FALSE, n.core = 1, theta.seq = NULL,
     reduce = FALSE, R = NULL)
    {
     make.full <- function(X) {
     svd.X <- svd(X)
     r <- max(which(svd.X$d > 1e-08))
     return(as.matrix(svd.X$u[, 1:r]))
     }
     names <- colnames(data)
     ypos <- match(pheno, names)
     if (is.na(ypos)) {
     stop("Phenotype name does not appear in data.")
     }
     else {
     y <- data[, ypos]
     }
     if (!is.null(R) & (length(R) != length(y))) {
     stop("Length of R does not equal length of y")
     }
     not.miss <- which(!is.na(y))
     if (length(not.miss) < length(y)) {
     data <- data[not.miss, ]
     y <- y[not.miss]
     if (!is.null(R)) {
     R <- R[not.miss]
     }
     }
     n <- length(y)
     X <- matrix(1, n, 1)
     if (!is.null(fixed)) {
     p <- length(fixed)
     for (i in 1:p) {
     xpos <- match(fixed[i], names)
     xx <- factor(data[, xpos])
     if (length(unique(xx)) > 1) {
     X <- cbind(X, stats::model.matrix(~x - 1, data.frame(x = xx)))
     }
     }
     }
     if (!is.null(covariate)) {
     p <- length(covariate)
     for (i in 1:p) {
     xpos <- match(covariate[i], names)
     X <- cbind(X, data[, xpos])
     }
     }
     gid.pos <- match(geno, names)
     if (is.na(gid.pos)) {
     stop("Genotype name does not appear in data.")
     }
     not.miss.gid <- as.character(unique(data[, gid.pos]))
     if (is.null(K)) {
     if (reduce) {
     print("reduce=TRUE is not valid for independent genotypes. Proceeding without reduction.")
     }
     gid <- not.miss.gid
     v <- length(gid)
     Z <- matrix(0, n, v)
     colnames(Z) <- gid
     Z[cbind(1:n, match(data[, gid.pos], gid))] <- 1
     X2 <- make.full(X)
     ans <- rrBLUP::mixed.solve(y = y, X = X2, Z = Z, SE = PEV)
     resid <- y - X2 %*% ans$beta - Z %*% ans$u
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     PEV = ans$u.SE^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u,
     resid = resid))
     }
     }
     else {
     if (class(K) == "dist") {
     K <- as.matrix(K)
     }
     gid <- rownames(K)
     ix.pheno <- match(not.miss.gid, gid)
     miss.pheno.gid <- which(is.na(ix.pheno))
     if (length(miss.pheno.gid) > 0) {
     stop(paste("The following lines have phenotypes but no genotypes:",
     paste(not.miss.gid[miss.pheno.gid], collapse = " ")))
     }
     miss.gid <- setdiff(gid, not.miss.gid)
     ix <- c(ix.pheno, match(miss.gid, gid))
     K <- K[ix, ix]
     v <- length(not.miss.gid)
     Z <- matrix(0, n, v)
     Z[cbind(1:n, match(data[, gid.pos], not.miss.gid))] <- 1
     if (!is.null(R)) {
     sqrt.R <- sqrt(R)
     X2 <- X/sqrt.R
     y2 <- y/sqrt.R
     Z2 <- Z/sqrt.R
     }
     else {
     X2 <- X
     y2 <- y
     Z2 <- Z
     }
     if ((n > v) & (reduce)) {
     w <- sqrt(diag(crossprod(Z2)))
     X2 <- make.full(crossprod(Z2, X2)/w)
     y2 <- crossprod(Z2, y2)/w
     Z2 <- cbind(diag(w), matrix(0, v, nrow(K) - v))
     reduced <- TRUE
     }
     else {
     X2 <- make.full(X2)
     Z2 <- cbind(Z2, matrix(0, n, nrow(K) - v))
     reduced <- FALSE
     }
     rm(X, Z, y)
     if (!GAUSS) {
     ans <- rrBLUP::mixed.solve(y = y2, X = X2, Z = Z2,
     K = K, SE = PEV)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, g = ans$u[ix],
     resid = resid))
     }
     }
     else {
     if (is.null(theta.seq)) {
     theta <- setdiff(seq(0, max(K), length.out = 11),
     0)
     }
     else {
     theta <- theta.seq
     }
     n.profile <- length(theta)
     ms.fun <- function(theta) {
     soln <- list()
     n.t <- length(theta)
     for (i in 1:n.t) {
     soln[[i]] <- rrBLUP::mixed.solve(y = y2, X = X2,
     Z = Z2, K = exp(-(K/theta[i])^2), SE = PEV)
     }
     return(soln)
     }
     if (n.core > 1) {
     it <- split(theta, factor(cut(theta, n.core,
     labels = FALSE)))
     soln <- unlist(snowfall::sfLapply(it, ms.fun,
     mc.cores = n.core), recursive = FALSE)
     }
     else {
     soln <- ms.fun(theta)
     }
     LL <- rep(0, n.profile)
     for (i in 1:n.profile) {
     LL[i] <- soln[[i]]$LL
     }
     ans <- soln[[which.max(LL)]]
     profile <- cbind(theta, LL)
     ix <- match(gid, rownames(ans$u))
     if (reduced) {
     resid <- NULL
     }
     else {
     resid <- y2 - X2 %*% ans$beta - Z2 %*% ans$u
     }
     if (PEV) {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], PEV = ans$u.SE[ix]^2, resid = resid))
     }
     else {
     return(list(Vg = ans$Vu, Ve = ans$Ve, profile = profile,
     g = ans$u[ix], resid = resid))
     }
     }
     }
    }
    <bytecode: 0x518c128>
    <environment: 0x811f738>
     --- function search by body ---
     ----------- END OF FAILURE REPORT --------------
    Quitting from lines 68-106 (Optimize_parameter_vector.Rmd)
    Error: processing vignette 'Optimize_parameter_vector.Rmd' failed with diagnostics:
    the condition has length > 1
    --- failed re-building ‘Optimize_parameter_vector.Rmd’
    
    --- re-building ‘Within_family_selection.Rmd’ using rmarkdown
    Loading required package: snowfall
    Loading required package: snow
    Loading required package: Rcpp
    --- finished re-building ‘Within_family_selection.Rmd’
    
    SUMMARY: processing the following files failed:
     ‘Intro_to_BSL.Rmd’ ‘Load_existing_data.Rmd’
     ‘Optimize_parameter_vector.Rmd’
    
    Error: Vignette re-building failed.
    Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc