Last updated on 2019-11-26 00:51:54 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 7.1.0 | 19.94 | 346.39 | 366.33 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 7.1.0 | 20.67 | 251.07 | 271.74 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 7.1.0 | 399.15 | NOTE | |||
| r-devel-linux-x86_64-fedora-gcc | 7.1.0 | 393.99 | NOTE | |||
| r-devel-windows-ix86+x86_64 | 7.1.0 | 45.00 | 342.00 | 387.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 7.1.0 | 47.00 | 312.00 | 359.00 | OK | |
| r-patched-linux-x86_64 | 7.1.0 | 19.48 | 330.01 | 349.49 | OK | |
| r-patched-solaris-x86 | 7.1.0 | 506.50 | OK | |||
| r-release-linux-x86_64 | 7.1.0 | 19.36 | 332.51 | 351.87 | OK | |
| r-release-windows-ix86+x86_64 | 7.1.0 | 41.00 | 356.00 | 397.00 | OK | |
| r-release-osx-x86_64 | 7.1.0 | NOTE | ||||
| r-oldrel-windows-ix86+x86_64 | 7.1.0 | 25.00 | 308.00 | 333.00 | OK | |
| r-oldrel-osx-x86_64 | 7.1.0 | NOTE |
Version: 7.1.0
Check: examples
Result: ERROR
Running examples in 'Haplin-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: hapPowerAsymp
> ### Title: Asymptotic power calculations for genetic association analyses
> ### with Haplin
> ### Aliases: hapPowerAsymp
>
> ### ** Examples
>
>
> ## Calculate the asymptotic power for a triad design
> ## when the minor allele increases the fetal risk by twofold.
> ## Assumes a multiplicative dose-response relationship.
> hapPowerAsymp(nall = c(2), n.strata = 1, cases = list(c(mfc=120)),
+ haplo.freq = c(0.1,0.9), RR = c(2,1), RRstar = c(1,1))
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
Haplin
--- call from context ---
f.check.pars0(.mcall, .defaults.hap)
--- call from argument ---
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
--- R stacktrace ---
where 1: f.check.pars0(.mcall, .defaults.hap)
where 2: f.catch0(cur.call, formals())
where 3: haplin0(n.vars = 0, design = "triad", ccvar = NULL, xchrom = FALSE,
sex = NULL, verbose = FALSE, use.missing = TRUE, threshold = 0,
reference = 2L, data.out = "prelim", data = c("1", "2", "1",
"2", "1", "2", "1", "2", "1", "2", "1", "2", "1", "2", "1",
"2", "1", "1", "2", "2", "1", "1", "2", "2", "1", "1", "2",
"2", "1", "1", "2", "2", "1", "1", "1", "1", "2", "2", "2",
"2", "1", "1", "1", "1", "2", "2", "2", "2", "1", "1", "1",
"1", "1", "1", "1", "1", "2", "2", "2", "2", "2", "2", "2",
"2", "1", "1", "2", "2", "1", "1", "2", "2", "1", "1", "2",
"2", "1", "1", "2", "2", "1", "1", "1", "1", "1", "1", "1",
"1", "2", "2", "2", "2", "2", "2", "2", "2"))
where 4: do.call("haplin0", args = .haparg)
where 5: (function (nall, n.strata = 1, cases, controls, haplo.freq, RR,
RRcm, RRcf, RRstar, RR.mat, RRstar.mat, xchrom = F, sim.comb.sex = "double",
BR.girls, response = "mult", ...)
{
.sim.maternal <- FALSE
if (!missing(RR.mat) | !missing(RRstar.mat))
.sim.maternal <- TRUE
.sim.poo <- FALSE
if (!missing(RRcm) | !missing(RRcf))
.sim.poo <- TRUE
if (.sim.poo && !missing(RR))
stop("RR cannot be present at the same time as RRcm and RRcf",
call. = F)
.nhaplo <- prod(nall)
.nloci <- length(nall)
.RR.controls <- rep(1, .nhaplo)
.missing.controls <- FALSE
if (missing(controls))
.missing.controls <- TRUE
if (.missing.controls)
controls <- c(mfc = 0)
if (xchrom & sim.comb.sex %in% c("females", "males"))
BR.girls <- 1
if ((n.strata == 1 && length(cases) > 1) | any(sapply(cases,
length) > 1))
stop("Each element of list cases can only have length 1",
call. = F)
if (!.missing.controls && (n.strata == 1 && length(controls) >
1) | any(sapply(controls, length) > 1))
stop("Each element of list controls can only have length 1",
call. = F)
.arg <- list(nall = nall, n.strata = n.strata, cases = cases,
controls = controls, haplo.freq = haplo.freq, sim.maternal = .sim.maternal,
sim.poo = .sim.poo, xchrom = xchrom, sim.comb.sex = sim.comb.sex,
nhaplo = .nhaplo, nloci = .nloci, n.sim = 10)
if (.sim.poo)
.RR.arg <- list(RRcm = RRcm, RRcf = RRcf, RRstar = RRstar)
else .RR.arg <- list(RR = RR, RRstar = RRstar)
if (.sim.maternal)
.RR.arg <- c(.RR.arg, list(RR.mat = RR.mat, RRstar.mat = RRstar.mat))
if (xchrom)
.RR.arg <- c(.RR.arg, list(BR.girls = BR.girls))
.arg <- c(.arg, .RR.arg)
.strat.arg <- do.call(f.hapArg, args = .arg)
.f.prob.arg <- .strat.arg[, -which(colnames(.strat.arg) %in%
c("cases", "controls", "n.sim")), drop = FALSE]
lapply(1:n.strata, function(x) {
do.call(f.hapTests, args = .strat.arg[x, ])
})
if (xchrom & sim.comb.sex == "males")
message("The males are simulated assuming no contribution from fathers to sons")
.design <- sapply(1:n.strata, function(x) {
if (all(.strat.arg[, "control.mat"][[x]] == 0) | .missing.controls) {
if (all(.strat.arg[, "case.design"][[x]] == "c"))
stop("Only case children are given. No controls are available",
call. = F)
if (all(.strat.arg[, "case.design"][[x]] == "fc") &
xchrom)
stop("No controls are available", call. = F)
.design <- "triad"
}
else if (all(.strat.arg[, "case.design"][[x]] == "c") &
all(.strat.arg[, "control.design"][[x]] == "c"))
.design <- "cc"
else .design <- "cc.triad"
return(.design)
})
if (length(unique(.design)) == 1)
.design <- unique(.design)
else stop("Unable to specify haplin design due to the combination of arguments \"cases\" and \"controls\"",
call. = F)
if (.design == "cc" & xchrom)
stop("Design \"cc\" and xchrom is not yet implemented ",
call. = F)
.n.vars <- 0
.ccvar <- NULL
.sex = NULL
if (xchrom)
.n.vars <- .n.vars + 1
if (.design != "triad")
.n.vars <- .n.vars + 1
if (.design != "triad" & !xchrom)
.ccvar <- .n.vars
else if (.design == "triad" & xchrom)
.sex <- .n.vars
else if (.design != "triad" & xchrom) {
.ccvar <- .n.vars - 1
.sex <- .n.vars
}
if (is.list(haplo.freq))
.haplo.freq <- haplo.freq[[which.max(unlist(lapply(haplo.freq,
max)))]]
else .haplo.freq <- haplo.freq
.ref.cat <- which.max(.haplo.freq)
.lu <- list(...)
if ("reference" %in% names(.lu))
.ref.cat <- .lu$reference
.response <- response
.haparg <- list(n.vars = .n.vars, design = .design, ccvar = .ccvar,
xchrom = xchrom, sex = .sex, verbose = FALSE, use.missing = TRUE,
threshold = 0, reference = .ref.cat, data.out = "prelim")
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) %in%
c("gen.missing.cases", "gen.missing.controls", "nloci",
"nhaplo", "case.des", "control.des", "case.mat",
"control.mat", "case.design", "control.design", "nall",
"sim.poo")), drop = FALSE]
colnames(.f.prob.arg)[which(colnames(.f.prob.arg) == "xchrom")] <- "sim.xchrom"
if (!.sim.poo) {
.f.prob.arg.RRcmcf <- cbind(.f.prob.arg[, "RR"], .f.prob.arg[,
"RR"])
colnames(.f.prob.arg.RRcmcf) <- c("RRcm", "RRcf")
.f.prob.arg <- cbind(.f.prob.arg, .f.prob.arg.RRcmcf)
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) ==
"RR"), drop = FALSE]
}
.var.covar <- list()
for (i in 1:n.strata) {
.tmp.strat.arg <- .strat.arg[i, ]
.RR <- as.data.frame(.tmp.strat.arg[which(grepl("RR",
names(.tmp.strat.arg)))])
.RRstar <- .RR[, which(grepl("star", names(.RR))), drop = F]
if (.response == "mult") {
if (any(apply(.RRstar, 2, sum) != .nhaplo))
stop("Arguments RRstar and/or RRstar.mat do not correspond to a multiplicative dose-response model",
call. = F)
.RR <- .RR[, -which(grepl("star", names(.RR))), drop = F]
}
.names <- names(.RR)
.RR.ref <- .RR[.ref.cat, , drop = F]
.RR <- lapply(1:ncol(.RR), function(x) .RR[, x] <- .RR[,
x]/.RR.ref[, x])
.RR <- lapply(1:length(.RR), function(x) {
if (!grepl("star", .names[x]))
.RR <- .RR[[x]][-.ref.cat]
else if (grepl("star", .names[x]) & .nhaplo <= 2)
.RR <- .RR[[x]][-.ref.cat]
else .RR <- .RR[[x]]
.RR
})
.RR.beta <- as.vector(log(unlist(.RR)))
.haplo.coef <- .tmp.strat.arg$haplo.freq
.haplo.beta <- f.beta.haplo.freq.asymp(haplo.freq = .haplo.coef)
.beta <- c(.haplo.beta, .RR.beta)
.k <- 0
if (.design != "triad") {
.k <- .tmp.strat.arg$controls/.tmp.strat.arg$cases
.beta <- c(0, .beta)
}
if (xchrom)
.beta <- c(-log(1/BR.girls), .beta)
.design.matrix <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = F, mc.int = F)
.info <- attr(.design.matrix, "info")
.X <- as.matrix(.design.matrix)
names(.beta) <- colnames(.X)
.prob <- f.prob.asymp(beta = .beta, design = .design,
X = .X, k = .k)
.design.grid <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = T, mc.int = F)
.grid <- expand.grid(lapply(.design.grid, function(x) {
1:x
}))
.case.design = .tmp.strat.arg$case.design
.control.design = .tmp.strat.arg$control.design
.grid <- f.grid.asymp(pos = nrow(.grid), design = .design,
xchrom = xchrom, n.vars = .n.vars, nall = nall, case.design = .case.design,
control.design = .control.design)
.ncells <- nrow(.grid)
.haparg$data <- .grid
.data <- do.call("haplin0", args = .haparg)
if (.design != "triad") {
.data$cc[.data$cc == "case"] <- 2
.data$cc[.data$cc == "control"] <- 1
mode(.data$cc) <- "numeric"
}
if (xchrom) {
.data$sex[.data$sex == "girl"] <- 2
.data$sex[.data$sex == "boy"] <- 1
mode(.data$sex) <- "numeric"
}
.orig <- sort(unique(.data$orig.lines))
if (!identical(.orig, 1:.ncells))
stop()
.norig <- length(.orig)
.var.covar.strat <- f.var.covar.asymp(X = .X, data = .data,
pred = .prob, ncells = .ncells, norig = .norig, orig = .orig,
info = .info)
if (xchrom | .design != "triad")
.beta <- .beta[-which(names(.beta) %in% c("cc", "sex"))]
.var.covar.strat <- .var.covar.strat[names(.beta), names(.beta)]/(.strat.arg[i,
"cases"]$cases + .strat.arg[i, "controls"]$controls)
if (.sim.poo)
.var.covar.strat <- f.post.poo.diff(list(as.matrix(.beta)),
list(as.matrix(.var.covar.strat)))
else .var.covar.strat <- f.post.diff(list(.beta), list(.var.covar.strat))
.var.covar[[i]] <- .var.covar.strat
}
.coef <- sapply(.var.covar, function(x) x$coeff)
.covar <- sapply(.var.covar, function(x) x$covar)
.asymp <- list(coef = .coef, cov = .covar)
attr(.asymp, "ref.cat") <- .ref.cat
return(.asymp)
})(nall = 2, n.strata = 1, cases = list(c(mfc = 120)), controls = ,
haplo.freq = c(0.1, 0.9), RR = c(2, 1), RRcm = , RRcf = ,
RRstar = c(1, 1), RR.mat = , RRstar.mat = , xchrom = FALSE,
sim.comb.sex = "double", BR.girls = , response = "mult",
alpha = 0.05)
where 6: do.call(hapCovar, args = .asymp.arg)
where 7: hapPowerAsymp(nall = c(2), n.strata = 1, cases = list(c(mfc = 120)),
haplo.freq = c(0.1, 0.9), RR = c(2, 1), RRstar = c(1, 1))
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mcall, defaults)
{
params <- defaults
params[names(mcall)] <- mcall
.info <- list(filename = params[["filename"]], filespecs = params[c("markers",
"n.vars", "sep", "allele.sep", "na.strings", "subset")],
model = params[c("design", "use.missing", "xchrom", "comb.sex",
"maternal", "poo", "test.maternal", "scoretest")],
variables = params[c("ccvar", "covar", "strata", "sex")],
haplos = params[c("reference", "response", "threshold",
"max.haplos", "haplo.file")], control = params[c("resampling",
"max.EM.iter", "data.out", "verbose", "printout")])
class(.info) <- "info"
.xchrom <- .info$model$xchrom
.ccdesign <- .info$model$design %in% c("cc.triad", "cc")
.allowed <- .info
.allowed$model$scoretest <- c("yes", "no", "only")
.allowed$model$design <- c("triad", "cc.triad", "cc")
.allowed$haplos$response <- c("mult", "free")
.allowed$control$data.out <- c("no", "basic", "prelim", "null",
"full")
.allowed$control$resampling <- c("no", "jackknife")
.allowed$model$comb.sex <- c("males", "females", "single",
"double")
for (i in seq(along = .info)[-1]) {
for (j in seq(along = .info[[i]])) {
if (length(.info[[c(i, j)]]) == 1) {
if (!is.element(.info[[c(i, j)]], .allowed[[c(i,
j)]])) {
stop(paste("The argument ", names(.info[[i]])[j],
" has an invalid value. \nIt should be one of: \n",
paste(.allowed[[c(i, j)]], collapse = ", "),
sep = ""), call. = F)
}
}
}
}
if (.info$model$design %in% c("triad", "cc.triad")) {
.info$model$fam <- "mfc"
}
if (.info$model$design == "cc") {
.info$model$fam <- "c"
}
if (!is.name(.info$filename)) {
.filetest.f <- file_test("-f", .info$filename)
if (!.filetest.f)
stop(paste(.info$filename, " is not a file.", sep = ""),
call. = F)
}
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
if (.xchrom && !is.null(.info$model$comb.sex) && .info$model$comb.sex ==
"males") {
if (.info$haplos$response != "mult") {
warning("Can only use response = \"mult\" with comb.sex = \"males\". Has been changed to \"mult\".",
call. = F)
.info$haplos$response <- "mult"
}
if (.info$model$poo) {
stop("parent-of-origin estimation not possible when comb.sex = \"males\".",
call. = F)
}
}
if (.info$model$poo) {
if (.info$model$design == "cc") {
stop("parent-of-origin effects not available when design = \"cc\"",
call. = F)
}
if (.info$haplos$reference == "reciprocal") {
warning("Can only (for the time being) use reference = \"ref.cat\" or \"population\" when poo == TRUE. Has been changed to \"ref.cat\".",
call. = F)
.info$haplos$reference <- "ref.cat"
}
}
if (.ccdesign) {
if (is.null(.info$variables$ccvar)) {
stop("Parameter \"ccvar\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (.info$filespecs$n.vars == 0)
stop("Parameter \"n.vars\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
if (.info$variables$ccvar > .info$filespecs$n.vars)
stop("Parameter \"n.vars\" must be at least as large as parameter \"ccvar\"!",
call. = F)
}
else {
if (!is.null(.info$variables$ccvar))
stop("Parameter \"ccvar\" should only be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (!is.logical(.xchrom)) {
stop("Argument \"xchrom\" must be a logical ( either \"TRUE\" or \"FALSE\" )",
call. = F)
}
if (.xchrom) {
if (.info$filespecs$n.vars == 0) {
stop("Argument \"n.vars\" must be at least 1 to allow for a sex variable when \"xchrom = TRUE\"",
call. = F)
}
if (!is.numeric(.info$variables$sex)) {
stop("Argument \"sex\" should be a numeric value ( the column number of the sex variable ) when \"xchrom = TRUE\"",
call. = F)
}
if (.info$variables$sex > .info$filespecs$n.vars) {
stop("Argument \"sex\" cannot be larger than \"n.vars\"",
call. = F)
}
}
if (F) {
if (!.xchrom & !is.null(.info$model$comb.sex))
warning("Argument \"comb.sex\" is only implemented for models where \"xchrom = TRUE\"",
call. = F)
}
if (identical(.info$model$comb.sex, "males"))
.info$variables$sel.sex <- 1
if (identical(.info$model$comb.sex, "females"))
.info$variables$sel.sex <- 2
if (.info$model$scoretest == "only" & (.info$control$data.out ==
"full")) {
warning("Since data.out = \"full\", scoretest argument is changed from \"only\" to \"no\"",
call. = F)
.info$control$scoretest <- "no"
}
if (!is.numeric(.info$filespecs$markers) & !identical(.info$filespecs$markers,
"ALL"))
stop("\"markers\" argument must be either \"ALL\" ( default ) or an integer value.",
call. = F)
if ((.info$model$design == "cc") & (.info$model$maternal))
stop("Cannot use maternal = TRUE with design = \"cc\"",
call. = F)
if ((.info$haplos$response %in% c("mult")) & is.element(.info$haplos$reference,
c("reciprocal", "population"))) {
warning("response = \"mult\" must be used with reference category ( numeric or \"ref.cat\" ). Has been changed to reference = \"ref.cat\"",
call. = F)
.info$haplos$reference <- "ref.cat"
}
if (.info$model$test.maternal)
.info$model$maternal <- TRUE
return(.info)
}
<bytecode: 0x97be708>
<environment: namespace:Haplin>
--- function search by body ---
Function f.check.pars0 in namespace Haplin has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
Flavor: r-devel-linux-x86_64-debian-clang
Version: 7.1.0
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
...
--- re-building 'A_Haplin_intro_installation.Rmd' using rmarkdown
--- finished re-building 'A_Haplin_intro_installation.Rmd'
--- re-building 'B_Reading_data.Rmd' using rmarkdown
Read 6 items
Read 1494 items
Read 0 items
Read 864 items
Read 1433376 items
Read 0 items
Read 6 items
Read 1494 items
Read 0 items
Read 864 items
Read 1433376 items
Read 0 items
--- finished re-building 'B_Reading_data.Rmd'
--- re-building 'C_Running_Haplin.Rmd' using rmarkdown
Read 6 items
Read 1494 items
Read 0 items
Read 8 items
Read 9112 items
Read 0 items
Read 864 items
Read 1433376 items
Read 0 items
--- finished re-building 'C_Running_Haplin.Rmd'
--- re-building 'D_Running_Haplin_on_cluster.Rmd' using rmarkdown
--- finished re-building 'D_Running_Haplin_on_cluster.Rmd'
--- re-building 'hapRelEff.Rmd' using rmarkdown
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
Haplin
--- call from context ---
f.check.pars0(.mcall, .defaults.hap)
--- call from argument ---
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
--- R stacktrace ---
where 1: f.check.pars0(.mcall, .defaults.hap)
where 2: f.catch0(cur.call, formals())
where 3: haplin0(n.vars = 1, design = "cc", ccvar = 1, xchrom = FALSE,
sex = NULL, verbose = FALSE, use.missing = TRUE, threshold = 0,
reference = 2L, data.out = "prelim", data = c("1", "1", "1",
"1", "2", "2", "2", "2", "1", "2", "1", "2", "1", "2", "1",
"2", "1", "1", "2", "2", "1", "1", "2", "2"))
where 4: do.call("haplin0", args = .haparg)
where 5: (function (nall, n.strata = 1, cases, controls, haplo.freq, RR,
RRcm, RRcf, RRstar, RR.mat, RRstar.mat, xchrom = F, sim.comb.sex = "double",
BR.girls, response = "mult", ...)
{
.sim.maternal <- FALSE
if (!missing(RR.mat) | !missing(RRstar.mat))
.sim.maternal <- TRUE
.sim.poo <- FALSE
if (!missing(RRcm) | !missing(RRcf))
.sim.poo <- TRUE
if (.sim.poo && !missing(RR))
stop("RR cannot be present at the same time as RRcm and RRcf",
call. = F)
.nhaplo <- prod(nall)
.nloci <- length(nall)
.RR.controls <- rep(1, .nhaplo)
.missing.controls <- FALSE
if (missing(controls))
.missing.controls <- TRUE
if (.missing.controls)
controls <- c(mfc = 0)
if (xchrom & sim.comb.sex %in% c("females", "males"))
BR.girls <- 1
if ((n.strata == 1 && length(cases) > 1) | any(sapply(cases,
length) > 1))
stop("Each element of list cases can only have length 1",
call. = F)
if (!.missing.controls && (n.strata == 1 && length(controls) >
1) | any(sapply(controls, length) > 1))
stop("Each element of list controls can only have length 1",
call. = F)
.arg <- list(nall = nall, n.strata = n.strata, cases = cases,
controls = controls, haplo.freq = haplo.freq, sim.maternal = .sim.maternal,
sim.poo = .sim.poo, xchrom = xchrom, sim.comb.sex = sim.comb.sex,
nhaplo = .nhaplo, nloci = .nloci, n.sim = 10)
if (.sim.poo)
.RR.arg <- list(RRcm = RRcm, RRcf = RRcf, RRstar = RRstar)
else .RR.arg <- list(RR = RR, RRstar = RRstar)
if (.sim.maternal)
.RR.arg <- c(.RR.arg, list(RR.mat = RR.mat, RRstar.mat = RRstar.mat))
if (xchrom)
.RR.arg <- c(.RR.arg, list(BR.girls = BR.girls))
.arg <- c(.arg, .RR.arg)
.strat.arg <- do.call(f.hapArg, args = .arg)
.f.prob.arg <- .strat.arg[, -which(colnames(.strat.arg) %in%
c("cases", "controls", "n.sim")), drop = FALSE]
lapply(1:n.strata, function(x) {
do.call(f.hapTests, args = .strat.arg[x, ])
})
if (xchrom & sim.comb.sex == "males")
message("The males are simulated assuming no contribution from fathers to sons")
.design <- sapply(1:n.strata, function(x) {
if (all(.strat.arg[, "control.mat"][[x]] == 0) | .missing.controls) {
if (all(.strat.arg[, "case.design"][[x]] == "c"))
stop("Only case children are given. No controls are available",
call. = F)
if (all(.strat.arg[, "case.design"][[x]] == "fc") &
xchrom)
stop("No controls are available", call. = F)
.design <- "triad"
}
else if (all(.strat.arg[, "case.design"][[x]] == "c") &
all(.strat.arg[, "control.design"][[x]] == "c"))
.design <- "cc"
else .design <- "cc.triad"
return(.design)
})
if (length(unique(.design)) == 1)
.design <- unique(.design)
else stop("Unable to specify haplin design due to the combination of arguments \"cases\" and \"controls\"",
call. = F)
if (.design == "cc" & xchrom)
stop("Design \"cc\" and xchrom is not yet implemented ",
call. = F)
.n.vars <- 0
.ccvar <- NULL
.sex = NULL
if (xchrom)
.n.vars <- .n.vars + 1
if (.design != "triad")
.n.vars <- .n.vars + 1
if (.design != "triad" & !xchrom)
.ccvar <- .n.vars
else if (.design == "triad" & xchrom)
.sex <- .n.vars
else if (.design != "triad" & xchrom) {
.ccvar <- .n.vars - 1
.sex <- .n.vars
}
if (is.list(haplo.freq))
.haplo.freq <- haplo.freq[[which.max(unlist(lapply(haplo.freq,
max)))]]
else .haplo.freq <- haplo.freq
.ref.cat <- which.max(.haplo.freq)
.lu <- list(...)
if ("reference" %in% names(.lu))
.ref.cat <- .lu$reference
.response <- response
.haparg <- list(n.vars = .n.vars, design = .design, ccvar = .ccvar,
xchrom = xchrom, sex = .sex, verbose = FALSE, use.missing = TRUE,
threshold = 0, reference = .ref.cat, data.out = "prelim")
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) %in%
c("gen.missing.cases", "gen.missing.controls", "nloci",
"nhaplo", "case.des", "control.des", "case.mat",
"control.mat", "case.design", "control.design", "nall",
"sim.poo")), drop = FALSE]
colnames(.f.prob.arg)[which(colnames(.f.prob.arg) == "xchrom")] <- "sim.xchrom"
if (!.sim.poo) {
.f.prob.arg.RRcmcf <- cbind(.f.prob.arg[, "RR"], .f.prob.arg[,
"RR"])
colnames(.f.prob.arg.RRcmcf) <- c("RRcm", "RRcf")
.f.prob.arg <- cbind(.f.prob.arg, .f.prob.arg.RRcmcf)
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) ==
"RR"), drop = FALSE]
}
.var.covar <- list()
for (i in 1:n.strata) {
.tmp.strat.arg <- .strat.arg[i, ]
.RR <- as.data.frame(.tmp.strat.arg[which(grepl("RR",
names(.tmp.strat.arg)))])
.RRstar <- .RR[, which(grepl("star", names(.RR))), drop = F]
if (.response == "mult") {
if (any(apply(.RRstar, 2, sum) != .nhaplo))
stop("Arguments RRstar and/or RRstar.mat do not correspond to a multiplicative dose-response model",
call. = F)
.RR <- .RR[, -which(grepl("star", names(.RR))), drop = F]
}
.names <- names(.RR)
.RR.ref <- .RR[.ref.cat, , drop = F]
.RR <- lapply(1:ncol(.RR), function(x) .RR[, x] <- .RR[,
x]/.RR.ref[, x])
.RR <- lapply(1:length(.RR), function(x) {
if (!grepl("star", .names[x]))
.RR <- .RR[[x]][-.ref.cat]
else if (grepl("star", .names[x]) & .nhaplo <= 2)
.RR <- .RR[[x]][-.ref.cat]
else .RR <- .RR[[x]]
.RR
})
.RR.beta <- as.vector(log(unlist(.RR)))
.haplo.coef <- .tmp.strat.arg$haplo.freq
.haplo.beta <- f.beta.haplo.freq.asymp(haplo.freq = .haplo.coef)
.beta <- c(.haplo.beta, .RR.beta)
.k <- 0
if (.design != "triad") {
.k <- .tmp.strat.arg$controls/.tmp.strat.arg$cases
.beta <- c(0, .beta)
}
if (xchrom)
.beta <- c(-log(1/BR.girls), .beta)
.design.matrix <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = F, mc.int = F)
.info <- attr(.design.matrix, "info")
.X <- as.matrix(.design.matrix)
names(.beta) <- colnames(.X)
.prob <- f.prob.asymp(beta = .beta, design = .design,
X = .X, k = .k)
.design.grid <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = T, mc.int = F)
.grid <- expand.grid(lapply(.design.grid, function(x) {
1:x
}))
.case.design = .tmp.strat.arg$case.design
.control.design = .tmp.strat.arg$control.design
.grid <- f.grid.asymp(pos = nrow(.grid), design = .design,
xchrom = xchrom, n.vars = .n.vars, nall = nall, case.design = .case.design,
control.design = .control.design)
.ncells <- nrow(.grid)
.haparg$data <- .grid
.data <- do.call("haplin0", args = .haparg)
if (.design != "triad") {
.data$cc[.data$cc == "case"] <- 2
.data$cc[.data$cc == "control"] <- 1
mode(.data$cc) <- "numeric"
}
if (xchrom) {
.data$sex[.data$sex == "girl"] <- 2
.data$sex[.data$sex == "boy"] <- 1
mode(.data$sex) <- "numeric"
}
.orig <- sort(unique(.data$orig.lines))
if (!identical(.orig, 1:.ncells))
stop()
.norig <- length(.orig)
.var.covar.strat <- f.var.covar.asymp(X = .X, data = .data,
pred = .prob, ncells = .ncells, norig = .norig, orig = .orig,
info = .info)
if (xchrom | .design != "triad")
.beta <- .beta[-which(names(.beta) %in% c("cc", "sex"))]
.var.covar.strat <- .var.covar.strat[names(.beta), names(.beta)]/(.strat.arg[i,
"cases"]$cases + .strat.arg[i, "controls"]$controls)
if (.sim.poo)
.var.covar.strat <- f.post.poo.diff(list(as.matrix(.beta)),
list(as.matrix(.var.covar.strat)))
else .var.covar.strat <- f.post.diff(list(.beta), list(.var.covar.strat))
.var.covar[[i]] <- .var.covar.strat
}
.coef <- sapply(.var.covar, function(x) x$coeff)
.covar <- sapply(.var.covar, function(x) x$covar)
.asymp <- list(coef = .coef, cov = .covar)
attr(.asymp, "ref.cat") <- .ref.cat
return(.asymp)
})(n.strata = 1, nall = 2, cases = list(c(c = 1)), controls = list(
c(c = 1)), haplo.freq = c(0.1, 0.9), RR = c(1, 1), RRcm = ,
RRcf = , RRstar = c(1, 1), RR.mat = , RRstar.mat = , xchrom = FALSE,
sim.comb.sex = "double", BR.girls = , response = "mult")
where 6: do.call(hapCovar, args = .asymp.arg1)
where 7: hapRelEff(cases.comp = c(c = 1), controls.comp = c(c = 1), cases.ref = c(mfc = 1),
haplo.freq = c(0.1, 0.9), RR = c(1, 1))
where 8: eval(expr, envir, enclos)
where 9: eval(expr, envir, enclos)
where 10: withVisible(eval(expr, envir, enclos))
where 11: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 12: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 13: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 14: 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 15: evaluate::evaluate(...)
where 16: 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 17: 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 18: block_exec(params)
where 19: call_block(x)
where 20: process_group.block(group)
where 21: process_group(group)
where 22: 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 23: process_file(text, output)
where 24: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet,
encoding = encoding)
where 25: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
...)
where 26: vweave_rmarkdown(...)
where 27: engine$weave(file, quiet = quiet, encoding = enc)
where 28: doTryCatch(return(expr), name, parentenv, handler)
where 29: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 30: tryCatchList(expr, classes, parentenv, handlers)
where 31: 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 32: tools:::.buildOneVignette("hapRelEff.Rmd", "/home/hornik/tmp/R.check/r-devel-clang/Work/PKGS/Haplin.Rcheck/vign_test/Haplin",
TRUE, FALSE, "hapRelEff", "UTF-8", "/tmp/Rtmp9UucIQ/file2d4b1014f451.rds")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mcall, defaults)
{
params <- defaults
params[names(mcall)] <- mcall
.info <- list(filename = params[["filename"]], filespecs = params[c("markers",
"n.vars", "sep", "allele.sep", "na.strings", "subset")],
model = params[c("design", "use.missing", "xchrom", "comb.sex",
"maternal", "poo", "test.maternal", "scoretest")],
variables = params[c("ccvar", "covar", "strata", "sex")],
haplos = params[c("reference", "response", "threshold",
"max.haplos", "haplo.file")], control = params[c("resampling",
"max.EM.iter", "data.out", "verbose", "printout")])
class(.info) <- "info"
.xchrom <- .info$model$xchrom
.ccdesign <- .info$model$design %in% c("cc.triad", "cc")
.allowed <- .info
.allowed$model$scoretest <- c("yes", "no", "only")
.allowed$model$design <- c("triad", "cc.triad", "cc")
.allowed$haplos$response <- c("mult", "free")
.allowed$control$data.out <- c("no", "basic", "prelim", "null",
"full")
.allowed$control$resampling <- c("no", "jackknife")
.allowed$model$comb.sex <- c("males", "females", "single",
"double")
for (i in seq(along = .info)[-1]) {
for (j in seq(along = .info[[i]])) {
if (length(.info[[c(i, j)]]) == 1) {
if (!is.element(.info[[c(i, j)]], .allowed[[c(i,
j)]])) {
stop(paste("The argument ", names(.info[[i]])[j],
" has an invalid value. \nIt should be one of: \n",
paste(.allowed[[c(i, j)]], collapse = ", "),
sep = ""), call. = F)
}
}
}
}
if (.info$model$design %in% c("triad", "cc.triad")) {
.info$model$fam <- "mfc"
}
if (.info$model$design == "cc") {
.info$model$fam <- "c"
}
if (!is.name(.info$filename)) {
.filetest.f <- file_test("-f", .info$filename)
if (!.filetest.f)
stop(paste(.info$filename, " is not a file.", sep = ""),
call. = F)
}
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
if (.xchrom && !is.null(.info$model$comb.sex) && .info$model$comb.sex ==
"males") {
if (.info$haplos$response != "mult") {
warning("Can only use response = \"mult\" with comb.sex = \"males\". Has been changed to \"mult\".",
call. = F)
.info$haplos$response <- "mult"
}
if (.info$model$poo) {
stop("parent-of-origin estimation not possible when comb.sex = \"males\".",
call. = F)
}
}
if (.info$model$poo) {
if (.info$model$design == "cc") {
stop("parent-of-origin effects not available when design = \"cc\"",
call. = F)
}
if (.info$haplos$reference == "reciprocal") {
warning("Can only (for the time being) use reference = \"ref.cat\" or \"population\" when poo == TRUE. Has been changed to \"ref.cat\".",
call. = F)
.info$haplos$reference <- "ref.cat"
}
}
if (.ccdesign) {
if (is.null(.info$variables$ccvar)) {
stop("Parameter \"ccvar\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (.info$filespecs$n.vars == 0)
stop("Parameter \"n.vars\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
if (.info$variables$ccvar > .info$filespecs$n.vars)
stop("Parameter \"n.vars\" must be at least as large as parameter \"ccvar\"!",
call. = F)
}
else {
if (!is.null(.info$variables$ccvar))
stop("Parameter \"ccvar\" should only be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (!is.logical(.xchrom)) {
stop("Argument \"xchrom\" must be a logical ( either \"TRUE\" or \"FALSE\" )",
call. = F)
}
if (.xchrom) {
if (.info$filespecs$n.vars == 0) {
stop("Argument \"n.vars\" must be at least 1 to allow for a sex variable when \"xchrom = TRUE\"",
call. = F)
}
if (!is.numeric(.info$variables$sex)) {
stop("Argument \"sex\" should be a numeric value ( the column number of the sex variable ) when \"xchrom = TRUE\"",
call. = F)
}
if (.info$variables$sex > .info$filespecs$n.vars) {
stop("Argument \"sex\" cannot be larger than \"n.vars\"",
call. = F)
}
}
if (F) {
if (!.xchrom & !is.null(.info$model$comb.sex))
warning("Argument \"comb.sex\" is only implemented for models where \"xchrom = TRUE\"",
call. = F)
}
if (identical(.info$model$comb.sex, "males"))
.info$variables$sel.sex <- 1
if (identical(.info$model$comb.sex, "females"))
.info$variables$sel.sex <- 2
if (.info$model$scoretest == "only" & (.info$control$data.out ==
"full")) {
warning("Since data.out = \"full\", scoretest argument is changed from \"only\" to \"no\"",
call. = F)
.info$control$scoretest <- "no"
}
if (!is.numeric(.info$filespecs$markers) & !identical(.info$filespecs$markers,
"ALL"))
stop("\"markers\" argument must be either \"ALL\" ( default ) or an integer value.",
call. = F)
if ((.info$model$design == "cc") & (.info$model$maternal))
stop("Cannot use maternal = TRUE with design = \"cc\"",
call. = F)
if ((.info$haplos$response %in% c("mult")) & is.element(.info$haplos$reference,
c("reciprocal", "population"))) {
warning("response = \"mult\" must be used with reference category ( numeric or \"ref.cat\" ). Has been changed to reference = \"ref.cat\"",
call. = F)
.info$haplos$reference <- "ref.cat"
}
if (.info$model$test.maternal)
.info$model$maternal <- TRUE
return(.info)
}
<bytecode: 0xb5bdda8>
<environment: namespace:Haplin>
--- function search by body ---
Function f.check.pars0 in namespace Haplin has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
SUMMARY: processing the following file failed:
'hapRelEff.Rmd'
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 7.1.0
Check: for non-standard things in the check directory
Result: NOTE
Found the following files/directories:
'exmpl_data_preproc_gen.RData' 'exmpl_data_preproc_gen.ffData'
'exmpl_haplin_data_gen.RData' 'exmpl_haplin_data_gen.ffData'
'exmpl_ped_data_gen.RData' 'exmpl_ped_data_gen.ffData'
'exmpl_ped_data_part_gen.RData' 'exmpl_ped_data_part_gen.ffData'
'gen_data_men_only_gen.RData' 'gen_data_men_only_gen.ffData'
'my_data_part_gen.RData' 'my_data_part_gen.ffData'
'trial_data_gen.RData' 'trial_data_gen.ffData'
Flavors: r-devel-linux-x86_64-debian-clang, r-devel-linux-x86_64-debian-gcc
Version: 7.1.0
Check: examples
Result: ERROR
Running examples in ‘Haplin-Ex.R’ failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: hapPowerAsymp
> ### Title: Asymptotic power calculations for genetic association analyses
> ### with Haplin
> ### Aliases: hapPowerAsymp
>
> ### ** Examples
>
>
> ## Calculate the asymptotic power for a triad design
> ## when the minor allele increases the fetal risk by twofold.
> ## Assumes a multiplicative dose-response relationship.
> hapPowerAsymp(nall = c(2), n.strata = 1, cases = list(c(mfc=120)),
+ haplo.freq = c(0.1,0.9), RR = c(2,1), RRstar = c(1,1))
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
Haplin
--- call from context ---
f.check.pars0(.mcall, .defaults.hap)
--- call from argument ---
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
--- R stacktrace ---
where 1: f.check.pars0(.mcall, .defaults.hap)
where 2: f.catch0(cur.call, formals())
where 3: haplin0(n.vars = 0, design = "triad", ccvar = NULL, xchrom = FALSE,
sex = NULL, verbose = FALSE, use.missing = TRUE, threshold = 0,
reference = 2L, data.out = "prelim", data = c("1", "2", "1",
"2", "1", "2", "1", "2", "1", "2", "1", "2", "1", "2", "1",
"2", "1", "1", "2", "2", "1", "1", "2", "2", "1", "1", "2",
"2", "1", "1", "2", "2", "1", "1", "1", "1", "2", "2", "2",
"2", "1", "1", "1", "1", "2", "2", "2", "2", "1", "1", "1",
"1", "1", "1", "1", "1", "2", "2", "2", "2", "2", "2", "2",
"2", "1", "1", "2", "2", "1", "1", "2", "2", "1", "1", "2",
"2", "1", "1", "2", "2", "1", "1", "1", "1", "1", "1", "1",
"1", "2", "2", "2", "2", "2", "2", "2", "2"))
where 4: do.call("haplin0", args = .haparg)
where 5: (function (nall, n.strata = 1, cases, controls, haplo.freq, RR,
RRcm, RRcf, RRstar, RR.mat, RRstar.mat, xchrom = F, sim.comb.sex = "double",
BR.girls, response = "mult", ...)
{
.sim.maternal <- FALSE
if (!missing(RR.mat) | !missing(RRstar.mat))
.sim.maternal <- TRUE
.sim.poo <- FALSE
if (!missing(RRcm) | !missing(RRcf))
.sim.poo <- TRUE
if (.sim.poo && !missing(RR))
stop("RR cannot be present at the same time as RRcm and RRcf",
call. = F)
.nhaplo <- prod(nall)
.nloci <- length(nall)
.RR.controls <- rep(1, .nhaplo)
.missing.controls <- FALSE
if (missing(controls))
.missing.controls <- TRUE
if (.missing.controls)
controls <- c(mfc = 0)
if (xchrom & sim.comb.sex %in% c("females", "males"))
BR.girls <- 1
if ((n.strata == 1 && length(cases) > 1) | any(sapply(cases,
length) > 1))
stop("Each element of list cases can only have length 1",
call. = F)
if (!.missing.controls && (n.strata == 1 && length(controls) >
1) | any(sapply(controls, length) > 1))
stop("Each element of list controls can only have length 1",
call. = F)
.arg <- list(nall = nall, n.strata = n.strata, cases = cases,
controls = controls, haplo.freq = haplo.freq, sim.maternal = .sim.maternal,
sim.poo = .sim.poo, xchrom = xchrom, sim.comb.sex = sim.comb.sex,
nhaplo = .nhaplo, nloci = .nloci, n.sim = 10)
if (.sim.poo)
.RR.arg <- list(RRcm = RRcm, RRcf = RRcf, RRstar = RRstar)
else .RR.arg <- list(RR = RR, RRstar = RRstar)
if (.sim.maternal)
.RR.arg <- c(.RR.arg, list(RR.mat = RR.mat, RRstar.mat = RRstar.mat))
if (xchrom)
.RR.arg <- c(.RR.arg, list(BR.girls = BR.girls))
.arg <- c(.arg, .RR.arg)
.strat.arg <- do.call(f.hapArg, args = .arg)
.f.prob.arg <- .strat.arg[, -which(colnames(.strat.arg) %in%
c("cases", "controls", "n.sim")), drop = FALSE]
lapply(1:n.strata, function(x) {
do.call(f.hapTests, args = .strat.arg[x, ])
})
if (xchrom & sim.comb.sex == "males")
message("The males are simulated assuming no contribution from fathers to sons")
.design <- sapply(1:n.strata, function(x) {
if (all(.strat.arg[, "control.mat"][[x]] == 0) | .missing.controls) {
if (all(.strat.arg[, "case.design"][[x]] == "c"))
stop("Only case children are given. No controls are available",
call. = F)
if (all(.strat.arg[, "case.design"][[x]] == "fc") &
xchrom)
stop("No controls are available", call. = F)
.design <- "triad"
}
else if (all(.strat.arg[, "case.design"][[x]] == "c") &
all(.strat.arg[, "control.design"][[x]] == "c"))
.design <- "cc"
else .design <- "cc.triad"
return(.design)
})
if (length(unique(.design)) == 1)
.design <- unique(.design)
else stop("Unable to specify haplin design due to the combination of arguments \"cases\" and \"controls\"",
call. = F)
if (.design == "cc" & xchrom)
stop("Design \"cc\" and xchrom is not yet implemented ",
call. = F)
.n.vars <- 0
.ccvar <- NULL
.sex = NULL
if (xchrom)
.n.vars <- .n.vars + 1
if (.design != "triad")
.n.vars <- .n.vars + 1
if (.design != "triad" & !xchrom)
.ccvar <- .n.vars
else if (.design == "triad" & xchrom)
.sex <- .n.vars
else if (.design != "triad" & xchrom) {
.ccvar <- .n.vars - 1
.sex <- .n.vars
}
if (is.list(haplo.freq))
.haplo.freq <- haplo.freq[[which.max(unlist(lapply(haplo.freq,
max)))]]
else .haplo.freq <- haplo.freq
.ref.cat <- which.max(.haplo.freq)
.lu <- list(...)
if ("reference" %in% names(.lu))
.ref.cat <- .lu$reference
.response <- response
.haparg <- list(n.vars = .n.vars, design = .design, ccvar = .ccvar,
xchrom = xchrom, sex = .sex, verbose = FALSE, use.missing = TRUE,
threshold = 0, reference = .ref.cat, data.out = "prelim")
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) %in%
c("gen.missing.cases", "gen.missing.controls", "nloci",
"nhaplo", "case.des", "control.des", "case.mat",
"control.mat", "case.design", "control.design", "nall",
"sim.poo")), drop = FALSE]
colnames(.f.prob.arg)[which(colnames(.f.prob.arg) == "xchrom")] <- "sim.xchrom"
if (!.sim.poo) {
.f.prob.arg.RRcmcf <- cbind(.f.prob.arg[, "RR"], .f.prob.arg[,
"RR"])
colnames(.f.prob.arg.RRcmcf) <- c("RRcm", "RRcf")
.f.prob.arg <- cbind(.f.prob.arg, .f.prob.arg.RRcmcf)
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) ==
"RR"), drop = FALSE]
}
.var.covar <- list()
for (i in 1:n.strata) {
.tmp.strat.arg <- .strat.arg[i, ]
.RR <- as.data.frame(.tmp.strat.arg[which(grepl("RR",
names(.tmp.strat.arg)))])
.RRstar <- .RR[, which(grepl("star", names(.RR))), drop = F]
if (.response == "mult") {
if (any(apply(.RRstar, 2, sum) != .nhaplo))
stop("Arguments RRstar and/or RRstar.mat do not correspond to a multiplicative dose-response model",
call. = F)
.RR <- .RR[, -which(grepl("star", names(.RR))), drop = F]
}
.names <- names(.RR)
.RR.ref <- .RR[.ref.cat, , drop = F]
.RR <- lapply(1:ncol(.RR), function(x) .RR[, x] <- .RR[,
x]/.RR.ref[, x])
.RR <- lapply(1:length(.RR), function(x) {
if (!grepl("star", .names[x]))
.RR <- .RR[[x]][-.ref.cat]
else if (grepl("star", .names[x]) & .nhaplo <= 2)
.RR <- .RR[[x]][-.ref.cat]
else .RR <- .RR[[x]]
.RR
})
.RR.beta <- as.vector(log(unlist(.RR)))
.haplo.coef <- .tmp.strat.arg$haplo.freq
.haplo.beta <- f.beta.haplo.freq.asymp(haplo.freq = .haplo.coef)
.beta <- c(.haplo.beta, .RR.beta)
.k <- 0
if (.design != "triad") {
.k <- .tmp.strat.arg$controls/.tmp.strat.arg$cases
.beta <- c(0, .beta)
}
if (xchrom)
.beta <- c(-log(1/BR.girls), .beta)
.design.matrix <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = F, mc.int = F)
.info <- attr(.design.matrix, "info")
.X <- as.matrix(.design.matrix)
names(.beta) <- colnames(.X)
.prob <- f.prob.asymp(beta = .beta, design = .design,
X = .X, k = .k)
.design.grid <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = T, mc.int = F)
.grid <- expand.grid(lapply(.design.grid, function(x) {
1:x
}))
.case.design = .tmp.strat.arg$case.design
.control.design = .tmp.strat.arg$control.design
.grid <- f.grid.asymp(pos = nrow(.grid), design = .design,
xchrom = xchrom, n.vars = .n.vars, nall = nall, case.design = .case.design,
control.design = .control.design)
.ncells <- nrow(.grid)
.haparg$data <- .grid
.data <- do.call("haplin0", args = .haparg)
if (.design != "triad") {
.data$cc[.data$cc == "case"] <- 2
.data$cc[.data$cc == "control"] <- 1
mode(.data$cc) <- "numeric"
}
if (xchrom) {
.data$sex[.data$sex == "girl"] <- 2
.data$sex[.data$sex == "boy"] <- 1
mode(.data$sex) <- "numeric"
}
.orig <- sort(unique(.data$orig.lines))
if (!identical(.orig, 1:.ncells))
stop()
.norig <- length(.orig)
.var.covar.strat <- f.var.covar.asymp(X = .X, data = .data,
pred = .prob, ncells = .ncells, norig = .norig, orig = .orig,
info = .info)
if (xchrom | .design != "triad")
.beta <- .beta[-which(names(.beta) %in% c("cc", "sex"))]
.var.covar.strat <- .var.covar.strat[names(.beta), names(.beta)]/(.strat.arg[i,
"cases"]$cases + .strat.arg[i, "controls"]$controls)
if (.sim.poo)
.var.covar.strat <- f.post.poo.diff(list(as.matrix(.beta)),
list(as.matrix(.var.covar.strat)))
else .var.covar.strat <- f.post.diff(list(.beta), list(.var.covar.strat))
.var.covar[[i]] <- .var.covar.strat
}
.coef <- sapply(.var.covar, function(x) x$coeff)
.covar <- sapply(.var.covar, function(x) x$covar)
.asymp <- list(coef = .coef, cov = .covar)
attr(.asymp, "ref.cat") <- .ref.cat
return(.asymp)
})(nall = 2, n.strata = 1, cases = list(c(mfc = 120)), controls = ,
haplo.freq = c(0.1, 0.9), RR = c(2, 1), RRcm = , RRcf = ,
RRstar = c(1, 1), RR.mat = , RRstar.mat = , xchrom = FALSE,
sim.comb.sex = "double", BR.girls = , response = "mult",
alpha = 0.05)
where 6: do.call(hapCovar, args = .asymp.arg)
where 7: hapPowerAsymp(nall = c(2), n.strata = 1, cases = list(c(mfc = 120)),
haplo.freq = c(0.1, 0.9), RR = c(2, 1), RRstar = c(1, 1))
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mcall, defaults)
{
params <- defaults
params[names(mcall)] <- mcall
.info <- list(filename = params[["filename"]], filespecs = params[c("markers",
"n.vars", "sep", "allele.sep", "na.strings", "subset")],
model = params[c("design", "use.missing", "xchrom", "comb.sex",
"maternal", "poo", "test.maternal", "scoretest")],
variables = params[c("ccvar", "covar", "strata", "sex")],
haplos = params[c("reference", "response", "threshold",
"max.haplos", "haplo.file")], control = params[c("resampling",
"max.EM.iter", "data.out", "verbose", "printout")])
class(.info) <- "info"
.xchrom <- .info$model$xchrom
.ccdesign <- .info$model$design %in% c("cc.triad", "cc")
.allowed <- .info
.allowed$model$scoretest <- c("yes", "no", "only")
.allowed$model$design <- c("triad", "cc.triad", "cc")
.allowed$haplos$response <- c("mult", "free")
.allowed$control$data.out <- c("no", "basic", "prelim", "null",
"full")
.allowed$control$resampling <- c("no", "jackknife")
.allowed$model$comb.sex <- c("males", "females", "single",
"double")
for (i in seq(along = .info)[-1]) {
for (j in seq(along = .info[[i]])) {
if (length(.info[[c(i, j)]]) == 1) {
if (!is.element(.info[[c(i, j)]], .allowed[[c(i,
j)]])) {
stop(paste("The argument ", names(.info[[i]])[j],
" has an invalid value. \nIt should be one of: \n",
paste(.allowed[[c(i, j)]], collapse = ", "),
sep = ""), call. = F)
}
}
}
}
if (.info$model$design %in% c("triad", "cc.triad")) {
.info$model$fam <- "mfc"
}
if (.info$model$design == "cc") {
.info$model$fam <- "c"
}
if (!is.name(.info$filename)) {
.filetest.f <- file_test("-f", .info$filename)
if (!.filetest.f)
stop(paste(.info$filename, " is not a file.", sep = ""),
call. = F)
}
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
if (.xchrom && !is.null(.info$model$comb.sex) && .info$model$comb.sex ==
"males") {
if (.info$haplos$response != "mult") {
warning("Can only use response = \"mult\" with comb.sex = \"males\". Has been changed to \"mult\".",
call. = F)
.info$haplos$response <- "mult"
}
if (.info$model$poo) {
stop("parent-of-origin estimation not possible when comb.sex = \"males\".",
call. = F)
}
}
if (.info$model$poo) {
if (.info$model$design == "cc") {
stop("parent-of-origin effects not available when design = \"cc\"",
call. = F)
}
if (.info$haplos$reference == "reciprocal") {
warning("Can only (for the time being) use reference = \"ref.cat\" or \"population\" when poo == TRUE. Has been changed to \"ref.cat\".",
call. = F)
.info$haplos$reference <- "ref.cat"
}
}
if (.ccdesign) {
if (is.null(.info$variables$ccvar)) {
stop("Parameter \"ccvar\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (.info$filespecs$n.vars == 0)
stop("Parameter \"n.vars\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
if (.info$variables$ccvar > .info$filespecs$n.vars)
stop("Parameter \"n.vars\" must be at least as large as parameter \"ccvar\"!",
call. = F)
}
else {
if (!is.null(.info$variables$ccvar))
stop("Parameter \"ccvar\" should only be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (!is.logical(.xchrom)) {
stop("Argument \"xchrom\" must be a logical ( either \"TRUE\" or \"FALSE\" )",
call. = F)
}
if (.xchrom) {
if (.info$filespecs$n.vars == 0) {
stop("Argument \"n.vars\" must be at least 1 to allow for a sex variable when \"xchrom = TRUE\"",
call. = F)
}
if (!is.numeric(.info$variables$sex)) {
stop("Argument \"sex\" should be a numeric value ( the column number of the sex variable ) when \"xchrom = TRUE\"",
call. = F)
}
if (.info$variables$sex > .info$filespecs$n.vars) {
stop("Argument \"sex\" cannot be larger than \"n.vars\"",
call. = F)
}
}
if (F) {
if (!.xchrom & !is.null(.info$model$comb.sex))
warning("Argument \"comb.sex\" is only implemented for models where \"xchrom = TRUE\"",
call. = F)
}
if (identical(.info$model$comb.sex, "males"))
.info$variables$sel.sex <- 1
if (identical(.info$model$comb.sex, "females"))
.info$variables$sel.sex <- 2
if (.info$model$scoretest == "only" & (.info$control$data.out ==
"full")) {
warning("Since data.out = \"full\", scoretest argument is changed from \"only\" to \"no\"",
call. = F)
.info$control$scoretest <- "no"
}
if (!is.numeric(.info$filespecs$markers) & !identical(.info$filespecs$markers,
"ALL"))
stop("\"markers\" argument must be either \"ALL\" ( default ) or an integer value.",
call. = F)
if ((.info$model$design == "cc") & (.info$model$maternal))
stop("Cannot use maternal = TRUE with design = \"cc\"",
call. = F)
if ((.info$haplos$response %in% c("mult")) & is.element(.info$haplos$reference,
c("reciprocal", "population"))) {
warning("response = \"mult\" must be used with reference category ( numeric or \"ref.cat\" ). Has been changed to reference = \"ref.cat\"",
call. = F)
.info$haplos$reference <- "ref.cat"
}
if (.info$model$test.maternal)
.info$model$maternal <- TRUE
return(.info)
}
<bytecode: 0x562398c38098>
<environment: namespace:Haplin>
--- function search by body ---
Function f.check.pars0 in namespace Haplin has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 7.1.0
Check: re-building of vignette outputs
Result: WARN
Error(s) in re-building vignettes:
...
--- re-building ‘A_Haplin_intro_installation.Rmd’ using rmarkdown
--- finished re-building ‘A_Haplin_intro_installation.Rmd’
--- re-building ‘B_Reading_data.Rmd’ using rmarkdown
Read 6 items
Read 1494 items
Read 0 items
Read 864 items
Read 1433376 items
Read 0 items
Read 6 items
Read 1494 items
Read 0 items
Read 864 items
Read 1433376 items
Read 0 items
--- finished re-building ‘B_Reading_data.Rmd’
--- re-building ‘C_Running_Haplin.Rmd’ using rmarkdown
Read 6 items
Read 1494 items
Read 0 items
Read 8 items
Read 9112 items
Read 0 items
Read 864 items
Read 1433376 items
Read 0 items
--- finished re-building ‘C_Running_Haplin.Rmd’
--- re-building ‘D_Running_Haplin_on_cluster.Rmd’ using rmarkdown
--- finished re-building ‘D_Running_Haplin_on_cluster.Rmd’
--- re-building ‘hapRelEff.Rmd’ using rmarkdown
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
Haplin
--- call from context ---
f.check.pars0(.mcall, .defaults.hap)
--- call from argument ---
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
--- R stacktrace ---
where 1: f.check.pars0(.mcall, .defaults.hap)
where 2: f.catch0(cur.call, formals())
where 3: haplin0(n.vars = 1, design = "cc", ccvar = 1, xchrom = FALSE,
sex = NULL, verbose = FALSE, use.missing = TRUE, threshold = 0,
reference = 2L, data.out = "prelim", data = c("1", "1", "1",
"1", "2", "2", "2", "2", "1", "2", "1", "2", "1", "2", "1",
"2", "1", "1", "2", "2", "1", "1", "2", "2"))
where 4: do.call("haplin0", args = .haparg)
where 5: (function (nall, n.strata = 1, cases, controls, haplo.freq, RR,
RRcm, RRcf, RRstar, RR.mat, RRstar.mat, xchrom = F, sim.comb.sex = "double",
BR.girls, response = "mult", ...)
{
.sim.maternal <- FALSE
if (!missing(RR.mat) | !missing(RRstar.mat))
.sim.maternal <- TRUE
.sim.poo <- FALSE
if (!missing(RRcm) | !missing(RRcf))
.sim.poo <- TRUE
if (.sim.poo && !missing(RR))
stop("RR cannot be present at the same time as RRcm and RRcf",
call. = F)
.nhaplo <- prod(nall)
.nloci <- length(nall)
.RR.controls <- rep(1, .nhaplo)
.missing.controls <- FALSE
if (missing(controls))
.missing.controls <- TRUE
if (.missing.controls)
controls <- c(mfc = 0)
if (xchrom & sim.comb.sex %in% c("females", "males"))
BR.girls <- 1
if ((n.strata == 1 && length(cases) > 1) | any(sapply(cases,
length) > 1))
stop("Each element of list cases can only have length 1",
call. = F)
if (!.missing.controls && (n.strata == 1 && length(controls) >
1) | any(sapply(controls, length) > 1))
stop("Each element of list controls can only have length 1",
call. = F)
.arg <- list(nall = nall, n.strata = n.strata, cases = cases,
controls = controls, haplo.freq = haplo.freq, sim.maternal = .sim.maternal,
sim.poo = .sim.poo, xchrom = xchrom, sim.comb.sex = sim.comb.sex,
nhaplo = .nhaplo, nloci = .nloci, n.sim = 10)
if (.sim.poo)
.RR.arg <- list(RRcm = RRcm, RRcf = RRcf, RRstar = RRstar)
else .RR.arg <- list(RR = RR, RRstar = RRstar)
if (.sim.maternal)
.RR.arg <- c(.RR.arg, list(RR.mat = RR.mat, RRstar.mat = RRstar.mat))
if (xchrom)
.RR.arg <- c(.RR.arg, list(BR.girls = BR.girls))
.arg <- c(.arg, .RR.arg)
.strat.arg <- do.call(f.hapArg, args = .arg)
.f.prob.arg <- .strat.arg[, -which(colnames(.strat.arg) %in%
c("cases", "controls", "n.sim")), drop = FALSE]
lapply(1:n.strata, function(x) {
do.call(f.hapTests, args = .strat.arg[x, ])
})
if (xchrom & sim.comb.sex == "males")
message("The males are simulated assuming no contribution from fathers to sons")
.design <- sapply(1:n.strata, function(x) {
if (all(.strat.arg[, "control.mat"][[x]] == 0) | .missing.controls) {
if (all(.strat.arg[, "case.design"][[x]] == "c"))
stop("Only case children are given. No controls are available",
call. = F)
if (all(.strat.arg[, "case.design"][[x]] == "fc") &
xchrom)
stop("No controls are available", call. = F)
.design <- "triad"
}
else if (all(.strat.arg[, "case.design"][[x]] == "c") &
all(.strat.arg[, "control.design"][[x]] == "c"))
.design <- "cc"
else .design <- "cc.triad"
return(.design)
})
if (length(unique(.design)) == 1)
.design <- unique(.design)
else stop("Unable to specify haplin design due to the combination of arguments \"cases\" and \"controls\"",
call. = F)
if (.design == "cc" & xchrom)
stop("Design \"cc\" and xchrom is not yet implemented ",
call. = F)
.n.vars <- 0
.ccvar <- NULL
.sex = NULL
if (xchrom)
.n.vars <- .n.vars + 1
if (.design != "triad")
.n.vars <- .n.vars + 1
if (.design != "triad" & !xchrom)
.ccvar <- .n.vars
else if (.design == "triad" & xchrom)
.sex <- .n.vars
else if (.design != "triad" & xchrom) {
.ccvar <- .n.vars - 1
.sex <- .n.vars
}
if (is.list(haplo.freq))
.haplo.freq <- haplo.freq[[which.max(unlist(lapply(haplo.freq,
max)))]]
else .haplo.freq <- haplo.freq
.ref.cat <- which.max(.haplo.freq)
.lu <- list(...)
if ("reference" %in% names(.lu))
.ref.cat <- .lu$reference
.response <- response
.haparg <- list(n.vars = .n.vars, design = .design, ccvar = .ccvar,
xchrom = xchrom, sex = .sex, verbose = FALSE, use.missing = TRUE,
threshold = 0, reference = .ref.cat, data.out = "prelim")
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) %in%
c("gen.missing.cases", "gen.missing.controls", "nloci",
"nhaplo", "case.des", "control.des", "case.mat",
"control.mat", "case.design", "control.design", "nall",
"sim.poo")), drop = FALSE]
colnames(.f.prob.arg)[which(colnames(.f.prob.arg) == "xchrom")] <- "sim.xchrom"
if (!.sim.poo) {
.f.prob.arg.RRcmcf <- cbind(.f.prob.arg[, "RR"], .f.prob.arg[,
"RR"])
colnames(.f.prob.arg.RRcmcf) <- c("RRcm", "RRcf")
.f.prob.arg <- cbind(.f.prob.arg, .f.prob.arg.RRcmcf)
.f.prob.arg <- .f.prob.arg[, -which(colnames(.f.prob.arg) ==
"RR"), drop = FALSE]
}
.var.covar <- list()
for (i in 1:n.strata) {
.tmp.strat.arg <- .strat.arg[i, ]
.RR <- as.data.frame(.tmp.strat.arg[which(grepl("RR",
names(.tmp.strat.arg)))])
.RRstar <- .RR[, which(grepl("star", names(.RR))), drop = F]
if (.response == "mult") {
if (any(apply(.RRstar, 2, sum) != .nhaplo))
stop("Arguments RRstar and/or RRstar.mat do not correspond to a multiplicative dose-response model",
call. = F)
.RR <- .RR[, -which(grepl("star", names(.RR))), drop = F]
}
.names <- names(.RR)
.RR.ref <- .RR[.ref.cat, , drop = F]
.RR <- lapply(1:ncol(.RR), function(x) .RR[, x] <- .RR[,
x]/.RR.ref[, x])
.RR <- lapply(1:length(.RR), function(x) {
if (!grepl("star", .names[x]))
.RR <- .RR[[x]][-.ref.cat]
else if (grepl("star", .names[x]) & .nhaplo <= 2)
.RR <- .RR[[x]][-.ref.cat]
else .RR <- .RR[[x]]
.RR
})
.RR.beta <- as.vector(log(unlist(.RR)))
.haplo.coef <- .tmp.strat.arg$haplo.freq
.haplo.beta <- f.beta.haplo.freq.asymp(haplo.freq = .haplo.coef)
.beta <- c(.haplo.beta, .RR.beta)
.k <- 0
if (.design != "triad") {
.k <- .tmp.strat.arg$controls/.tmp.strat.arg$cases
.beta <- c(0, .beta)
}
if (xchrom)
.beta <- c(-log(1/BR.girls), .beta)
.design.matrix <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = F, mc.int = F)
.info <- attr(.design.matrix, "info")
.X <- as.matrix(.design.matrix)
names(.beta) <- colnames(.X)
.prob <- f.prob.asymp(beta = .beta, design = .design,
X = .X, k = .k)
.design.grid <- f.design.get(n.all = .nhaplo, design = .design,
xchrom = xchrom, maternal = .sim.maternal, poo = .sim.poo,
hwe = T, comb.sex = sim.comb.sex, ref.cat = .ref.cat,
response = .response, ret.characteristics = T, mc.int = F)
.grid <- expand.grid(lapply(.design.grid, function(x) {
1:x
}))
.case.design = .tmp.strat.arg$case.design
.control.design = .tmp.strat.arg$control.design
.grid <- f.grid.asymp(pos = nrow(.grid), design = .design,
xchrom = xchrom, n.vars = .n.vars, nall = nall, case.design = .case.design,
control.design = .control.design)
.ncells <- nrow(.grid)
.haparg$data <- .grid
.data <- do.call("haplin0", args = .haparg)
if (.design != "triad") {
.data$cc[.data$cc == "case"] <- 2
.data$cc[.data$cc == "control"] <- 1
mode(.data$cc) <- "numeric"
}
if (xchrom) {
.data$sex[.data$sex == "girl"] <- 2
.data$sex[.data$sex == "boy"] <- 1
mode(.data$sex) <- "numeric"
}
.orig <- sort(unique(.data$orig.lines))
if (!identical(.orig, 1:.ncells))
stop()
.norig <- length(.orig)
.var.covar.strat <- f.var.covar.asymp(X = .X, data = .data,
pred = .prob, ncells = .ncells, norig = .norig, orig = .orig,
info = .info)
if (xchrom | .design != "triad")
.beta <- .beta[-which(names(.beta) %in% c("cc", "sex"))]
.var.covar.strat <- .var.covar.strat[names(.beta), names(.beta)]/(.strat.arg[i,
"cases"]$cases + .strat.arg[i, "controls"]$controls)
if (.sim.poo)
.var.covar.strat <- f.post.poo.diff(list(as.matrix(.beta)),
list(as.matrix(.var.covar.strat)))
else .var.covar.strat <- f.post.diff(list(.beta), list(.var.covar.strat))
.var.covar[[i]] <- .var.covar.strat
}
.coef <- sapply(.var.covar, function(x) x$coeff)
.covar <- sapply(.var.covar, function(x) x$covar)
.asymp <- list(coef = .coef, cov = .covar)
attr(.asymp, "ref.cat") <- .ref.cat
return(.asymp)
})(n.strata = 1, nall = 2, cases = list(c(c = 1)), controls = list(
c(c = 1)), haplo.freq = c(0.1, 0.9), RR = c(1, 1), RRcm = ,
RRcf = , RRstar = c(1, 1), RR.mat = , RRstar.mat = , xchrom = FALSE,
sim.comb.sex = "double", BR.girls = , response = "mult")
where 6: do.call(hapCovar, args = .asymp.arg1)
where 7: hapRelEff(cases.comp = c(c = 1), controls.comp = c(c = 1), cases.ref = c(mfc = 1),
haplo.freq = c(0.1, 0.9), RR = c(1, 1))
where 8: eval(expr, envir, enclos)
where 9: eval(expr, envir, enclos)
where 10: withVisible(eval(expr, envir, enclos))
where 11: withCallingHandlers(withVisible(eval(expr, envir, enclos)), warning = wHandler,
error = eHandler, message = mHandler)
where 12: handle(ev <- withCallingHandlers(withVisible(eval(expr, envir,
enclos)), warning = wHandler, error = eHandler, message = mHandler))
where 13: timing_fn(handle(ev <- withCallingHandlers(withVisible(eval(expr,
envir, enclos)), warning = wHandler, error = eHandler, message = mHandler)))
where 14: 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 15: evaluate::evaluate(...)
where 16: 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 17: 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 18: block_exec(params)
where 19: call_block(x)
where 20: process_group.block(group)
where 21: process_group(group)
where 22: 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 23: process_file(text, output)
where 24: knitr::knit(knit_input, knit_output, envir = envir, quiet = quiet,
encoding = encoding)
where 25: rmarkdown::render(file, encoding = encoding, quiet = quiet, envir = globalenv(),
...)
where 26: vweave_rmarkdown(...)
where 27: engine$weave(file, quiet = quiet, encoding = enc)
where 28: doTryCatch(return(expr), name, parentenv, handler)
where 29: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 30: tryCatchList(expr, classes, parentenv, handlers)
where 31: 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 32: tools:::.buildOneVignette("hapRelEff.Rmd", "/home/hornik/tmp/R.check/r-devel-gcc/Work/PKGS/Haplin.Rcheck/vign_test/Haplin",
TRUE, FALSE, "hapRelEff", "UTF-8", "/home/hornik/tmp/scratch/RtmpwjaC5d/file3732c404cda.rds")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (mcall, defaults)
{
params <- defaults
params[names(mcall)] <- mcall
.info <- list(filename = params[["filename"]], filespecs = params[c("markers",
"n.vars", "sep", "allele.sep", "na.strings", "subset")],
model = params[c("design", "use.missing", "xchrom", "comb.sex",
"maternal", "poo", "test.maternal", "scoretest")],
variables = params[c("ccvar", "covar", "strata", "sex")],
haplos = params[c("reference", "response", "threshold",
"max.haplos", "haplo.file")], control = params[c("resampling",
"max.EM.iter", "data.out", "verbose", "printout")])
class(.info) <- "info"
.xchrom <- .info$model$xchrom
.ccdesign <- .info$model$design %in% c("cc.triad", "cc")
.allowed <- .info
.allowed$model$scoretest <- c("yes", "no", "only")
.allowed$model$design <- c("triad", "cc.triad", "cc")
.allowed$haplos$response <- c("mult", "free")
.allowed$control$data.out <- c("no", "basic", "prelim", "null",
"full")
.allowed$control$resampling <- c("no", "jackknife")
.allowed$model$comb.sex <- c("males", "females", "single",
"double")
for (i in seq(along = .info)[-1]) {
for (j in seq(along = .info[[i]])) {
if (length(.info[[c(i, j)]]) == 1) {
if (!is.element(.info[[c(i, j)]], .allowed[[c(i,
j)]])) {
stop(paste("The argument ", names(.info[[i]])[j],
" has an invalid value. \nIt should be one of: \n",
paste(.allowed[[c(i, j)]], collapse = ", "),
sep = ""), call. = F)
}
}
}
}
if (.info$model$design %in% c("triad", "cc.triad")) {
.info$model$fam <- "mfc"
}
if (.info$model$design == "cc") {
.info$model$fam <- "c"
}
if (!is.name(.info$filename)) {
.filetest.f <- file_test("-f", .info$filename)
if (!.filetest.f)
stop(paste(.info$filename, " is not a file.", sep = ""),
call. = F)
}
if (class(mcall$data) == "gwaa.data") {
if (.info$model$design == "triad") {
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc.triad") {
.info$variables$ccvar <- 10
if (.xchrom) {
.info$variables$sex <- 7
}
}
if (.info$model$design == "cc") {
.info$variables$ccvar <- 4
if (.xchrom) {
.info$variables$sex <- 3
}
}
}
if (.xchrom && !is.null(.info$model$comb.sex) && .info$model$comb.sex ==
"males") {
if (.info$haplos$response != "mult") {
warning("Can only use response = \"mult\" with comb.sex = \"males\". Has been changed to \"mult\".",
call. = F)
.info$haplos$response <- "mult"
}
if (.info$model$poo) {
stop("parent-of-origin estimation not possible when comb.sex = \"males\".",
call. = F)
}
}
if (.info$model$poo) {
if (.info$model$design == "cc") {
stop("parent-of-origin effects not available when design = \"cc\"",
call. = F)
}
if (.info$haplos$reference == "reciprocal") {
warning("Can only (for the time being) use reference = \"ref.cat\" or \"population\" when poo == TRUE. Has been changed to \"ref.cat\".",
call. = F)
.info$haplos$reference <- "ref.cat"
}
}
if (.ccdesign) {
if (is.null(.info$variables$ccvar)) {
stop("Parameter \"ccvar\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (.info$filespecs$n.vars == 0)
stop("Parameter \"n.vars\" must be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
if (.info$variables$ccvar > .info$filespecs$n.vars)
stop("Parameter \"n.vars\" must be at least as large as parameter \"ccvar\"!",
call. = F)
}
else {
if (!is.null(.info$variables$ccvar))
stop("Parameter \"ccvar\" should only be specified when using design \"cc.triad\" or \"cc\"!",
call. = F)
}
if (!is.logical(.xchrom)) {
stop("Argument \"xchrom\" must be a logical ( either \"TRUE\" or \"FALSE\" )",
call. = F)
}
if (.xchrom) {
if (.info$filespecs$n.vars == 0) {
stop("Argument \"n.vars\" must be at least 1 to allow for a sex variable when \"xchrom = TRUE\"",
call. = F)
}
if (!is.numeric(.info$variables$sex)) {
stop("Argument \"sex\" should be a numeric value ( the column number of the sex variable ) when \"xchrom = TRUE\"",
call. = F)
}
if (.info$variables$sex > .info$filespecs$n.vars) {
stop("Argument \"sex\" cannot be larger than \"n.vars\"",
call. = F)
}
}
if (F) {
if (!.xchrom & !is.null(.info$model$comb.sex))
warning("Argument \"comb.sex\" is only implemented for models where \"xchrom = TRUE\"",
call. = F)
}
if (identical(.info$model$comb.sex, "males"))
.info$variables$sel.sex <- 1
if (identical(.info$model$comb.sex, "females"))
.info$variables$sel.sex <- 2
if (.info$model$scoretest == "only" & (.info$control$data.out ==
"full")) {
warning("Since data.out = \"full\", scoretest argument is changed from \"only\" to \"no\"",
call. = F)
.info$control$scoretest <- "no"
}
if (!is.numeric(.info$filespecs$markers) & !identical(.info$filespecs$markers,
"ALL"))
stop("\"markers\" argument must be either \"ALL\" ( default ) or an integer value.",
call. = F)
if ((.info$model$design == "cc") & (.info$model$maternal))
stop("Cannot use maternal = TRUE with design = \"cc\"",
call. = F)
if ((.info$haplos$response %in% c("mult")) & is.element(.info$haplos$reference,
c("reciprocal", "population"))) {
warning("response = \"mult\" must be used with reference category ( numeric or \"ref.cat\" ). Has been changed to reference = \"ref.cat\"",
call. = F)
.info$haplos$reference <- "ref.cat"
}
if (.info$model$test.maternal)
.info$model$maternal <- TRUE
return(.info)
}
<bytecode: 0x55df6ce63ea8>
<environment: namespace:Haplin>
--- function search by body ---
Function f.check.pars0 in namespace Haplin has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
SUMMARY: processing the following file failed:
‘hapRelEff.Rmd’
Error: Vignette re-building failed.
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 7.1.0
Check: for non-standard things in the check directory
Result: NOTE
Found the following files/directories:
‘exmpl_data_preproc_gen.RData’ ‘exmpl_data_preproc_gen.ffData’
‘exmpl_haplin_data_gen.RData’ ‘exmpl_haplin_data_gen.ffData’
‘exmpl_ped_data_gen.RData’ ‘exmpl_ped_data_gen.ffData’
‘exmpl_ped_data_part_gen.RData’ ‘exmpl_ped_data_part_gen.ffData’
‘gen_data_men_only_gen.RData’ ‘gen_data_men_only_gen.ffData’
‘my_data_part_gen.RData’ ‘my_data_part_gen.ffData’
‘poo_exmpl_data_preproc_gen.RData’
‘poo_exmpl_data_preproc_gen.ffData’ ‘poo_exmpl_data_read_gen.RData’
‘poo_exmpl_data_read_gen.ffData’ ‘trial_data_gen.RData’
‘trial_data_gen.ffData’
Flavors: r-devel-linux-x86_64-fedora-clang, r-devel-linux-x86_64-fedora-gcc
Version: 7.1.0
Check: package dependencies
Result: NOTE
Package suggested but not available for checking: ‘Rmpi’
Flavors: r-release-osx-x86_64, r-oldrel-osx-x86_64