diff --git a/DESCRIPTION b/DESCRIPTION index b688e07..1aa4444 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: breedR Type: Package Title: Statistical Methods for Forest Genetic Resources Analysts -Version: 0.11-5 +Version: 0.12 Encoding: UTF-8 Authors@R: c(person("Facundo", "Muñoz", role=c("aut", "cre"), @@ -24,12 +24,16 @@ Depends: sp Imports: ggplot2, + graphics, + grDevices, Matrix (>= 1.2.0), methods, nlme, pedigree, pedigreemm, - splines + splines, + stats, + utils Suggests: doParallel, GGally, @@ -52,4 +56,4 @@ URL: https://github.com/famuvie/breedR BugReports: https://github.com/famuvie/breedR/issues Additional_repositories: http://www.math.ntnu.no/inla/R/testing VignetteBuilder: knitr -RoxygenNote: 5.0.1 +RoxygenNote: 6.0.1 diff --git a/NAMESPACE b/NAMESPACE index 14f21e3..746e728 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,8 +7,8 @@ S3method(all,equal.remlf90) S3method(as.data.frame,metagene) S3method(as.data.frame,pedigree) S3method(coef,remlf90) -S3method(effect_size,breedr_effect) -S3method(effect_size,effect_group) +S3method(dim,breedr_effect) +S3method(dim,effect_group) S3method(effect_type,breedr_effect) S3method(effect_type,effect_group) S3method(extractAIC,remlf90) @@ -38,8 +38,9 @@ S3method(nobs,remlf90) S3method(plot,metagene) S3method(plot,ranef.breedR) S3method(plot,remlf90) +S3method(print,breedR.q) S3method(print,breedR.variogram) -S3method(print,ranef.breedR) +S3method(print,breedR_estimates) S3method(print,remlf90) S3method(print,summary.metagene) S3method(print,summary.remlf90) @@ -59,6 +60,7 @@ S3method(renderpf90,permanent_environmental_competition) S3method(renderpf90,splines) S3method(residuals,remlf90) S3method(sim.spatial,metagene) +S3method(summary,breedR.q) S3method(summary,metagene) S3method(summary,remlf90) S3method(vcov,random) @@ -96,11 +98,34 @@ exportMethods("coordinates<-") exportMethods(coordinates) import(Matrix) import(ggplot2) +import(sp) +importFrom(grDevices,colorRampPalette) +importFrom(graphics,par) +importFrom(graphics,plot.new) +importFrom(methods,as) importFrom(methods,setMethod) importFrom(methods,setOldClass) importFrom(nlme,fixef) importFrom(nlme,ranef) +importFrom(stats,AIC) +importFrom(stats,BIC) +importFrom(stats,aggregate) +importFrom(stats,dist) +importFrom(stats,fitted) +importFrom(stats,logLik) +importFrom(stats,median) importFrom(stats,model.matrix) +importFrom(stats,model.response) importFrom(stats,nobs) +importFrom(stats,printCoefmat) +importFrom(stats,quantile) +importFrom(stats,residuals) +importFrom(stats,runif) +importFrom(stats,sd) +importFrom(stats,terms) +importFrom(stats,var) importFrom(stats,vcov) +importFrom(stats,xtabs) +importFrom(utils,read.table) +importFrom(utils,str) importMethodsFrom(Matrix,coerce) diff --git a/NEWS b/NEWS index 8e09471..c8eecd2 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,12 @@ -* Interface for using **weights** for residual variance +breedR 0.12 +=========== + +* Basic multitrait interface (#30) + +* Default values for initial (co)variances are now a function of empirical +(co)variances + +* Interface for using **weights** for residual variance (#77) * Vignette: Heterogeneous variances diff --git a/R/AllGeneric.R b/R/AllGeneric.R index 3eb517a..87f5982 100644 --- a/R/AllGeneric.R +++ b/R/AllGeneric.R @@ -23,12 +23,6 @@ get_param <- function(x) UseMethod('get_param') #' @param x object to be \emph{translated} to progsf90 effect_type <- function(x) UseMethod('effect_type') -#' Size of a (group of) effect(s) -#' -#' Returns 0 for a \code{fixed} effect, and the size of a \code{effect_group} -#' @param x element of the breedr_modelframe -effect_size <- function(x) UseMethod('effect_size') - #' Render a progsf90 effect #' #' Translates breedR effects into progsf90 parameters and data. diff --git a/R/ar.R b/R/ar.R index 03266b3..fd5ae6e 100644 --- a/R/ar.R +++ b/R/ar.R @@ -115,5 +115,6 @@ build.AR.rho.grid <- function(rho) { build.AR1d <- function(n, x) { temp <- diag(c(1, rep(1 + x^2, n-2), 1)) subdiag <- rbind(0, cbind(diag(-x, n-1), 0)) - return(as(Matrix::Matrix(temp + subdiag + t(subdiag), sparse = TRUE), 'dgTMatrix')) + ans <- Matrix::Matrix(temp + subdiag + t(subdiag), sparse = TRUE) + return(methods::as(ans, 'dgTMatrix')) } diff --git a/R/binaries.R b/R/binaries.R index 0672746..0458ffe 100644 --- a/R/binaries.R +++ b/R/binaries.R @@ -30,7 +30,7 @@ check_progsf90 <- function(path = breedR.getOption('breedR.bin'), if (!check && !quiet) { message('Binary dependencies missing.', '\nWould you like to install them?\t') - if (menu(c("Yes", "No")) == 1) { + if (utils::menu(c("Yes", "No")) == 1) { install_progsf90(dest = path, platform = platform) check <- check_progsf90(path, platform, quiet) } @@ -100,7 +100,7 @@ retrieve_bin <- function(f, url, dest) { } else { out <- tryCatch( - download.file( + utils::download.file( url = file.path(url, f), destfile = destf, mode = 'wb', @@ -154,12 +154,15 @@ progsf90_files <- function(os = breedR.os.type(), } -## Check whether there is internet connection +# Check whether there is internet connection breedR_online <- function() { tf <- tempfile() !inherits( suppressWarnings( - try(download.file('http://famuvie.github.io/breedR/', tf, quiet = TRUE)) + try(utils::download.file( + 'http://famuvie.github.io/breedR/', tf, quiet = TRUE + ), + silent = TRUE) ), 'try-error' ) diff --git a/R/breedr_effect.R b/R/breedr_effect.R index 2d401ef..2246885 100644 --- a/R/breedr_effect.R +++ b/R/breedr_effect.R @@ -1,4 +1,4 @@ -#' Constructor for a generic effect +#' Constructor for a generic breedR effect #' #' The breedr_effect-class is virtual. No object should be directly created with #' this constructor. This constructor is to be called from within non-virtual @@ -24,6 +24,19 @@ breedr_effect <- function(incidence) { return(ans) } + +# @describeIn breedr_effect Dimension of a \code{breedr_effect}: 0 for a fixed +# effect, 1 for a random effect +#' @rdname breedr_effect +#' @param x A \code{breedr_effect}. +#' @export +dim.breedr_effect <- function(x) { + siz <- ifelse(inherits(x, 'random'), 1, 0) + return(c(size = siz, ntraits = NA)) +} + + + #' Constructor for a group of effects #' #' Builds an \code{effect_group} from a list of \code{breer_effect} elements. @@ -32,20 +45,20 @@ breedr_effect <- function(incidence) { #' object. In the future, the initial covariance matrix will be a matter of the #' inference engine, not inherent to the model. #' +#' The `ntraits` is used to check the dimension of the initial variance matrix. +#' #' @param x list of breedr_effect elements #' @param cov.ini initial covariance matrix for the estimation algorithm +#' @param ntraits number of traits in the model #' #' @return A list of \code{breedr_effect} elements. -effect_group <- function(x, cov.ini) { +effect_group <- function(x, cov.ini, ntraits) { ## Checks ========================================== ## x is a list and cov.ini a SPD matrix stopifnot(is.list(x)) cov.ini <- as.matrix(cov.ini) - stopifnot(is.numeric(cov.ini)) - stopifnot(isSymmetric.matrix(cov.ini, check.attributes = FALSE)) - ev <- eigen(cov.ini, symmetric = TRUE, only.values = TRUE)$values - stopifnot(all(ev > 0)) + validate_variance(cov.ini) ## all elements are breedr_effects if (!all(sapply(x, inherits, 'breedr_effect'))) @@ -53,7 +66,7 @@ effect_group <- function(x, cov.ini) { ## cov.ini is square and of size equal to number of effects nx <- length(x) - if (!all(dim(cov.ini) == nx)) + if (!all(dim(cov.ini) == nx*ntraits)) stop('Dimension of the initial covariance matrix do not conform with number of effects in the group.') @@ -63,10 +76,12 @@ effect_group <- function(x, cov.ini) { return(ans) } -#' Size of a group of effects -#' -#' @param x object of class \code{effect_group} -group_size <- function(x) { - stopifnot(inherits(x, 'effect_group')) - length(x$effects) +# @describeIn effect_group Returns the dimension of an \code{effect_group} +# factored by its size and number of traits +#' @rdname effect_group +#' @export +dim.effect_group <- function(x) { + siz <- length(x$effects) + ntr <- dim(as.matrix(x$cov.ini))[1] / siz + return(c(size = siz, ntraits = ntr)) } diff --git a/R/checks.R b/R/checks.R index d5bad91..b7a9965 100644 --- a/R/checks.R +++ b/R/checks.R @@ -1,12 +1,27 @@ ## Functions for checking model components ## Internal - not exported -check_var.ini <- function (x, random) { + +#' Check initial variances specification +#' +#' If the user specified initial values, verify that all random effects were +#' included. Otherwise, set default values. In any case, validate all initial +#' values. +#' +#' @return A list with initial covariance matrices for all random effects in the +#' model. A logical attribute `var.ini.default` is TRUE if values were set by +#' default. +#' +#' @param x list. user specification of var.ini (or NULL) +#' @param random formula. user specification of random effects. +#' @param response numeric vector or matrix. +#' @return matrix of observation values. +check_var.ini <- function (x, random, response) { ## terms in the random component + 'residual' random.terms <- switch( is.null(random) + 1, - c(attr(terms(random), 'term.labels'), 'residuals'), + c(attr(stats::terms(random), 'term.labels'), 'residuals'), 'residuals') if (!is.null(x)) { @@ -27,8 +42,10 @@ check_var.ini <- function (x, random) { } else { ## set default values and flag - x <- as.list(rep(breedR.getOption('default.initial.variance'), - length(random.terms))) + div_fun <- breedR.getOption('default.initial.variance') + default_ini <- + eval(div_fun)(response, dim = 1, cor.effect = 0.1, digits = 2) + x <- lapply(random.terms, function(x) default_ini) names(x) <- random.terms attr(x, 'var.ini.default') <- TRUE } @@ -42,6 +59,7 @@ check_var.ini <- function (x, random) { } +## Checks and completes the specification of a genetic model check_genetic <- function(model = c('add_animal', 'competition'), pedigree, id, @@ -51,18 +69,15 @@ check_genetic <- function(model = c('add_animal', 'competition'), autofill = TRUE, var.ini, data, + response, ...) { ## do not include data in the call ## data is an auxiliar for checking and substituting id ## but it is not part of the genetic component specification mc <- match.call() - mc <- mc[names(mc) != 'data'] + mc <- mc[!names(mc) %in% c('data', 'response')] - ## flag indicating whether the var.ini was taken by default - ## or specified by the user - attr(mc, 'var.ini.default') <- FALSE - ## Mandatory arguments for (arg in c('model', 'pedigree', 'id')) { if (eval(call('missing', as.name(arg))) || @@ -115,23 +130,32 @@ check_genetic <- function(model = c('add_animal', 'competition'), 'not represented in the pedigree:\n', toString(mc$id[which(!idx)]))) + ## flag indicating whether the var.ini was taken by default + ## or specified by the user + attr(mc, 'var.ini.default') <- FALSE + + ## default initial variance function + div_fun <- breedR.getOption('default.initial.variance') + + ## dimension of the genetic effect + dim <- switch(mc$model, add_animal = 1, competition = 2) + ## Set default var.ini if missing if (missing(var.ini) || is.null(var.ini)) { - var.ini <- switch( - mc$model, - add_animal = breedR.getOption('default.initial.variance'), - competition = { - var.ini.mat <- diag(breedR.getOption('default.initial.variance'), 2) - var.ini.mat[1,2] <- var.ini.mat[2,1] <- -var.ini.mat[1,1]/2 - var.ini.mat - } - ) + ## default initial covariance matrix + var.ini <- + eval(div_fun)(response, dim = dim, cor.effect = 0.1, digits = 2) + + ## set flag indicating a default initial value attr(mc, 'var.ini.default') <- TRUE } - ## Validate initial variance - validate_variance(var.ini) + ## Validate initial variance (SPD, dimensions, etc.) + validate_variance( + var.ini, + dimension = rep(dim*ncol(as.matrix(response)), 2), + where = 'genetic component.') ## Checks specific to competition models if (mc$model == 'competition') { @@ -184,7 +208,10 @@ check_genetic <- function(model = c('add_animal', 'competition'), 'in the competition specification.\n', 'e.g. pec = list(present = TRUE, var.ini = 1)')) } - pec$var.ini <- breedR.getOption('default.initial.variance') + + ## default initial covariance matrix + pec$var.ini <- + eval(div_fun)(response, dim = 1, cor.effect = 0.1, digits = 2) } ## Validate initial variance in pec @@ -227,17 +254,14 @@ check_spatial <- function(model = c('splines', 'AR', 'blocks'), autofill = TRUE, sparse = TRUE, var.ini, - data) { + data, + response) { ## do not include data in the call ## data is an auxiliar for checking and substituting id ## but it is not part of the genetic component specification mc <- match.call() - mc <- mc[names(mc) != 'data'] - - ## flag indicating whether the var.ini was taken by default - ## or specified by the user - attr(mc, 'var.ini.default') <- FALSE + mc <- mc[!names(mc) %in% c('data', 'response')] for (arg in c('model', 'coordinates')) { if (eval(call('missing', as.name(arg)))) @@ -321,15 +345,31 @@ check_spatial <- function(model = c('splines', 'AR', 'blocks'), mc$rho <- rho.grid } + ## flag indicating whether the var.ini was taken by default + ## or specified by the user + attr(mc, 'var.ini.default') <- FALSE + + ## default initial variance function + div_fun <- breedR.getOption('default.initial.variance') + + ## dimension of the spatial effect + dim <- 1 + if (missing(var.ini) || is.null(var.ini)) { - ## If not specified, return function that gives the value - ## in order to check later whether the value is default or specified - var.ini <- breedR.getOption('default.initial.variance') + + ## default initial covariance matrix + var.ini <- eval(div_fun)(response, dim, cor.effect = 0.1, digits = 2) + + ## set flag indicating a default initial value attr(mc, 'var.ini.default') <- TRUE } - - ## Validate initial variance - validate_variance(var.ini) + + ## Validate initial variance (SPD, dimensions, etc.) + validate_variance( + var.ini, + dimension = rep(dim*ncol(as.matrix(response)), 2), + where = 'spatial component.' + ) mc$var.ini <- var.ini ## evaluate remaining parameters @@ -342,7 +382,7 @@ check_spatial <- function(model = c('splines', 'AR', 'blocks'), -check_generic <- function(x){ +check_generic <- function(x, response){ mc <- match.call() @@ -362,7 +402,9 @@ check_generic <- function(x){ ## validate individual elements for (arg.idx in seq_along(x)){ - result <- try(do.call('validate_generic_element', x[[arg.idx]]), silent =TRUE) + result <- try(do.call('validate_generic_element', + c(x[[arg.idx]], response = list(response))), + silent =TRUE) if (inherits(result, 'try-error')) { stop(paste(attr(result, 'condition')$message, 'in generic component', names(x)[arg.idx])) @@ -389,13 +431,14 @@ check_generic <- function(x){ } -validate_generic_element <- function(incidence, covariance, precision, var.ini) { +validate_generic_element <- function(incidence, + covariance, + precision, + var.ini, + response) { mc <- match.call() - - ## flag indicating whether the var.ini was taken by default - ## or specified by the user - attr(mc, 'var.ini.default') <- FALSE + mc <- mc[names(mc) != 'response'] for (arg in c('incidence')) { if (eval(call('missing', as.name(arg)))) @@ -418,18 +461,33 @@ validate_generic_element <- function(incidence, covariance, precision, var.ini) stop(paste(str.name, 'must be of type matrix')) if(ncol(incidence) != nrow(structure)) stop(paste('Non conformant incidence and', str.name, 'matrices')) + + ## flag indicating whether the var.ini was taken by default + ## or specified by the user + attr(mc, 'var.ini.default') <- FALSE + + ## default initial variance function + div_fun <- breedR.getOption('default.initial.variance') + + ## dimension of the generic effect + dim <- 1 if (missing(var.ini) || is.null(var.ini)) { ## If not specified, return function that gives the value ## in order to check later whether the value is default or specified - var.ini <- breedR.getOption('default.initial.variance') + var.ini <- eval(div_fun)(response, dim, cor.effect = 0.1, digits = 2) + + ## set flag indicating a default initial value attr(mc, 'var.ini.default') <- TRUE - } + } + + ## Validate initial variance + ## even if default: the user could have changed the default function + validate_variance( + var.ini, + dimension = rep(dim*ncol(as.matrix(response)), 2), + where = 'generic component.') - ## Validate specified variance - ## even if default, since the user could have changed the default option - validate_variance(var.ini) - mc$var.ini <- var.ini return(structure(as.list(mc[-1]), @@ -477,26 +535,23 @@ normalise_coordinates <- function (x, where = '') { #' @param where string. Model component where coordinates were specified. For #' error messages only. E.g. \code{where = 'competition specification'}. #' -#' @return \code{TRUE} is all checks pass +#' @return \code{TRUE} if all checks pass validate_variance <- function (x, dimension = dim(as.matrix(x)), where = '') { - stopifnot(is.numeric(dimension) || length(dimension) != 2) - - if (isTRUE(all.equal(dimension, c(1, 1)))) { - ## Case for a number - if (!is.numeric(x) || !x > 0) - stop(paste('the variance must be a positive number in the', where)) - } else { - ## Case for a matrix - x <- as.matrix(x) - if (nrow(x)!=ncol(x)) - stop(paste('x must be a square matrix in the', where)) - if (length(x) != prod(dimension)) - stop(paste('x must be a', paste(dimension, collapse = 'x'), - 'matrix in the', where)) - if (!all(x == t(x)) || !all(eigen(x)$values >0 )) - stop(paste('x must be a SPD matrix in the', where)) - } + stopifnot( + is.numeric(x <- as.matrix(x)), + is.numeric(dimension), + length(dimension) == 2 + ) + + if (nrow(x)!=ncol(x)) + stop(paste('x must be a square matrix in the', where)) + if (length(x) != prod(dimension)) + stop(paste('x must be a', paste(dimension, collapse = 'x'), + 'matrix in the', where)) + ev <- eigen(x, symmetric = TRUE, only.values = TRUE)$values + if (!isSymmetric(x, check.attributes = FALSE) || !all( ev > 0 )) + stop(paste('x must be a SPD matrix in the', where)) return(TRUE) } diff --git a/R/coordinates.R b/R/coordinates.R index a9374ec..979c226 100644 --- a/R/coordinates.R +++ b/R/coordinates.R @@ -19,6 +19,7 @@ setOldClass(c("permanent_environmental_competition", #' @param value 2-column matrix or data frame with coordinates #' @param ... not used. #' @name coordinates_breedR +#' @import sp NULL #' @importFrom methods setOldClass setMethod diff --git a/R/effect_size.R b/R/effect_size.R deleted file mode 100644 index ff71ec2..0000000 --- a/R/effect_size.R +++ /dev/null @@ -1,13 +0,0 @@ - -#' @describeIn effect_size Size of an \code{effect_group} -#' @export -effect_size.effect_group <- function(x) { - - return(nrow(as.matrix(x$cov.ini))) -} - -#' @describeIn effect_size Size of an \code{breedr_effect} -#' @export -effect_size.breedr_effect <- function(x) { - ifelse(inherits(x, 'random'), 1, 0) -} diff --git a/R/genetic.R b/R/genetic.R index 92c8f9b..6a53434 100644 --- a/R/genetic.R +++ b/R/genetic.R @@ -76,6 +76,7 @@ additive_genetic <- function(pedigree, incidence) { #' @param idx integer vector of observed individuals (in the original #' codification) #' @inheritParams additive_genetic +#' @importFrom methods as #' #' @return A list with elements \code{pedigree}, \code{incidence.matrix}, #' \code{structure.matrix} and \code{structure.type}, which is a string diff --git a/R/get_efnames.R b/R/get_efnames.R index b87b33e..1999522 100644 --- a/R/get_efnames.R +++ b/R/get_efnames.R @@ -8,7 +8,7 @@ get_efnames <- function(effects) { subnames <- function(idx) { - sizes <- vapply(effects, effect_size, 1) + sizes <- vapply(effects, dim, numeric(2))["size", ] if (sizes[idx] <= 1) return(names(effects)[idx]) else return(names(effects[[idx]]$effects)) diff --git a/R/get_structure.R b/R/get_structure.R index 15321e6..1f937b3 100644 --- a/R/get_structure.R +++ b/R/get_structure.R @@ -11,7 +11,8 @@ get_structure.breedR <- function (x) { } -#' @describeIn get_structure Check that all elements share the same structure and return it. +#' @describeIn get_structure Check that all elements share the same structure +#' and return it. #' @export get_structure.effect_group <- function(x) { @@ -36,9 +37,17 @@ get_structure.effect_group <- function(x) { str.list.prec <- str.list[str.types == 'precision'] if (length(str.list.cov) > 1) - stopifnot(all.equalx(str.list.cov[1], str.list.cov[-1])) + stopifnot( + all(vapply(str.list.cov[-1], + function(x) isTRUE(all.equal(str.list.cov[1], x)), + TRUE)) + ) if (length(str.list.prec) > 1) - stopifnot(all.equalx(str.list.prec[1], str.list.prec[-1])) + stopifnot( + all(vapply(str.list.prec[-1], + function(x) isTRUE(all.equal(str.list.prec[1], x)), + TRUE)) + ) ## Compare one covariance with one inverted precision ## Converting to standard matrix format, as solving often diff --git a/R/gghacks.R b/R/gghacks.R index 5813d28..386d9c4 100644 --- a/R/gghacks.R +++ b/R/gghacks.R @@ -3,9 +3,11 @@ #' This function presents several ggplots of the same type side by side #' under the same scale, while keeping annotations. #' +#' The names of the objects in the list will be used for facet labels. +#' #' @param plots List of ggplots with meaningful names #' -#' The names of the objects in the list will be used for facet labels. +#' @usage compare.plots(plots) #' @import ggplot2 #' @export compare.plots compare.plots <- function(plots) { @@ -45,13 +47,13 @@ compare.plots <- function(plots) { if( nrow(text.data) > 0 ) { # Remove the original geom_text layer p$layers[[text.data[1, 'layer']]] <- NULL - p <- p + geom_text(aes(x, y, label = lab), + p <- p + geom_text(aes_string("x", "y", label = "lab"), data = text.data, parse = any(text.data$parse)) } # Include all annotations and facets - p <- p + facet_grid(~ .id) + p <- p + facet_grid("~ .id") p # # ggplot(tmpdat, aes(irow, icol)) + @@ -79,7 +81,8 @@ spatial.plot <- function(dat, scale = c('divergent', 'sequential')) { ggcl <- paste('ggplot2::ggplot(dat, aes(',cn[1], ',', cn[2], ')) + geom_raster(aes(fill = ', cn[3], '))') p <- eval(parse(text = ggcl)) } else { - p <- ggplot2::ggplot(dat, aes(x , y)) + geom_raster(aes(fill = z)) + p <- ggplot2::ggplot(dat, aes_string("x" , "y")) + + geom_raster(aes_string(fill = "z")) } diff --git a/R/metagene-class.R b/R/metagene-class.R index 74e9cb6..c37cd0f 100644 --- a/R/metagene-class.R +++ b/R/metagene-class.R @@ -9,6 +9,7 @@ #' insim.002) #' @return the data in the file as an object of class \code{metagene} #' @references \url{http://www.igv.fi.cnr.it/noveltree/} +#' @importFrom utils read.table #' @export #' @aliases metagene read.metagene <- function(fname) { @@ -71,12 +72,13 @@ read.metagene <- function(fname) { #' @method summary metagene #' @param object a metagene object #' @describeIn read.metagene summary of a metagene object +#' @importFrom stats sd var #' @export summary.metagene <- function(object, ...) { # attach(x) xsummary <- function(x) c(summary(x), - 'SD'=sd(x), - 'Var'=var(x))[c(4, 7, 8, 1:3, 5:6)] + 'SD'=stats::sd(x), + 'Var'=stats::var(x))[c(4, 7, 8, 1:3, 5:6)] breeding.values <- list( global = do.call(rbind, @@ -196,10 +198,10 @@ plot.metagene <- function(x, type = c('default', 'spatial'), ...) { generation = rep(factor(x$gen), 2), sex = rep(x$sex, 2), value = c(x$BV_X, x$phe_X)) - p <- ggplot(dat, aes(x = value, fill = label)) + + p <- ggplot(dat, aes_string(x = "value", fill = "label")) + geom_density(alpha=.3) + facet_grid(generation~.) + - labs(x = "Value by generation") + labs(x = "Value by generation") } if( !missing(...) ) { @@ -348,6 +350,7 @@ b.values <- function(x) { #### Simulate spatial structure #### +#' @importFrom stats var #' @export sim.spatial.metagene <- function(meta, variance = 0.5, range = 0.5, ...) { diff --git a/R/options.R b/R/options.R index f8a9561..cb9164b 100644 --- a/R/options.R +++ b/R/options.R @@ -18,7 +18,8 @@ #' gives the number of knots (nok) to be used for a splines model, if not #' otherwise specified #' -#' \code{default.initial.variance}: a default value for all variance components +#' \code{default.initial.variance}: a function of the numeric response vector +#' or matrix which returns a default initial value for a variance component #' #' \code{col.seq}: a vector with the specification of default extreme breedR #' col for sequential scales in spatial quantitative plots. See Details. @@ -113,7 +114,7 @@ breedR.getOption <- function(option = c("ar.eval", breedR.bin = breedR.bin.builtin(), ar.eval = c(-8, -2, 2, 8)/10, splines.nok = quote(determine.n.knots), - default.initial.variance = 1, + default.initial.variance = quote(default_initial_variance), col.seq = c('#034E7B', '#FDAE6B'), col.div = c('#3A3A98FF', '#832424FF'), cygwin = 'C:/cygwin', @@ -226,3 +227,79 @@ breedR.setOption <- function(...) { } return (invisible(op)) } + +#' Default initial value for variance components +#' +#' A function of the response vector or matrix (multi-trait case) returning a +#' SPD matrix of conforming dimensions. +#' +#' The default initial covariance matrix across traits is computed as half the +#' empirical covariance kronecker times a Positive-Definite matrix with Compound +#' Symmetry Structure with a constant diagonal with value 1 and constant +#' off-diagonal elements with the positive value given by \code{cor.effect}, +#' i.e. \deqn{\Sigma = Var(x)/2 \%*\% \psi(dim).} This implies that the default +#' initial \strong{correlations} across traits equal the empirical correlations, +#' except if \code{cor.trait} is not \code{NULL}. +#' +#' \eqn{\psi(dim)} is intendend to model correlated random effects within +#' traits, and only has an effect when \code{dim} > 1. +#' +#' If any column in \code{x} is constant (i.e. empirical variance of 0) then the +#' function stops. It is better to remove this trait from the analysis. +#' +#' @param x numeric vector or matrix with the phenotypic observations. Each +#' trait in one column. +#' @param dim integer. dimension of the random effect for each trait. Default is +#' 1. +#' @param cor.trait a number strictly in (-1, 1). The initial value for the +#' correlation across traits. Default is NULL, which makes the function to +#' take the value from the data. See Details. +#' @param cor.effect a number strictly in (0, 1). The initial value for the +#' correlation across the different dimensions of the random effect. Default +#' is 0.1. +#' @param digits numeric. If not NULL (as default), the resulting matrix is rounded up +#' to 2 significant digits. +#' @examples +#' ## Initial covariance matrix for a bidimensional random effect +#' ## acting independently over three traits +#' x <- cbind(rnorm(100, sd = 1), rnorm(100, sd = 2), rnorm(100, sd = 3)) +#' breedR:::default_initial_variance(x, dim = 2, cor.effect = 0.5) +default_initial_variance <- + function(x, dim = 1, cor.trait = NULL, cor.effect = 0.1, digits = NULL) { + + x <- as.matrix(x) + n.traits <- ncol(x) + + ## Empirical half-variances of each trait + halfvar <- stats::var(x, na.rm = TRUE)/2 + + ## Check for degenerate variances + if (any(idx <- which(diag(halfvar) == 0))) { + stop(paste('Trait', idx, 'is constant.')) + } + + ## User-explicit correlation across traits + if (!is.null(cor.trait) && n.traits > 1) { + D <- diag(sqrt(diag(halfvar))) + C <- matrix(cor.trait, nrow(D), ncol(D)) + + diag(1 - cor.trait, nrow(D), ncol(D)) + halfvar <- D %*% C %*% D + } + + + ## Matrix "expansion" for correlated effects within traits + + ## build exchangeable cov matrix of given dimension + ## with constant variance + exchangeable_covmat <- function(s2, rho, dim) { + matrix(rho*s2, dim, dim) + + diag((1-rho)*s2, dim, dim) + } + + sigma <- kronecker(halfvar, exchangeable_covmat(1, cor.effect, dim)) + + ## Rounding + if (!is.null(digits)) sigma <- signif(sigma, digits) + + return(sigma) +} diff --git a/R/pedigree.R b/R/pedigree.R index 208d446..905dcf2 100644 --- a/R/pedigree.R +++ b/R/pedigree.R @@ -168,7 +168,7 @@ check_pedigree <- function(ped) { # Parent codes should appear in the first column # This removes 0 and NA's as codes - parent_codes <- sort(unique(stack(ped[,2:3])$values[which(ped[,2:3] > 0)])) + parent_codes <- sort(unique(utils::stack(ped[,2:3])$values[which(ped[,2:3] > 0)])) full_ped <- all(parent_codes %in% ped[, 1]) # Offspring follow parents (in codes) @@ -195,6 +195,7 @@ check_pedigree <- function(ped) { #' @describeIn build_pedigree Coerce to a data.frame. One row per individual, #' the first column being the identification code, and the other two columns #' are dad and mum codes respectively. +#' @importFrom methods as #' @export as.data.frame.pedigree <- function(x, ...) { y <- as(x, 'data.frame') diff --git a/R/progsf90.R b/R/progsf90.R index b48c3e8..5dce86e 100644 --- a/R/progsf90.R +++ b/R/progsf90.R @@ -13,7 +13,7 @@ build.effects <- function (mf, genetic, spatial, generic, var.ini) { # # Number of traits # # (size of the response vector or matrix) - # ntraits <- ncol(as.matrix(model.response(mf))) + # ntraits <- ncol(as.matrix(stats::model.response(mf))) # # Position counter # pos = ntraits + 1 @@ -40,7 +40,8 @@ build.effects <- function (mf, genetic, spatial, generic, var.ini) { for (x in names(mf.rnd)) { effect.item <- effect_group(list(diagonal(mf.rnd[[x]])), - cov.ini = var.ini[[x]]) + cov.ini = var.ini[[x]], + ntraits = ncol(stats::model.response(mf))) effect.item.list <- structure(list(effect.item), names = x) effects <- c(effects, effect.item.list) @@ -65,7 +66,8 @@ build.effects <- function (mf, genetic, spatial, generic, var.ini) { ## additive-genetic only effect.item <- effect_group(list(direct = gen_direct), - cov.ini = genetic$var.ini) + cov.ini = genetic$var.ini, + ntraits = ncol(stats::model.response(mf))) effect.item.list <- list(genetic = effect.item) } else { @@ -80,7 +82,8 @@ build.effects <- function (mf, genetic, spatial, generic, var.ini) { effect.item <- effect_group(list(genetic_direct = gen_direct, genetic_competition = gen_comp), - cov.ini = genetic$var.ini) + cov.ini = genetic$var.ini, + ntraits = ncol(stats::model.response(mf))) effect.item.list <- list(genetic = effect.item) ## eventually, a second effect-group for pec @@ -91,7 +94,8 @@ build.effects <- function (mf, genetic, spatial, generic, var.ini) { autofill = genetic$autofill ) effect.item <- effect_group(list(pec = pec), - cov.ini = genetic$pec$var.ini) + cov.ini = genetic$pec$var.ini, + ntraits = ncol(stats::model.response(mf))) effect.item.list <- c( effect.item.list, list(pec = effect.item) @@ -115,7 +119,8 @@ build.effects <- function (mf, genetic, spatial, generic, var.ini) { ## build the effect group with the (single) spatial model effect.item <- effect_group(structure(list(sp), names = class(sp)[1]), - cov.ini = spatial$var.ini) + cov.ini = spatial$var.ini, + ntraits = ncol(stats::model.response(mf))) effects <- c(effects, list(spatial = effect.item)) } @@ -130,7 +135,9 @@ build.effects <- function (mf, genetic, spatial, generic, var.ini) { make_group <- function(x) { stopifnot('var.ini' %in% names(x)) go <- do.call('generic', x[-grep('var.ini', names(x))]) - ef <- effect_group(list(go), x[['var.ini']]) + ef <- effect_group(list(go), + x[['var.ini']], + ntraits = ncol(stats::model.response(mf))) return(ef) } generic.groups <- lapply(generic, make_group) @@ -184,25 +191,22 @@ progsf90 <- function (mf, weights, effects, opt = c("sol se"), res.var.ini = 10) # TODO: Should I pass only the response instead of the whole mf? # or maybe only ntraits?, or maybe include the response in effects? # (size of the response vector or matrix) - ntraits <- ncol(as.matrix(model.response(mf))) + ntraits <- ncol(as.matrix(stats::model.response(mf))) # Weights position w_pos <- ifelse(is.null(weights), '', ntraits + 1) - + ## renderpf90 all the effects ## positions in data file starting after offset for traits and weights - effects.pf90 <- renderpf90.breedr_modelframe(effects, ntraits + (w_pos>0)) + effects.pf90 <- renderpf90.breedr_modelframe(effects, ntraits, w_pos>0) # Builds the lines in the EFFECTS section - na2empty <- function(x) { - x <- as.character(x) - x[is.na(x)] <- '' - return(x) + + setup_effectline <- function(x) { + with(x, paste(pos, levels, type, nest)) } - effect.lst <- - sapply(effects.pf90, - function(x) with(x, paste(pos, levels, type, na2empty(nest)))) + effect.lst <- lapply(effects.pf90, setup_effectline) # Phenotype Y <- mf[, attr(attr(mf, 'terms'), 'response')] @@ -219,17 +223,12 @@ progsf90 <- function (mf, weights, effects, opt = c("sol se"), res.var.ini = 10) } parse.rangroup <- function(x) { - group.size <- nrow(as.matrix(effects.pf90[[x]]$var)) + group.size <- nrow(as.matrix(effects.pf90[[x]]$var))/ntraits ## The group 'head' is the first effect with a number of levels > 0 group.head <- head(which(effects.pf90[[x]]$levels != 0), 1) # Determine the right position in the effects list group.head.abs <- sum(sapply(effect.lst, length)[1:(x-1)]) + group.head - ## Refactored effects - fn <- ifelse('file_name' %in% names(effects.pf90[[x]]), - effects.pf90[[x]]$file_name, - effects.pf90[[x]]$file) - return(list(pos = group.head.abs + 1:group.size - 1, type = effects.pf90[[x]]$model, file = effects.pf90[[x]]$file_name, @@ -239,7 +238,7 @@ progsf90 <- function (mf, weights, effects, opt = c("sol se"), res.var.ini = 10) par <- list(datafile = 'data', ntraits = ntraits, neffects = sum(sapply(effect.lst, length)), - observations = 1:ntraits, + observations = paste(seq_len(ntraits), collapse = " "), weights = w_pos, effects = effect.lst, residvar = res.var.ini, @@ -289,6 +288,21 @@ progsf90 <- function (mf, weights, effects, opt = c("sol se"), res.var.ini = 10) write.progsf90 <- function (pf90, dir) { + write_matrix <- function(x) { + apply(as.matrix(x), 1, paste, collapse = " ") + } + + write_rangroup <- function(x) { + c('RANDOM_GROUP', + paste(x$pos, collapse = ' '), + 'RANDOM_TYPE', + x$type, + 'FILE', + x$file, + '(CO)VARIANCES', + write_matrix(x$cov)) + } + # Parameter file parameter.file <- with(pf90$parameter, @@ -299,19 +313,8 @@ write.progsf90 <- function (pf90, dir) { 'WEIGHT(S)', weights, 'EFFECTS: POSITIONS_IN_DATAFILE NUMBER_OF_LEVELS TYPE_OF_EFFECT [EFFECT NESTED]', paste(unlist(effects)), - 'RANDOM_RESIDUAL VALUES', residvar, - c(sapply(rangroup, - function(x) c('RANDOM_GROUP', - paste(x$pos, collapse = ' '), - 'RANDOM_TYPE', - x$type, - 'FILE', - x$file, - '(CO)VARIANCES', - apply(as.matrix(x$cov), 1, - paste, - collapse = ' '))), - recursive = TRUE), + 'RANDOM_RESIDUAL VALUES', write_matrix(residvar), + c(sapply(rangroup, write_rangroup), recursive = TRUE), paste('OPTION', options))) writeLines(as.character(parameter.file), @@ -319,7 +322,7 @@ write.progsf90 <- function (pf90, dir) { # file.show(parameter.file.path) # Data file - write.table(pf90$data, + utils::write.table(pf90$data, file = file.path(dir, pf90$parameter$datafile), row.names = FALSE, col.names = FALSE) # file.show(data.file.path) @@ -339,18 +342,6 @@ write.progsf90 <- function (pf90, dir) { # Parse results from a progsf90 'solutions' file parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { - ## Parse a matrix from a text output - parse.txtmat <- function(v, names) { - # get the numeric values from the strings, spliting by spaces - ans <- sapply(v, function(x) as.numeric(strsplit(x, ' +')[[1]][-1])) - # ensure matrix even if only a number - ans <- as.matrix(ans) - # if no sub-names passed, remove all naming - if( is.null(names) ) names(ans) <- dimnames(ans) <- NULL - # otherwise, put the given names in both dimensions (covariance matrix) - else dimnames(ans) <- list(names, names) - ans - } ## Parse the AI matrix from AIREML output parse_invAI <- function(x) { @@ -358,7 +349,8 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { idx <- grep('inverse of AI matrix', x) stopifnot(length(idx) == 2) mat.txt <- x[(idx[1]+1):(idx[2]-1)] - invAI <- parse.txtmat(mat.txt, rownames(varcomp)) + + invAI <- parse.txtmat(mat.txt) return(invAI) } @@ -377,7 +369,7 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { names = c('mean', 'sample mean', 'sample sd')) } - pattern <- "^.*? SE for function of \\(co\\)variances (\\w+) .*$" + pattern <- "^.*? SE for function of \\(co\\)variances (\\S+) .*$" labels.idx <- grep(pattern, x) labels <- gsub(pattern, "\\1", x[labels.idx]) idx <- grep(' - Function:', x) @@ -387,9 +379,16 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { if (N > 0L) colnames(ans) <- labels return(ans) } - + + + ## Number and names of traits + ntraits <- as.numeric(tail(unlist(strsplit( + grep("Number of Traits", reml.out, value = TRUE), + ' +')), 1)) + trait_names <- colnames(stats::model.response(mf)) # NULL for 1 trait + # Parsing the results - sol.file <- try(read.table(solfile, header=FALSE, skip=1)) + sol.file <- try(utils::read.table(solfile, header=FALSE, skip=1)) if( inherits(sol.file, 'try-error') ) { ## The output file is formatted with fixed-width columns ## leaving 4 spaces between the columns trait and effect @@ -416,11 +415,24 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { } colnames(sol.file) <- c('trait', 'effect', 'level', 'value', 's.e.') - # Assuming one trait only - result <- split(sol.file[, c('value', 's.e.')], sol.file$effect) + # trait < level < effect + split_by <- function(x, var) { + col.id <- match(var, names(x)) + split(x[, -col.id], x[[col.id]]) + } + result_by_effect <- split_by(sol.file[, -3], 'effect') + result <- lapply(result_by_effect, split_by, 'trait') + + # Name the results according to effects + # Effects can be grouped (e.g. competition) and account for correlated + # effects + names(result) <- get_efnames(effects) + # Name traits within effects + result <- lapply(result, structure, names = trait_names) + # Different results can be associated to a single (group) effect - effect.size <- vapply(effects, effect_size, 1) + effect.size <- vapply(effects, dim, numeric(2))["size", ] # count fixed effects as of size 1 effect.size[effect.size == 0] <- 1 @@ -430,12 +442,6 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { unlist(sapply(seq_along(effects), function(idx) rep(idx, effect.size[idx]))) - # Name the results according to effects - # Effects can be grouped (e.g. competition) and account for correlated - # effects - - names(result) <- get_efnames(effects) - # Identify factors in model terms mt <- attr(mf, 'terms') isF <- sapply(attr(mt, 'dataClasses'), @@ -446,38 +452,19 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { isSpatial <- exists('spatial', effects) # write labels for factor levels in results - for( x in names(isF)[which(isF)] ) - rownames(result[[x]]) <- levels(mf[[x]]) + for (x in names(isF)[which(isF)] ) { + for (trait in seq_len(ntraits)) { + rownames(result[[x]][[trait]]) <- levels(mf[[x]]) + } + } # Random and Fixed effects indices with respect to the 'effects' list effect.type <- vapply(effects, effect_type, '') -# fixed.effects.idx <- which(effect.type == 'fixed') -# diagonal.effects.idx <- sapply(effects, -# function(x) identical(x$model, 'diagonal')) -# special.effects.idx <- !(fixed.effects.idx | diagonal.effects.idx) -# random.effects.idx <- diagonal.effects.idx | special.effects.idx - - # Random effects coefficients ranef <- result[result_effect.map %in% which(effect.type == 'random')] -# # Build up the model matrix *for the fixed and random terms* -# # with one dummy variable per level of factors -# # as progsf90 takes care of everything -# # I need to provide each factor with an identity matrix -# # as its 'contrasts' attribute -# diagonal_contrasts <- function(x) { -# ctr <- diag(nlevels(x)) -# colnames(ctr) <- levels(x) -# attr(x, 'contrasts') <- ctr -# x -# } -# mf[isF] <- lapply(mf[isF], diagonal_contrasts) -# mm <- model.matrix(mt, mf) -# - # REML info # TODO: 'delta convergence' only for AI-REML? reml.ver <- sub('^\\s+([[:graph:]]* +ver\\. +[0-9.]*).*$', '\\1', @@ -490,9 +477,16 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { # Maximum number of iterations # (Hardcoded in REML and AIREML) max.it <- 5000 + + ## Dimension of random effects + rangroup.sizes <- c(effect.size[effect.type == 'random'], + resid = 1)*ntraits + + ## index of variance component results + varcomp.idx <- grep('Genetic variance|Residual variance', reml.out) + 1 # Variance components - if( identical(last.round[1], max.it) ) { + if (identical(last.round[1], max.it)) { warning('The algorithm did not converge') varcomp <- cbind('Estimated variances' = rep(NA, sum(effect.type == 'random') + 1L)) rownames(varcomp) <- c(names(effects)[effect.type == 'random'], 'Residual') @@ -500,32 +494,28 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { # Variance components sd.label <- ifelse(TRUE, 'SE', 'S.D.') - varcomp.idx <- grep('Genetic variance|Residual variance', reml.out) + 1 # There should be one variance for each random effect plus one resid. var. stopifnot(identical(length(varcomp.idx), sum(effect.type == 'random') + 1L)) - rangroup.sizes <- c(effect.size[effect.type == 'random'], - resid = 1) - - if( all(rangroup.sizes == 1) ){ + if (all(rangroup.sizes == 1)){ varcomp <- cbind('Estimated variances' = as.numeric(reml.out[varcomp.idx])) rownames(varcomp) <- c(names(effects)[effect.type == 'random'], 'Residual') } else { varcomp.str <- lapply(mapply(function(x, y) x + 1:y, varcomp.idx-1, - rangroup.sizes), + rangroup.sizes, + SIMPLIFY = FALSE), function(x) reml.out[x]) # names for the members of a group (if more than one) get_subnames <- function(name) { - if (name %in% names(rangroup.sizes) && - rangroup.sizes[name] > 1) { - sn <- names(effects[[name]]$effects) - } else sn <- NULL + ## effect sub-names (or NULL) + esn <- names(effects[[name]]$effects) + names_effect(esn, trait_names) } - subnames <- sapply(names(rangroup.sizes), get_subnames) - varcomp <- mapply(parse.txtmat, varcomp.str, subnames) + subnames <- lapply(names(rangroup.sizes), get_subnames) + varcomp <- mapply(parse.txtmat, varcomp.str, subnames, SIMPLIFY = FALSE) names(varcomp) <- c(names(effects)[effect.type == 'random'], 'Residual') } @@ -535,15 +525,18 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { # There should be one variance for each random effect plus one resid. var. stopifnot(identical(length(varcomp.idx), sum(effect.type == 'random') + 1L)) - if( all(rangroup.sizes == 1) ){ + if (all(rangroup.sizes == 1)){ varcomp <- cbind(varcomp, 'S.E.' = as.numeric(reml.out[varsd.idx])) } else { varsd.str <- lapply(mapply(function(x, y) x + 1:y, varsd.idx-1, - rangroup.sizes), + rangroup.sizes, + SIMPLIFY = FALSE), function(x) reml.out[x]) - varsd <- mapply(parse.txtmat, varsd.str, subnames) + varsd <- mapply(parse.txtmat, varsd.str, subnames, SIMPLIFY = FALSE) names(varsd) <- c(names(effects)[effect.type == 'random'], 'Residual') + varcomp <- cbind("Estimated variances" = varcomp, + "S.E." = varsd) } } } @@ -557,7 +550,16 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { split='delta convergence=')[[1]][2]), output = reml.out ) - if (method == 'ai') reml$invAI <- parse_invAI(reml.out) + + ## AI matrix + if (method == 'ai') { + + comp_names <- unlist( + mapply(vcnames, names(rangroup.sizes), rangroup.sizes, + MoreArgs = list(trnames = trait_names), SIMPLIFY = FALSE)) + reml$invAI <- parse_invAI(reml.out) + dimnames(reml$invAI) <- list(comp_names, comp_names) + } # Fit info last.fit <- as.numeric(strsplit(strsplit(reml.out[last.round.idx-1], @@ -568,14 +570,11 @@ parse_results <- function (solfile, effects, mf, reml.out, method, mcout) { AIC = last.fit[2] ) - # TODO: Add inbreeding coefficient for each tree (in the pedigree) (use pedigreemm::inbreeding()) - # Include the matrix A of additive relationships (as sparse. Use pedigreemm::getA) - # Compute covariances estimates for multiple traits (and their standard errors) ans <- list( call = mcout, method = method, components = list(pedigree = isGenetic, - spatial = isSpatial), # TODO competition, ... + spatial = isSpatial), effects = effects, mf = mf, fixed = result[result_effect.map %in% which(effect.type == 'fixed')], @@ -603,7 +602,7 @@ build.mf <- function(call) { ## Fixed effects fxd <- eval(call$fixed, parent.frame(2)) - tfxd <- terms(fxd) + tfxd <- stats::terms(fxd) # Add an intercept manually only if the user requested it # *and* there are no other *categorical* fixed effects @@ -611,32 +610,32 @@ build.mf <- function(call) { formula = fxd, data = quote(data)), parent.frame()) - tempt <- terms(tempmf) + tempt <- stats::terms(tempmf) tempc <- attr(tempt, 'dataClasses')[attr(tempt, 'term.labels')] any.cat <- any(tempc %in% c('factor', 'ordered')) if( attr(tfxd, 'intercept') == 1L & !any.cat ) { fxd <- update(fxd, " ~ Intercept + .") } - terms.list$fxd <- attr(terms(fxd), 'term.labels') + terms.list$fxd <- attr(stats::terms(fxd), 'term.labels') ## Random effects (unstructured) rnd <- eval(call$random, parent.frame(2)) if(!is.null(rnd)) - terms.list$rnd <- attr(terms(rnd), 'term.labels') + terms.list$rnd <- attr(stats::terms(rnd), 'term.labels') ## Join fixed and random - lhs <- as.character(fxd[[2]]) + lhs <- deparse(fxd[[2]]) rhs <- paste(do.call(c, terms.list), collapse = '+') - fml <- as.formula(paste(lhs, rhs, sep = '~'), env = parent.frame(2)) + fml <- stats::as.formula(paste(lhs, rhs, sep = '~'), env = parent.frame(2)) # Build Model Frame # Use na.pass to allow missing observations which will be handled later mfcall <- call('model.frame', formula = fml, data = quote(transform(data, Intercept = 1)), - na.action = na.pass) + na.action = stats::na.pass) mf <- eval(mfcall, parent.frame()) mt <- attr(mf, 'terms') @@ -693,41 +692,51 @@ pf90_code_missing <- function(x) { #' genetic variance by the sum of all variance components plus the residual #' variance. #' -#' Assumes only one trait. +#' @return A character vector with one option specification per trait. #' #' @param rglist list of random groups in the parameters of a #' \code{\link{progsf90}} object +#' @param traits A character vector with trait names, or NULL for single trait. #' @param quiet logical. If FALSE, the function issues a message when it fails #' to build a formula. #' #' @references #' http://nce.ads.uga.edu/wiki/doku.php?id=readme.aireml#options -pf90_default_heritability <- function (rglist, quiet = FALSE) { +pf90_default_heritability <- function (rglist, traits = NULL, quiet = FALSE) { stopifnot(is.list(rglist)) ## Positions of random effects in the list of random groups ranef.idx <- sapply(rglist, function(x) x$pos) + ## trait indices + tr_idx <- seq_along(traits) + if (is.null(traits)) tr_idx <- 1 + if (length(rglist) > 0 && # there is at least one group all(vapply(ranef.idx, length, 1) == 1) && # all of them of size 1 'genetic' %in% names(ranef.idx)) { # there is a genetic effect ## Compose a formula term for the variance of random effect x ## trait # is 1. vector-friendly - fterm <- function(x) paste('G', x, x, '1', '1', sep = '_') + fterm <- function(x) paste('G', x, x, tr_idx, tr_idx, sep = '_') ## Additive-genetic variance in the numerator ## (Potentially more than one) numerator <- fterm(ranef.idx[['genetic']]) ## All variance estimates plus residual variance in the denominator - denom <- paste(c(sapply(ranef.idx, fterm), paste('R', '1', '1', sep = '_')), - collapse = '+') + trait_component <- cbind( + matrix(sapply(ranef.idx, fterm), ncol = length(ranef.idx)), + paste('R', tr_idx, tr_idx, sep = '_') + ) + denom <- apply(trait_component, 1, paste, collapse = '+') H2fml <- paste0(numerator, "/(", denom, ")") - option.str <- paste('se_covar_function', 'Heritability', H2fml) + H2lbl <- "Heritability" + if (!is.null(traits)) H2lbl <- paste(H2lbl, traits, sep = ":") + option.str <- paste('se_covar_function', H2lbl, H2fml) } else { @@ -738,3 +747,63 @@ pf90_default_heritability <- function (rglist, quiet = FALSE) { return(option.str) } + + +#' Parse a matrix from a text output robustly +#' +#' Each row of the matrix is a string. If rows are too long, they can continue +#' in another line. Hence, the number of lines might be a multiple of the number +#' of columns +#' +#' @param x A character vector with space-separated numbers +#' @param names A character vector with row and column names for the output matrix. +#' @param square logical. Whether to assume that the matrix is square. +#' +#' If the matrix is not necessarily +parse.txtmat <- function(x, names = NULL, square = TRUE) { + ## numeric values from the strings, spliting by spaces + ans <- unname( + lapply(x, function(x) as.numeric(strsplit(x, ' +')[[1]][-1])) + ) + + ## concatenate rows in groups of p + fix_rows <- function(x, p) { + grp <- split(x, rep(seq_len(length(x)/p), each = p)) + return(unname(lapply(grp, unlist))) + } + + row_lengths <- sapply(ans, length) + nonzero_drl <- diff(row_lengths) != 0L + + ## Handle potential line wrapping + if( any(nonzero_drl) ) { + ## row-lengths not constant: e.g. drl = 10 10 2 10 10 2 ... + ## concatenate lines by period + period <- head(which(nonzero_drl), 1) + 1 + ans <- fix_rows(ans, period) + + ## row lengths should be constant by now + row_lengths <- sapply(ans, length) + nonzero_drl <- diff(row_lengths) != 0L + stopifnot(!any(nonzero_drl)) + } + + if ( square && (m <- length(ans)) != (n <- row_lengths[1]) ) { + ## square matrix not square + ## check rows are multiple of cols + if (m %% n != 0) stop("Could not figure out square matrix dimensions.") + period <- m %/% n + ans <- fix_rows(ans, period) + } + + ## ensure matrix even if only a number + ans <- as.matrix(simplify2array(ans)) + + ## if no sub-names passed, remove all naming + if( is.null(names) ) names(ans) <- dimnames(ans) <- NULL + # otherwise, put the given names in both dimensions (covariance matrix) + else dimnames(ans) <- list(names, names) + + return(ans) +} + diff --git a/R/remlf90-class.R b/R/remlf90-class.R index 91a6f86..d6cd0af 100644 --- a/R/remlf90-class.R +++ b/R/remlf90-class.R @@ -291,6 +291,7 @@ #' } #' #' @export +#' @importFrom stats terms model.response logLik runif remlf90 <- function(fixed, random = NULL, genetic = NULL, @@ -314,10 +315,18 @@ remlf90 <- function(fixed, # Allow for multiple responses # Allow for generalized mixed models - ### Call mc <- mcout <- match.call() + + # Builds model frame by joining the fixed and random terms + # and translating the intercept (if appropriate) to a fake covariate + # Add an additional 'term.types' attribute within 'terms' + # indicating whether the term is 'fixed' or 'random' + # progsf90 does not allow for custom model parameterizations + # and they don't use intercepts + mf <- build.mf(mc) + mt <- attr(mf, 'terms') ### Checks if ( missing(fixed) | missing(data) ) { @@ -349,15 +358,30 @@ remlf90 <- function(fixed, method <- tolower(method) method <- match.arg(method) + + ### Number of traits + # ntraits <- ncol(as.matrix(model.response(mf))) + + ### Response matrix (ntraits = ncols) + responsem <- as.matrix(model.response(mf)) + ## Genetic specification if (!is.null(genetic)) { - genetic <- do.call('check_genetic', c(genetic, list(data = data))) + ## TODO: Ideally, I should pass the model frame only, containing the + ## necessary variables (also for special effects and response) + genetic <- do.call('check_genetic', + c(genetic, list(data = data, + response = responsem))) } + ## Spatial specification if (!is.null(spatial)) { - - spatial <- do.call('check_spatial', c(spatial, list(data = data))) + ## TODO: Ideally, I should pass the model frame only, containing the + ## necessary variables (also for special effects and response) + spatial <- do.call('check_spatial', + c(spatial, list(data = data, + response = responsem))) # If AR model without rho specified # we need to fit it with several fixed rho's @@ -391,15 +415,17 @@ remlf90 <- function(fixed, ## Generic specification if (!is.null(generic)) { - generic <- check_generic(generic) + ## TODO: multitrait case shoud check initial variance conformity + ## and return a sensible default + generic <- check_generic(generic, response = responsem) } ## Initial variances specification ## We check even the NULL case, where the function returns the ## default initial variances for all random effects + residuals - var.ini <- check_var.ini(var.ini, random) + var.ini <- check_var.ini(var.ini, random, responsem) - ## Whether the user specified all initial variances for each component + ## Whether the initial variances for each component are defaults has_var.ini <- function(x) { if (eval(call('is.null', as.symbol(x)))) return(NA) @@ -415,23 +441,12 @@ remlf90 <- function(fixed, 'Please specify either all or none.')) ## Issue a warning in the case of no specification if (all(var.ini.checks, na.rm = TRUE)) { - message(paste('No specification of initial variances.\n', - '\tUsing default value of', - breedR.getOption('default.initial.variance'), - 'for all variance components.\n', - '\tSee ?breedR.getOption.\n')) + message(paste0('Using default initial variances given by ', + breedR.getOption('default.initial.variance'), '()\n', + 'See ?breedR.getOption.\n')) } - # Builds model frame by joining the fixed and random terms - # and translating the intercept (if appropriate) to a fake covariate - # Add an additional 'term.types' attribute within 'terms' - # indicating whether the term is 'fixed' or 'random' - # progsf90 does not allow for custom model parameterizations - # and they don't use intercepts - mf <- build.mf(mc) - mt <- attr(mf, 'terms') - # Build a list of parameters and information for each effect effects <- build.effects(mf, genetic, spatial, generic, var.ini) @@ -445,13 +460,13 @@ remlf90 <- function(fixed, opt = union('sol se', progsf90.options), res.var.ini = var.ini$residuals) - if (!is.null(genetic) && method == 'ai') { ## Compute default heritability if possible ## add and additional PROGSF90 OPTION + trait_names <- colnames(model.response(mf)) # NULL for 1 trait pf90$parameter$options <- c(pf90$parameter$options, - pf90_default_heritability(pf90$parameter$rangroup)) + pf90_default_heritability(pf90$parameter$rangroup, trait_names)) } # Temporary dir @@ -554,9 +569,13 @@ remlf90 <- function(fixed, #' @export coef.remlf90 <- function(object, ...) { - unlist(c(lapply(fixef(object), - function(x) x$value), - ranef(object))) + ans <- + rbind( + splat(rbind)(lapply(object$fixed, splat(rbind))), + splat(rbind)(lapply(object$ranef, splat(rbind))) + ) + + return(structure(ans[, "value"], names = rownames(ans))) } #' @export @@ -572,8 +591,7 @@ fitted.remlf90 <- function (object, ...) { mml <- model.matrix(object) - vall <- c(lapply(fixef(object), function(x) x$value), - ranef(object)) + vall <- c(fixef(object), ranef(object)) ## Match order stopifnot(setequal(names(mml), names(vall))) @@ -584,12 +602,13 @@ fitted.remlf90 <- function (object, ...) { } ## Multiply component-wise - comp.mat <- mapply(silent.matmult.drop, mml, vall, - SIMPLIFY = TRUE) + ## dimensions: observation; trait (if ntraits > 1); effect + comp.mat <- mapply(silent.matmult.drop, mml, vall, SIMPLIFY = 'array') # Linear Predictor / Fitted Values - eta <- rowSums(comp.mat) + ndim <- length(dim(comp.mat)) + eta <- rowSums(comp.mat, dims = ndim - 1) # fixed.part <- model.matrix(object)$fixed %*% @@ -637,7 +656,9 @@ fitted.remlf90 <- function (object, ...) { #' @export fixef #' @export fixef.remlf90 <- function (object, ...) { - object$fixed + ans <- get_estimates(object$fixed) + class(ans) <- 'breedR_estimates' + return(ans) } @@ -684,7 +705,7 @@ model.frame.remlf90 <- function (formula, ...) { -#' @importFrom stats nobs +#' @importFrom stats nobs model.response #' @method nobs remlf90 #' @export nobs.remlf90 <- function (object, ...) { @@ -707,6 +728,7 @@ nobs.remlf90 <- function (object, ...) { #' @param ... Further layers passed to \code{\link[ggplot2]{ggplot}}. #' #' @method plot remlf90 +#' @importFrom stats model.response fitted residuals #' @export plot.remlf90 <- function (x, type = c('phenotype', 'fitted', 'spatial', 'fullspatial', 'residuals'), z = NULL, ...) { @@ -810,16 +832,16 @@ plot.ranef.breedR <- function(x, y, ...) { ranef2df(x[[i]]))) pd <- do.call(rbind, pl) - ggplot(pd, aes(x = level, y = BLUP, ymin = ymin, ymax = ymax)) + + ggplot(pd, aes_string(x = "level", y = "BLUP", ymin = "ymin", ymax = "ymax")) + geom_pointrange() + coord_flip() } else message('No suitable random effects to plot') } -#' @method print ranef.breedR +#' @method print breedR_estimates # @describeIn ranef #' @export -print.ranef.breedR <- function(x, ...) { +print.breedR_estimates <- function(x, ...) { attr2df <- function(x) { data.frame(value = x, `s.e.` = attr(x, 'se')) } @@ -853,9 +875,9 @@ print.ranef.breedR <- function(x, ...) { #' @param object a fitted models with random effects of class #' \code{\link{remlf90}}. #' @param ... not used -#' @return An object of class \code{ranef.breedR} composed of a list of vectors, -#' one for each random effect. The length of the vectors are the number of -#' levels of the corresponding random effect. +#' @return An object of class \code{ranef.breedR} composed of a list of vectors +#' or matrices (multitrait case), one for each random effect. The length of +#' the vectors are the number of levels of the corresponding random effect. #' #' Each random effect has an attribute called \code{"se"} which is a vector #' with the standard errors. @@ -878,48 +900,35 @@ print.ranef.breedR <- function(x, ...) { #' @export ranef #' @export ranef.remlf90 <- function (object, ...) { - - ## List of random effects - ranef <- object$ranef - + ## ranef() will provide the model's random effects ## and further methods will let the user compute their 'projection' ## onto observed individuals (fit) or predict over unobserved individuals (pred) - ans <- list() - - ## Genetic component + + ans <- get_estimates(object$ranef) + + ## Additional attributes + + ## Genetic component: names of individuals if( object$components$pedigree ){ # Indices (in ranef) of genetic-related effects (direct and/or competition) - gen.idx <- grep('genetic', names(ranef)) + gen.idx <- grep('genetic', names(ans)) nm <- get_pedigree(object)@label - gl <- lapply(ranef[gen.idx], function(x) structure(x$value, - se = x$s.e., - names = nm)) - ranef <- ranef[-gen.idx] - ans <- c(ans, gl) - } - - ## Spatial component - if ( object$components$spatial ) { - ans$spatial <- with(ranef$spatial, - structure(value, se = s.e.)) - ranef$spatial <- NULL + for (k in gen.idx) attr(ans[[k]], 'names') <- nm + } - ## Other random effects with no particular treatment - other.ranef <- lapply(ranef, - function(x) structure(x$value, - se = x$s.e.)) - for(x in names(other.ranef)) { - attr(other.ranef[[x]], 'names') <- + idx <- grep('genetic|spatial', names(ans), invert = TRUE) + + for(x in names(ans[idx])) { + attr(ans[[x]], 'names') <- colnames(attr(model.matrix(object)$random[[x]], 'contrasts')) } - ans <- c(ans, other.ranef) - class(ans) <- 'ranef.breedR' + class(ans) <- c('ranef.breedR', 'breedR_estimates') return(ans) } @@ -987,6 +996,7 @@ vcov.remlf90 <- function (object, #' @method residuals remlf90 +#' @importFrom stats model.response #' @export residuals.remlf90 <- function (object, ...) { # TODO: to be used when na.action is included in remlf90 @@ -997,6 +1007,7 @@ residuals.remlf90 <- function (object, ...) { } #' @method summary remlf90 +#' @importFrom stats logLik AIC BIC #' @export summary.remlf90 <- function(object, ...) { @@ -1007,22 +1018,21 @@ summary.remlf90 <- function(object, ...) { return(breedR.qstat(object)) } - ans <- object - # Literal description of the model - effects <- paste(names(ans$components), sep=' and ') + effects <- paste(names(object$components), sep=' and ') title <- paste('Linear Mixed Model with', paste(effects, collapse = ' and '), ifelse(length(effects)==1, 'effect', 'effects'), 'fit by', object$reml$version) # Formula - fml <- deparse(attr(object$mf, 'terms')) + fml.spec <- names(object$components)[unlist(object$components)] + fml <- paste(c(deparse(attr(object$mf, 'terms')), fml.spec), + collapse = ' + ') # Coefficients - # TODO: How to compute Standard errors (and therefore t scores and p-values) # TODO: How to avoid showing the unused levels - coef <- do.call(rbind, object$fixed) + coef <- splat(rbind)(lapply(object$fixed, splat(rbind))) # colnames(coef) <- c('Estimate') # Model fit measures @@ -1037,7 +1047,31 @@ summary.remlf90 <- function(object, ...) { #TODO deviance = dev[["ML"]], # REMLdev = dev[["REML"]], row.names = "") - ans <- c(ans, + + ## Variance components + ## Either a numeric matrix (1 trait) - !is.list + ## or a matrix of matrices (>1 trait) - is.list && is.matrix + ## or a list of matrices (>1 trait, em: no SE) - !is.matrix + if (is.list(object$var) && is.matrix(object$var)) { + ## multiple-trait case: a 2-col (est; SE) matrix of covariance matrices + ## transform a list of 2 cov-matrices (est; SE) into a 2-col data frame + ## with properly named estimates + lmat2df <- function(x, nm) { + data.frame( + lapply(x, `[`, lower.tri(x[[1]], diag = TRUE)), + row.names = vcnames(nm, nrow(x[[1]]), trnames = rownames(x[[1]])), + check.names = FALSE + ) + } + varnm_df <- function(x, nm) lmat2df(object$var[nm, ], nm) + + ## list of data-frames with variance estimates and SE + var_ldf <- lapply(rownames(object$var), varnm_df, x = object$var) + + object$var <- splat(rbind)(var_ldf) + } + + ans <- c(object, model.description = title, formula = fml, model.fit = list(AICframe), @@ -1088,13 +1122,14 @@ print.remlf90 <- function(x, digits = max(3, getOption("digits") - 3), ...) { ## This is modeled a bit after print.summary.lm : #' @method print summary.remlf90 +#' @importFrom stats printCoefmat #' @export print.summary.remlf90 <- function(x, digits = max(3, getOption("digits") - 3), correlation = TRUE, symbolic.cor = FALSE, signif.stars = getOption("show.signif.stars"), ...) { - cat(x$model.description, '\n') - if(!is.null(x$call$formula)) + # cat(x$model.description, '\n') + if(!is.null(x$formula)) cat("Formula:", x$formula,"\n") if(!is.null(x$call$data)) cat(" Data:", deparse(x$call$data),"\n") @@ -1102,16 +1137,18 @@ print.summary.remlf90 <- function(x, digits = max(3, getOption("digits") - 3), cat(" Subset:", x$call$subset,"\n") print(x$model.fit, digits = digits) - cat("\nParameters of special components:\n") parl <- get_param.remlf90(x) - for (i in seq_along(parl)) { - for (j in seq_along(parl[[i]])) { - comp.nm <- ifelse(j==1, - paste0(names(parl)[i], ':'), - paste(character(nchar(names(parl)[i]) + 1), - collapse = '')) - model.nm <- paste0(names(parl[[i]])[j], ':') - cat(comp.nm, model.nm, parl[[i]][[j]]) + if (!is.null(parl)){ + cat("\nParameters of special components:\n") + for (i in seq_along(parl)) { + for (j in seq_along(parl[[i]])) { + comp.nm <- ifelse(j==1, + paste0(names(parl)[i], ':'), + paste(character(nchar(names(parl)[i]) + 1), + collapse = '')) + model.nm <- paste0(names(parl[[i]])[j], ':') + cat(comp.nm, model.nm, parl[[i]][[j]]) + } } } cat("\n") diff --git a/R/remote.R b/R/remote.R index bfc0473..c1baff7 100644 --- a/R/remote.R +++ b/R/remote.R @@ -276,12 +276,14 @@ breedR.remote_load <- function(retry = 5) { } #' @method summary breedR.q +#' @export summary.breedR.q = function(object, ...) { print(object, ...) } #' @method print breedR.q +#' @export print.breedR.q = function(x, ...) { if (length(x) == 0) { diff --git a/R/renderpf90.R b/R/renderpf90.R index 4188fdd..c2e9fc2 100644 --- a/R/renderpf90.R +++ b/R/renderpf90.R @@ -135,17 +135,15 @@ renderpf90.matrix <- function(x) { #' @describeIn renderpf90 Render a full \code{breedr_modelframe} #' @param ntraits integer. Number of traits in the model. +#' @param weights logical. Whether there is an additional column of weights. #' @export -renderpf90.breedr_modelframe <- function(x, ntraits) { - - ## Until the refactoring is completed, not all effects in the list - ## will be breedr_effects or effect_groups - ## Those which are not remain untouched +renderpf90.breedr_modelframe <- function(x, ntraits, weights) { xpf90 <- lapply(x, renderpf90) - ## The dimension of the response will be translated here from progsf90 - ## This determines the initial position of the effects in the data file + ## The dimension of the response (i.e. ntraits) will be translated here from + ## progsf90 This determines the initial position of the effects in the data + ## file, and the dimension of 'pos' and 'nest'. ## Make sure file_name are unique aux.idx <- which(sapply(x, inherits, 'effect_group')) @@ -159,13 +157,21 @@ renderpf90.breedr_modelframe <- function(x, ntraits) { ## Positions of the 'virtual' effects in the data file ## (to appear in the EFFECTS section in progsf90) dat.widths <- sapply(xpf90, function(x) ncol(x$data)) - end.columns <- cumsum(c(response = ntraits, dat.widths)) + end.columns <- cumsum(c(response = ntraits + weights, dat.widths)) offsets <- structure(head(end.columns, -1), names = names(dat.widths)) + collapse_traits <- function(x, ntraits) { + if (!is.na(x)) + paste(rep(x, ntraits), collapse = " ") + else '' + } + for (i in seq_along(xpf90)) { - xpf90[[i]]$pos <- offsets[[i]] + xpf90[[i]]$pos - xpf90[[i]]$nest <- offsets[[i]] + xpf90[[i]]$nest + xpf90[[i]]$pos <- vapply(offsets[[i]] + xpf90[[i]]$pos, + collapse_traits, "str", ntraits) + xpf90[[i]]$nest <- vapply(offsets[[i]] + xpf90[[i]]$nest, + collapse_traits, "str", ntraits) } @@ -433,6 +439,7 @@ renderpf90.ar <- function(x) { #' symmetry. #' #' @param x matrix. +#' @importFrom methods as as.triplet <- function(x) { xsp <- Matrix::tril(as(x, 'TsparseMatrix')) # Note: The Matrix package counts rows and columns starting from zero diff --git a/R/simulation.R b/R/simulation.R index 8a1aee5..e011c9e 100644 --- a/R/simulation.R +++ b/R/simulation.R @@ -117,7 +117,7 @@ breedR.sample.phenotype <- function(fixed = NULL, # Fixed if( !is.null(fixed) ) { X <- cbind(1, - matrix(runif(Nfull*(length(fixed) - 1)), + matrix(stats::runif(Nfull*(length(fixed) - 1)), nrow = Nfull)) phenotype <- phenotype + X %*% fixed @@ -133,7 +133,7 @@ breedR.sample.phenotype <- function(fixed = NULL, if( !is.null(random) ) { make.random.single <- function(x, N) { lev <- sample(x$nlevels, N, replace = TRUE) - val <- rnorm(x$nlevels, sd = sqrt(x$sigma2)) + val <- stats::rnorm(x$nlevels, sd = sqrt(x$sigma2)) return(factor(val[lev], levels = val)) } @@ -222,6 +222,8 @@ breedR.sample.phenotype <- function(fixed = NULL, genetic$pedigree <- ped genetic$id <-sum(genetic$Nparents) + 1:Nobs # index of individuals genetic$coord <- coord[ord, ] + genetic$var.ini <- genetic$sigma2_a + genetic$response <- 1 # fake response to establish n. traits genetic <- do.call(check_genetic, genetic) ## Build components @@ -246,7 +248,7 @@ breedR.sample.phenotype <- function(fixed = NULL, # Permanent Environmental Competition effect if (exists('pec', genetic)) { components$pec <- c(rep(NA, Nfull-Nobs), - rnorm(Nobs, sd = sqrt(genetic$pec$var.ini))) + stats::rnorm(Nobs, sd = sqrt(genetic$pec$var.ini))) Pmat <- matrix(components$pec[Bmat[, 8+1:8]], nrow = Nobs) components$wnp <- c(rep(NA, Nfull-Nobs), rowSums(Bmat[, 1:8] * Pmat, na.rm = TRUE)) @@ -261,7 +263,7 @@ breedR.sample.phenotype <- function(fixed = NULL, } else genetic$Nparents = 0 # Residual - components$resid <- rnorm(Nfull, sd = sqrt(residual.variance)) + components$resid <- stats::rnorm(Nfull, sd = sqrt(residual.variance)) phenotype <- phenotype + components$resid # Phenotype @@ -269,7 +271,7 @@ breedR.sample.phenotype <- function(fixed = NULL, # Preferred order of the columns for the first elements pref.ord <- c('self', 'sire', 'dam', 'row', 'col') - reord <- na.omit(match(pref.ord, names(components))) + reord <- stats::na.omit(match(pref.ord, names(components))) if( length(reord) > 0 ) { components <- c(components[, reord], components[, -reord]) } @@ -379,6 +381,7 @@ breedR.sample.BV <- function(ped, Sigma, N = 1) { #' from random mating of independent founders. Note that if #' \code{check.factorial} is \code{FALSE}, you can have some founders removed #' from the pedigree. +#' @importFrom stats xtabs breedR.sample.pedigree <- function(Nobs, Nparents, check.factorial = TRUE) { stopifnot(length(Nparents) == 2) if( is.null(names(Nparents)) ) names(Nparents) <- c('mum', 'dad') @@ -404,3 +407,53 @@ breedR.sample.pedigree <- function(Nobs, Nparents, check.factorial = TRUE) { return(fullped) } + + +#' @rdname simulation +#' @param dim numeric. Dimension of the effect (e.g. n. of traits) +#' @param var numeric matrix. (Co)variance matrix +#' @param Nlevels numeric. Number of individuals values to sample +#' @param labels character vector of labels for each level. +#' @param vname string. A name for the resulting variables +#' @details \code{breedR.sample.ranef} simulates a random effect with a given +#' variance. +breedR.sample.ranef <- + function(dim, var, Nlevels, labels = NULL, N = Nlevels, vname = 'X') { + if(!is.null(dim(var))) stopifnot(identical(dim(var), rep(as.integer(dim), 2))) + if(!is.null(labels)) stopifnot(all.equal(length(labels), Nlevels)) + + ## Simulate Nlevels correlated vectors of dimension dim + U <- chol(var) + values <- matrix(stats::rnorm(dim*Nlevels), ncol = dim) %*% U + + ## Sample N observations of the 'factor' + if (N == Nlevels) { + idx <- seq_len(Nlevels) + } else { + ## either N > Nlevels or N < Nlevels + idx <- sample(seq_len(Nlevels), N, replace = TRUE) + } + ans <- data.frame(values[idx, ]) + + ## variable names from variance matrix colnames + if (!is.null(colnames(var))) + trait_names <- colnames(var) + else trait_names <- seq_len(dim) + varnames <- paste(vname, trait_names, sep = "_") + + if (is.null(labels)) { + ## variable names from variance matrix colnames + if (!is.null(colnames(var))) + labels <- colnames(var) + else labels <- seq_len(dim) + names(ans) <- varnames + } else { + ## factor labels as an additional variable + ans <- cbind(factor(labels[idx]), ans) + names(ans) <- c(vname, varnames) + } + + + return(ans) +} + diff --git a/R/spatial.R b/R/spatial.R index 3d3c98f..9d1781f 100644 --- a/R/spatial.R +++ b/R/spatial.R @@ -61,6 +61,7 @@ loc_grid <- function (coordinates, autofill) { #' #' @param x numeric. Vector of increasing coordinates. #' @param label character. A name like 'rows' or 'x'. +#' @importFrom stats quantile median fill_holes <- function(x, label) { if(length(x) > 1){ diff --git a/R/splines.R b/R/splines.R index dde1116..b29a519 100644 --- a/R/splines.R +++ b/R/splines.R @@ -28,6 +28,7 @@ #' @return A list with elements \code{incidence.matrix}, \code{structure.matrix} #' and \code{structure.type}, which is a string indicating either #' \code{covariance} or \code{precision}. +#' @importFrom methods as breedr_splines <- function(coordinates, n.knots = NULL, autofill = TRUE, diff --git a/R/utils.R b/R/utils.R index 1cf544d..5a7b277 100644 --- a/R/utils.R +++ b/R/utils.R @@ -6,7 +6,7 @@ # Transform the separated fixed and random formulas # into the single formula with lme4 syntaxis lme4_fml <- function(fix, rnd, rm_int = TRUE) { - rnd.terms <- attr(terms(rnd), 'term.labels') + rnd.terms <- attr(stats::terms(rnd), 'term.labels') rnd.terms.lme4 <- paste('(1|', rnd.terms, ')', sep ='') int <- ifelse(rm_int, '-1', '') rnd.upd <- paste('~ .', int, paste('+', rnd.terms.lme4, collapse = ' ')) @@ -41,15 +41,18 @@ breedR.get.element <- function(name, alist) { # Fit some model breedR.result <- function(...) { - res <- suppressWarnings(remlf90(fixed = phe_X ~ gg, - genetic = list(model = 'add_animal', - pedigree = globulus[,1:3], - id = 'self'), - spatial = list(model = 'AR', - coord = globulus[, c('x','y')], - rho = c(.85, .8)), - data = globulus, - ...)) + dat <- breedR::globulus + res <- suppressMessages( + remlf90(fixed = phe_X ~ gg, + genetic = list(model = 'add_animal', + pedigree = dat[,1:3], + id = 'self'), + spatial = list(model = 'AR', + coord = dat[, c('x','y')], + rho = c(.85, .8)), + data = dat, + ...) + ) return(res) } @@ -139,3 +142,97 @@ matrix.short16 <- function(M) { return(Z) } +#' 'Splat' arguments to a function +#' +#' Wraps a function in do.call, so instead of taking multiple arguments, it +#' takes a single named list which will be interpreted as its arguments. +#' +#' @param flat function to splat +#' +#' This is useful when you want to pass a function a row of data frame or array, +#' and don't want to manually pull it apart in your function. +#' +#' Borrowed from \code{\link[plyr]{splat}} +#' +#' @return a function +#' +#' @examples +#' args <- replicate(3, runif(5), simplify = FALSE) +#' identical(breedR:::splat(rbind)(args), do.call(rbind, args)) +splat <- function (flat) { + function(args, ...) { + do.call(flat, c(args, list(...))) + } +} + +# given a list of data.frames, extract a given column +# from each of the data.frames into a matrix. +# Optionally drop into a vector if dimension = 1. +# Used in ranef.remlf90 and fixef.remlf90 to extract +# trait-wise predictions of effects +ldf2matrix <- function(x, vname, drop = TRUE) { + ## All dataframes (ntraits) are of the same size (nlevels x (value, s.e.)) + ## ensure a matrix, even if nlevels = 1 + ans <- do.call(cbind, lapply(x, `[[`, vname)) + rownames(ans) <- rownames(x[[1]]) + if (drop) ans <- drop(ans) + return(ans) +} + + +# Extract values and standard errors from lists +# of effects estimates (or predictions) +# x is a list of effects, where each element is a trait-wise +# list of data.frames with columns 'value' and 's.e.' +get_estimates <- function(x) { + values <- lapply(x, ldf2matrix, 'value') + se <- lapply(x, ldf2matrix, 's.e.') + ans <- mapply(function(gvl, gse) structure(gvl, se = gse), + values, se, SIMPLIFY = FALSE) + return(ans) +} + +# combine sub-effect names and trait names +# trait names within sub-effect names +# bl1 bl2 bl3 + y1 y2 = bl1.y1 bl1.y2 bl2.y1 bl2.y2 bl3.y1 bl3.y2 +# names_effect(paste0("bl", 1:3), paste0("y", 1:2)) +# "bl1.y1" "bl1.y2" "bl2.y1" "bl2.y2" "bl3.y1" "bl3.y2" +# names_effect(paste0("bl", 1:3), NULL) +# "bl1" "bl2" "bl3" +# names_effect(NULL, paste0("y", 1:2)) +# "y1" "y2" +# names_effect(NULL, NULL) +# NULL +names_effect <- function(inner = NULL, outer = NULL) { + + ans <- inner + if (length(outer) > 1) { + if (!is.null(inner)) { + ans <- apply( + expand.grid( + outer, inner, + KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE + )[2:1], + 1, paste, collapse = "." + ) + } else { + ans <- outer + } + } + return(ans) +} + + +## component names +vcnames <- function(efname, efdim, trnames) { + + dim_subtrait <- efdim/ifelse(is.null(trnames), 1, length(trnames)) + if (dim_subtrait > 1) + efname <- paste(efname, seq_len(dim_subtrait), sep = "_") + diag_names <- names_effect(efname, trnames) + + ## matrix components include variances and covariances + ans <- outer(diag_names, diag_names, paste, sep = "_") + diag(ans) <- diag_names + return(ans[upper.tri(ans, diag = TRUE)]) +} diff --git a/R/variogram.R b/R/variogram.R index 0cd16a7..d121973 100644 --- a/R/variogram.R +++ b/R/variogram.R @@ -72,6 +72,8 @@ #' #' #' @seealso \code{\link[fields]{vgram.matrix}} +#' @importFrom stats residuals dist aggregate +#' @importFrom grDevices colorRampPalette #' @export variogram <- function(x, plot = c('all', @@ -252,6 +254,8 @@ variogram <- function(x, #' plotted. Default: 30. #' @param ... not used. #' @import ggplot2 +#' @importFrom graphics plot.new par +#' @importFrom utils str #' @describeIn variogram Print a breedR variogram #' @export print.breedR.variogram <- function(x, minN = 30, ...) { @@ -266,7 +270,7 @@ print.breedR.variogram <- function(x, minN = 30, ...) { } p.iso <- ggplot(x$isotropic, - aes(distance, variogram)) + + aes_string("distance", "variogram")) + geom_point() + geom_line() + stat_smooth(se = FALSE, method = 'auto') diff --git a/inst/doc/Additive-Genetic-Models-in-Mixed-Populations.pdf b/inst/doc/Additive-Genetic-Models-in-Mixed-Populations.pdf index 410832b..89f056f 100644 Binary files a/inst/doc/Additive-Genetic-Models-in-Mixed-Populations.pdf and b/inst/doc/Additive-Genetic-Models-in-Mixed-Populations.pdf differ diff --git a/inst/doc/General-and-Specific-Combining-Abilities.pdf b/inst/doc/General-and-Specific-Combining-Abilities.pdf index a3dc6db..610e5c6 100644 Binary files a/inst/doc/General-and-Specific-Combining-Abilities.pdf and b/inst/doc/General-and-Specific-Combining-Abilities.pdf differ diff --git a/inst/doc/Handling-pedigrees.pdf b/inst/doc/Handling-pedigrees.pdf index 10b7d70..a6bc1ff 100644 Binary files a/inst/doc/Handling-pedigrees.pdf and b/inst/doc/Handling-pedigrees.pdf differ diff --git a/inst/doc/Heritability.pdf b/inst/doc/Heritability.pdf index 4ca67a0..024df58 100644 Binary files a/inst/doc/Heritability.pdf and b/inst/doc/Heritability.pdf differ diff --git a/inst/doc/Heterogeneous-variances.pdf b/inst/doc/Heterogeneous-variances.pdf index a5eff20..7d7fb8a 100644 Binary files a/inst/doc/Heterogeneous-variances.pdf and b/inst/doc/Heterogeneous-variances.pdf differ diff --git a/inst/doc/Missing-values.pdf b/inst/doc/Missing-values.pdf index 9abde92..0413b24 100644 Binary files a/inst/doc/Missing-values.pdf and b/inst/doc/Missing-values.pdf differ diff --git a/inst/doc/Overview.R b/inst/doc/Overview.R index 6a208aa..5e3e340 100644 --- a/inst/doc/Overview.R +++ b/inst/doc/Overview.R @@ -493,6 +493,44 @@ knitr::kable(var.comp) true.exp.cv <- with(dat[rm.idx, ], phenotype - resid) round(sqrt(mean((fitted(res.comp.cv)[rm.idx] - true.exp.cv)^2)), 2) +## ----multitrait-fit------------------------------------------------------ +## Filter site and select relevant variables +dat <- + droplevels( + douglas[douglas$site == "s3", + names(douglas)[!grepl("H0[^4]|AN|BR|site", names(douglas))]] + ) + +res <- + remlf90( + fixed = cbind(H04, C13) ~ orig, + # random = ~ block, + genetic = list( + model = 'add_animal', + pedigree = dat[, 1:3], + id = 'self'), + data = dat + ) + +## ----multitrait-summary, echo = FALSE------------------------------------ +summary(res) + +## ----multitrait-genetic-covariances-------------------------------------- +res$var[["genetic", "Estimated variances"]] + +## Use cov2cor() to compute correlations +cov2cor(res$var[["genetic", "Estimated variances"]]) + +## ----multitrait-fixef-ranef---------------------------------------------- +fixef(res) ## printed in tabular form, but... +unclass(fixef(res)) ## actually a matrix of estimates with attribute "se" + +str(ranef(res)) +head(ranef(res)$genetic) + +## ----multitrait-blups---------------------------------------------------- +head(model.matrix(res)$genetic %*% ranef(res)$genetic) + ## ----breedR-options------------------------------------------------------ breedR.getOption() diff --git a/inst/doc/Overview.Rmd b/inst/doc/Overview.Rmd index 289f26d..2a7549b 100644 --- a/inst/doc/Overview.Rmd +++ b/inst/doc/Overview.Rmd @@ -1233,6 +1233,73 @@ round(sqrt(mean((fitted(res.comp.cv)[rm.idx] - true.exp.cv)^2)), 2) +# Multiple traits + +**breedR** provides a basic interface for multi-trait models which only +requires specifying the different traits in the main formula using `cbind()`. + +```{r multitrait-fit} +## Filter site and select relevant variables +dat <- + droplevels( + douglas[douglas$site == "s3", + names(douglas)[!grepl("H0[^4]|AN|BR|site", names(douglas))]] + ) + +res <- + remlf90( + fixed = cbind(H04, C13) ~ orig, + # random = ~ block, + genetic = list( + model = 'add_animal', + pedigree = dat[, 1:3], + id = 'self'), + data = dat + ) +``` + +A full covariance matrix across traits is estimated for each random effect, +and all results, including heritabilities, are expressed effect-wise: + +```{r multitrait-summary, echo = FALSE} +summary(res) +``` + +Although the results are summarized in tabular form, the covariance matrices +can be recovered directly: + +```{r multitrait-genetic-covariances} +res$var[["genetic", "Estimated variances"]] + +## Use cov2cor() to compute correlations +cov2cor(res$var[["genetic", "Estimated variances"]]) +``` + +Estimates of fixed effects and BLUPs of random effects can be recovered with +`fixef()` and `ranef()` as usual. The only difference is that they will return a +list of matrices rather than vectors, with one column per trait. + +The standard errors are given as attributes, and are displayed in tabular form +whenever the object is printed. + +```{r multitrait-fixef-ranef} +fixef(res) ## printed in tabular form, but... +unclass(fixef(res)) ## actually a matrix of estimates with attribute "se" + +str(ranef(res)) +head(ranef(res)$genetic) +``` + +Recovering the breeding values for each observation in the original dataset +follows the same procedure as for one trait: multiply the incidence matrix by +the BLUP matrix. The result, however, will be a matrix with one column per +trait. + +```{r multitrait-blups} +head(model.matrix(res)$genetic %*% ranef(res)$genetic) +``` + + # Some more features diff --git a/inst/doc/Overview.pdf b/inst/doc/Overview.pdf index 9dbdac7..d713b76 100644 Binary files a/inst/doc/Overview.pdf and b/inst/doc/Overview.pdf differ diff --git a/inst/testdata/airemlf90_log_1.txt b/inst/testdata/airemlf90_log_1.txt new file mode 100644 index 0000000..ec1b732 --- /dev/null +++ b/inst/testdata/airemlf90_log_1.txt @@ -0,0 +1,138 @@ + name of parameter file? +parameters + * missing observation (default=0): -999 + *** store solutions and s.e. *** se + + AI-REMLF90 ver. 1.122 + + Parameter file: parameters + Data file: data + Number of Traits 2 + Number of Effects 2 + Position of Observations 1 2 + Position of Weight (1) 0 + Value of Missing Trait/Observation 0 + +EFFECTS + # type position (2) levels [positions for nested] + 1 covariable 3 3 1 + 2 cross-classified 4 4 50 + + Residual (co)variance Matrix + 0.96000 0.42000 + 0.42000 11.000 + + REMARKS + (1) Weight position 0 means no weights utilized + (2) Effect positions of 0 for some effects and traits means that such + effects are missing for specified traits + + Data record length = 4 + # free parameters= 3 + # parameters= 4 + # random effects= 0 + # elements for random effects= 0 + # maximum (ntrait*random)**2= 2 + # (co)variance matrices= 0 + read 1000 records in 1.8728999E-02 s, 353 + nonzeroes + finished peds in 1.8753000E-02 s, 353 nonzeroes + rank= 102 + ************** + **** FSPAK *** + ************** + MPE / IM / MAE + Jun 1994 + + SPARSE STATISTICS + DIMENSION OF MATRIX = 102 + RANK = 102 + STORAGE AVAILABLE = 2633 + MAXIMUM NEEDED = 2633 + NZE IN UPPER TRIANGULAR = 455 + NZE IN FACTOR = 251 + NO. OF CALLS NUM FACT = 1 + NO. OF CALLS SOLVE = 1 + NO. OF CALLS SPARS SOLV = 0 + NO. OF CALLS DET / LDET = 1 + NO. OF CALLS SPARS INV = 1 + TOTAL CPU TIME IN FSPAK = 0.000198 + TIME FOR FINDING ORDER = 0.000025 + TIME FOR SYMBOLIC FAC = 0.000011 + TIME FOR NUMERICAL FAC = 0.000014 + TIME FOR SOLVE = 0.000004 + TIME FOR SPARSE SOLVE = 0.000000 + TIME FOR SPARSE INVERSE = 0.000017 + -2logL = 6072.75298482128 : AIC = 6078.75298482128 + In round 1 convergence= 9.204781127338116E-002 + delta convergence= 1.01127528179923 + new R + 0.80456 2.8095 + 2.8095 10.511 + -2logL = 8203.74733381667 : AIC = 8209.74733381667 + In round 2 convergence= 6.071740180487556E-003 + delta convergence= 0.388474372557198 + new R + 0.87780 2.9864 + 2.9864 11.426 + -2logL = 6199.31814983008 : AIC = 6205.31814983008 + In round 3 convergence= 4.584489388588833E-004 + delta convergence= 0.108987600459738 + new R + 0.90281 2.9419 + 2.9419 11.684 + -2logL = 5432.29529740702 : AIC = 5438.29529740702 + In round 4 convergence= 3.935632136149145E-004 + delta convergence= 0.107799737895211 + new R + 0.92643 2.8690 + 2.8690 11.911 + -2logL = 5211.59203500297 : AIC = 5217.59203500297 + In round 5 convergence= 1.948306589984007E-004 + delta convergence= 7.664565612114138E-002 + new R + 0.94322 2.8170 + 2.8170 12.072 + -2logL = 5177.23684734518 : AIC = 5183.23684734518 + In round 6 convergence= 1.566568185087734E-005 + delta convergence= 2.179722332893752E-002 + new R + 0.94799 2.8022 + 2.8022 12.118 + -2logL = 5175.78686638886 : AIC = 5181.78686638886 + In round 7 convergence= 4.949525098641211E-008 + delta convergence= 1.225404679715726E-003 + new R + 0.94826 2.8013 + 2.8013 12.120 + -2logL = 5175.78300206193 : AIC = 5181.78300206193 + In round 8 convergence= 4.038531195941370E-013 + delta convergence= 3.500335555297703E-006 + new R + 0.94826 2.8013 + 2.8013 12.120 + solutions and s.e. stored in file: "solutions" + +Final Estimates + Residual variance(s) + 0.94826 2.8013 + 2.8013 12.120 + correlations + 1.0000 0.82631 + 0.82631 1.0000 + eigenvectors + -0.97311 0.23033 + 0.23033 0.97311 + eigenvalues + 0.28519 12.783 + inverse of AI matrix (Sampling Variance) + 0.18950E-02 0.55983E-02 0.16538E-01 + 0.55983E-02 0.20380E-01 0.71555E-01 + 0.16538E-01 0.71555E-01 0.30959 + Correlations from inverse of AI matrix + 1.0000 0.90083 0.68280 + 0.90083 1.0000 0.90083 + 0.68280 0.90083 1.0000 + SE for R + 0.43532E-01 0.14276 + 0.14276 0.55641 diff --git a/inst/testdata/airemlf90_log_2.txt b/inst/testdata/airemlf90_log_2.txt new file mode 100644 index 0000000..25964cf --- /dev/null +++ b/inst/testdata/airemlf90_log_2.txt @@ -0,0 +1,197 @@ + name of parameter file? +parameters + * missing observation (default=0): -999 + *** store solutions and s.e. *** se + + AI-REMLF90 ver. 1.122 + + Parameter file: parameters + Data file: data + Number of Traits 2 + Number of Effects 2 + Position of Observations 1 2 + Position of Weight (1) 0 + Value of Missing Trait/Observation 0 + +EFFECTS + # type position (2) levels [positions for nested] + 1 covariable 3 3 1 + 2 cross-classified 4 4 50 + + Residual (co)variance Matrix + 0.96000 0.42000 + 0.42000 11.000 + + Random Effect(s) 2 + Type of Random Effect: diagonal + trait effect (CO)VARIANCES + 1 2 0.9600 0.4200 + 2 2 0.4200 11.00 + + REMARKS + (1) Weight position 0 means no weights utilized + (2) Effect positions of 0 for some effects and traits means that such + effects are missing for specified traits + + Data record length = 4 + # free parameters= 6 + # parameters= 8 + # random effects= 1 + # elements for random effects= 3 + # maximum (ntrait*random)**2= 4 + # (co)variance matrices= 1 + read 1000 records in 3.1268999E-02 s, 353 + nonzeroes + finished peds in 3.1434000E-02 s, 353 nonzeroes + rank= 102 + ************** + **** FSPAK *** + ************** + MPE / IM / MAE + Jun 1994 + + SPARSE STATISTICS + DIMENSION OF MATRIX = 102 + RANK = 102 + STORAGE AVAILABLE = 2633 + MAXIMUM NEEDED = 2633 + NZE IN UPPER TRIANGULAR = 455 + NZE IN FACTOR = 251 + NO. OF CALLS NUM FACT = 1 + NO. OF CALLS SOLVE = 1 + NO. OF CALLS SPARS SOLV = 0 + NO. OF CALLS DET / LDET = 1 + NO. OF CALLS SPARS INV = 1 + TOTAL CPU TIME IN FSPAK = 0.000217 + TIME FOR FINDING ORDER = 0.000027 + TIME FOR SYMBOLIC FAC = 0.000011 + TIME FOR NUMERICAL FAC = 0.000016 + TIME FOR SOLVE = 0.000006 + TIME FOR SPARSE SOLVE = 0.000000 + TIME FOR SPARSE INVERSE = 0.000020 + -2logL = 6366.17154923307 : AIC = 6378.17154923307 + In round 1 convergence= 0.938064549357143 + delta convergence= 1.72604629535046 + new R + 0.80411 2.8065 + 2.8065 10.501 + new G + 0.76390 -1.4009 + -1.4009 5.7025 + -2logL = 8439.29230205048 : AIC = 8451.29230205048 + In round 2 convergence= 9.139887763314413E-003 + delta convergence= 0.309209041036213 + new R + 0.87701 2.9817 + 2.9817 11.412 + new G + 0.81509 -1.3933 + -1.3933 6.3398 + -2logL = 6453.50000092506 : AIC = 6465.50000092506 + In round 3 convergence= 3.689929967706082E-004 + delta convergence= 8.076761706861509E-002 + new R + 0.90211 2.9372 + 2.9372 11.671 + new G + 0.82093 -1.3696 + -1.3696 6.4659 + -2logL = 5695.91871227495 : AIC = 5707.91871227495 + In round 4 convergence= 1.411428458053771E-006 + delta convergence= 5.578205480891912E-002 + new R + 0.92570 2.8644 + 2.8644 11.899 + new G + 0.82004 -1.3655 + -1.3655 6.4603 + -2logL = 5478.99932068048 : AIC = 5490.99932068048 + In round 5 convergence= 1.195716496128840E-006 + delta convergence= 3.965654780422352E-002 + new R + 0.94231 2.8128 + 2.8128 12.059 + new G + 0.81936 -1.3634 + -1.3634 6.4536 + -2logL = 5445.58284810838 : AIC = 5457.58284810838 + In round 6 convergence= 4.789183100061474E-008 + delta convergence= 1.098547212561306E-002 + new R + 0.94696 2.7984 + 2.7984 12.104 + new G + 0.81923 -1.3630 + -1.3630 6.4522 + -2logL = 5444.20337255722 : AIC = 5456.20337255722 + In round 7 convergence= 3.950567465682949E-010 + delta convergence= 6.133881450508541E-004 + new R + 0.94722 2.7976 + 2.7976 12.106 + new G + 0.81924 -1.3631 + -1.3631 6.4523 + -2logL = 5444.19986995476 : AIC = 5456.19986995476 + In round 8 convergence= 4.223625924120614E-012 + delta convergence= 4.579101840204427E-006 + new R + 0.94722 2.7976 + 2.7976 12.106 + new G + 0.81924 -1.3631 + -1.3631 6.4524 + -2logL = 5444.19986992974 : AIC = 5456.19986992974 + In round 9 convergence= 4.947098163518088E-018 + delta convergence= 3.649287847394725E-009 + new R + 0.94722 2.7976 + 2.7976 12.106 + new G + 0.81924 -1.3631 + -1.3631 6.4524 + solutions and s.e. stored in file: "solutions" + +Final Estimates + Genetic variance(s) for effect 2 + 0.81924 -1.3631 + -1.3631 6.4524 + correlations + 1.0000 -0.59285 + -0.59285 1.0000 + eigenvectors + -0.97471 -0.22346 + -0.22346 0.97471 + eigenvalues + 0.50676 6.7648 + Residual variance(s) + 0.94722 2.7976 + 2.7976 12.106 + correlations + 1.0000 0.82613 + 0.82613 1.0000 + eigenvectors + -0.97312 0.23030 + 0.23030 0.97312 + eigenvalues + 0.28516 12.768 + inverse of AI matrix (Sampling Variance) + 0.30120E-01 -0.42370E-01 0.59559E-01 -0.90746E-04 -0.26714E-03 -0.78650E-03 + -0.42370E-01 0.15253 -0.34518 -0.26905E-03 -0.97917E-03 -0.34332E-02 + 0.59559E-01 -0.34518 2.0014 -0.79760E-03 -0.34575E-02 -0.14989E-01 + -0.90746E-04 -0.26905E-03 -0.79760E-03 0.18886E-02 0.55772E-02 0.16469E-01 + -0.26714E-03 -0.97917E-03 -0.34575E-02 0.55772E-02 0.20303E-01 0.71279E-01 + -0.78650E-03 -0.34332E-02 -0.14989E-01 0.16469E-01 0.71279E-01 0.30849 + Correlations from inverse of AI matrix + 1.0000 -0.62511 0.24258 -0.12032E-01 -0.10803E-01 -0.81592E-02 + -0.62511 1.0000 -0.62476 -0.15852E-01 -0.17595E-01 -0.15827E-01 + 0.24258 -0.62476 1.0000 -0.12973E-01 -0.17152E-01 -0.19075E-01 + -0.12032E-01 -0.15852E-01 -0.12973E-01 1.0000 0.90064 0.68230 + -0.10803E-01 -0.17595E-01 -0.17152E-01 0.90064 1.0000 0.90064 + -0.81592E-02 -0.15827E-01 -0.19075E-01 0.68230 0.90064 1.0000 + SE for G + 0.17355 0.39055 + 0.39055 1.4147 + SE for R + 0.43458E-01 0.14249 + 0.14249 0.55542 diff --git a/inst/testdata/airemlf90_log_3.txt b/inst/testdata/airemlf90_log_3.txt new file mode 100644 index 0000000..0918ed7 --- /dev/null +++ b/inst/testdata/airemlf90_log_3.txt @@ -0,0 +1,494 @@ + name of parameter file? +parameters + * missing observation (default=0): -999 + *** store solutions and s.e. *** se + * SE for function of (co)variances Heritability + G_2_2_1_1/(G_2_2_1_1+G_3_3_1_1+G_4_4_1_1+R_1_1) + + AI-REMLF90 ver. 1.122 + + Parameter file: parameters + Data file: data + Number of Traits 2 + Number of Effects 4 + Position of Observations 1 2 + Position of Weight (1) 0 + Value of Missing Trait/Observation 0 + +EFFECTS + # type position (2) levels [positions for nested] + 1 cross-classified 3 3 8 + 2 cross-classified 4 4 803 + 3 cross-classified 5 5 2376 + 4 cross-classified 6 6 40 + + Residual (co)variance Matrix + 4.2000 -0.16000 +-0.16000 0.50000 + + Random Effect(s) 2 + Type of Random Effect: additive animal + Pedigree File: pedigree_genetic + trait effect (CO)VARIANCES + 1 2 4.200 -0.1600 + 2 2 -0.1600 0.5000 + + Random Effect(s) 3 + Type of Random Effect: user defined from file + User File: ar_spatial + trait effect (CO)VARIANCES + 1 3 4.200 -0.1600 + 2 3 -0.1600 0.5000 + + Random Effect(s) 4 + Type of Random Effect: user defined from file and inverted + User File: generic_block + trait effect (CO)VARIANCES + 1 4 4.200 -0.1600 + 2 4 -0.1600 0.5000 + + REMARKS + (1) Weight position 0 means no weights utilized + (2) Effect positions of 0 for some effects and traits means that such + effects are missing for specified traits + + Data record length = 6 + # free parameters= 12 + # parameters= 16 + # random effects= 3 + # elements for random effects= 9 + # maximum (ntrait*random)**2= 4 + # (co)variance matrices= 3 +hash matrix increased from 8192 to 16384 % filled: 0.8000 +hash matrix increased from 16384 to 32768 % filled: 0.8000 + read 11897 records in 0.1476050 s, 20532 + nonzeroes +hash matrix increased from 32768 to 65536 % filled: 0.8000 + read 803 additive pedigrees +hash matrix increased from 8192 to 16384 % filled: 0.8000 + g_usr_inv: read 11576 elements + largest row, column, diagonal: 2376 2376 2376 +hash matrix increased from 65536 to 131072 % filled: 0.8000 + g_usr_inv: read 40 elements + largest row, column, diagonal: 2376 2376 2376 + a_usr_ija + finished peds in 0.1935290 s, 68641 nonzeroes + rank= 6454 + ************** + **** FSPAK *** + ************** + MPE / IM / MAE + Jun 1994 + + SPARSE STATISTICS + DIMENSION OF MATRIX = 6454 + RANK = 6454 + STORAGE AVAILABLE = 1078173 + MAXIMUM NEEDED = 1078173 + NZE IN UPPER TRIANGULAR = 75095 + NZE IN FACTOR = 373127 + NO. OF CALLS NUM FACT = 2 + NO. OF CALLS SOLVE = 41 + NO. OF CALLS SPARS SOLV = 0 + NO. OF CALLS DET / LDET = 1 + NO. OF CALLS SPARS INV = 1 + TOTAL CPU TIME IN FSPAK = 0.223328 + TIME FOR FINDING ORDER = 0.022705 + TIME FOR SYMBOLIC FAC = 0.002340 + TIME FOR NUMERICAL FAC = 0.030127 + TIME FOR SOLVE = 0.001051 + TIME FOR SPARSE SOLVE = 0.000000 + TIME FOR SPARSE INVERSE = 0.161856 + -2logL = 73236.1131076555 : AIC = 73260.1131076555 + In round 1 convergence= 1.44091153957578 + delta convergence= 0.952299661113297 + new R + 7.4415 -0.23155 + -0.23155 0.65183 + new G + 1.3819 -0.10935 + -0.10935 0.35937 + new G + 3.6362 -0.14418 + -0.14418 0.45875 + new G + 0.43707 -0.23277E-01 + -0.23277E-01 0.67159E-01 + -2logL = 68700.4160116631 : AIC = 68724.4160116631 + In round 2 convergence= 0.348113389212842 + delta convergence= 0.303928542819256 + new R + 8.3540 -0.24720 + -0.24720 0.67323 + new G + 0.47228 -0.83340E-01 + -0.83340E-01 0.27473 + new G + 2.4784 -0.11834 + -0.11834 0.39372 + new G + 0.79915E-01 -0.35900E-02 + -0.35900E-02 0.15381E-01 + -2logL = 68256.0259795067 : AIC = 68280.0259795067 + In round 3 convergence= 0.373675458682425 + delta convergence= 0.111969764300898 + new R + 8.3994 -0.24842 + -0.24842 0.67489 + new G + 0.29308 -0.75243E-01 + -0.75243E-01 0.25161 + new G + 1.5149 -0.95678E-01 + -0.95678E-01 0.33357 + new G + 0.48155E-01 -0.23928E-02 + -0.23928E-02 0.97016E-02 + -2logL = 68057.6302525290 : AIC = 68081.6302525290 + In round 4 convergence= 0.997107911540260 + delta convergence= 9.086647503618724E-002 + new R + 8.3789 -0.24835 + -0.24835 0.67537 + new G + 0.16519 -0.73684E-01 + -0.73684E-01 0.25317 + new G + 0.70585 -0.71424E-01 + -0.71424E-01 0.26237 + new G + 0.19947E-01 -0.12056E-02 + -0.12056E-02 0.51916E-02 + -2logL = 67843.3331388952 : AIC = 67867.3331388952 + In round 5 convergence= 1.65910706480579 + delta convergence= 6.459071576500318E-002 + new R + 8.3562 -0.24816 + -0.24816 0.67553 + new G + 0.85948E-01 -0.76674E-01 + -0.76674E-01 0.27559 + new G + 0.19530 -0.45072E-01 + -0.45072E-01 0.17252 + new G + 0.34913E-02 -0.29000E-03 + -0.29000E-03 0.19231E-02 + -2logL = 67649.8434857858 : AIC = 67673.8434857858 + In round 6 convergence= 4.266835551389778E-002 + delta convergence= 1.534225772180375E-002 + new R + 8.3199 -0.24780 + -0.24780 0.67552 + new G + 0.71957E-01 -0.78855E-01 + -0.78855E-01 0.29211 + new G + 0.13773 -0.33695E-01 + -0.33695E-01 0.12837 + new G + 0.25540E-02 -0.20760E-03 + -0.20760E-03 0.13262E-02 + -2logL = 67613.5431229823 : AIC = 67637.5431229823 + In round 7 convergence= 2.045772141265085E-002 + delta convergence= 8.447378025371271E-003 + new R + 8.3182 -0.24778 + -0.24778 0.67551 + new G + 0.63865E-01 -0.80424E-01 + -0.80424E-01 0.30525 + new G + 0.10089 -0.25782E-01 + -0.25782E-01 0.97427E-01 + new G + 0.18958E-02 -0.14604E-03 + -0.14604E-03 0.92271E-03 + -2logL = 67590.2511253736 : AIC = 67614.2511253736 + In round 8 convergence= 9.386592640432694E-003 + delta convergence= 5.630918121895646E-003 + new R + 8.3178 -0.24777 + -0.24777 0.67551 + new G + 0.59031E-01 -0.81476E-01 + -0.81476E-01 0.31521 + new G + 0.76935E-01 -0.20426E-01 + -0.20426E-01 0.76176E-01 + new G + 0.14569E-02 -0.10556E-03 + -0.10556E-03 0.66096E-03 + -2logL = 67575.5371018161 : AIC = 67599.5371018161 + In round 9 convergence= 4.313545285713892E-003 + delta convergence= 3.834213891025966E-003 + new R + 8.3182 -0.24777 + -0.24777 0.67552 + new G + 0.56158E-01 -0.82219E-01 + -0.82219E-01 0.32269 + new G + 0.60965E-01 -0.16846E-01 + -0.16846E-01 0.61685E-01 + new G + 0.11652E-02 -0.80149E-04 + -0.80149E-04 0.49222E-03 + -2logL = 67566.3123189296 : AIC = 67590.3123189296 + In round 10 convergence= 2.060127605286774E-003 + delta convergence= 2.696016731904364E-003 + new R + 8.3189 -0.24777 + -0.24777 0.67552 + new G + 0.54508E-01 -0.82810E-01 + -0.82810E-01 0.32833 + new G + 0.49952E-01 -0.14435E-01 + -0.14435E-01 0.51698E-01 + new G + 0.96668E-03 -0.64045E-04 + -0.64045E-04 0.38102E-03 + -2logL = 67560.4686359682 : AIC = 67584.4686359682 + In round 11 convergence= 1.307081019838777E-002 + delta convergence= 7.084031719713771E-003 + new R + 8.3270 -0.24778 + -0.24778 0.67553 + new G + 0.53520E-01 -0.85052E-01 + -0.85052E-01 0.34265 + new G + 0.17409E-01 -0.10114E-01 + -0.10114E-01 0.30094E-01 + new G + 0.53003E-03 0.13688E-05 + 0.13688E-05 0.96251E-05 + -2logL = 67548.4329615247 : AIC = 67572.4329615247 + In round 12 convergence= 5.334380102751146E-004 + delta convergence= 1.404723071538737E-003 + new R + 8.3272 -0.24770 + -0.24770 0.67554 + new G + 0.53787E-01 -0.85890E-01 + -0.85890E-01 0.34732 + new G + 0.12324E-01 -0.93142E-02 + -0.93142E-02 0.25212E-01 + new G + 0.51591E-03 0.10064E-05 + 0.10064E-05 0.90926E-05 + -2logL = 67547.2793850247 : AIC = 67571.2793850247 + In round 13 convergence= 2.012585921393148E-003 + delta convergence= 2.643480002809367E-003 + new R + 8.3334 -0.24764 + -0.24764 0.67554 + new G + 0.54272E-01 -0.85411E-01 + -0.85411E-01 0.34907 + new G + 0.10000E-09 -0.10358E-01 + -0.10358E-01 0.23415E-01 + new G + 0.43272E-02 0.30399E-04 + 0.30399E-04 0.44509E-06 + G not positive definite: fixed (setup_g) + -2logL = 51613.3138249635 : AIC = 51637.3138249635 + In round 14 convergence= 0.999941095417880 + delta convergence= 16.6634095526569 + new R + 12.558 1.1800 + 1.1800 0.63670 + new G + 0.10000E-09 22.300 + 22.300 4.9170 + new G + 0.10000E-09 -42.276 + -42.276 102.00 + new G + 4.8509 0.53120E-01 + 0.53120E-01 3.3883 + G not positive definite: fixed (setup_g) + G not positive definite: fixed (setup_g) + -2logL = 78543.2227821955 : AIC = 78567.2227821955 + In round 15 convergence= 1.02407242895374 + delta convergence= 204.300261449093 + new R + 8.7367 -0.16303 + -0.16303 0.67186 + new G + 0.10000E-09 -788.88 + -788.88 0.10000E-09 + new G + 15.848 -43.953 + -43.953 121.90 + new G + 1.2785 0.13480 + 0.13480 1.1352 + G not positive definite: fixed (setup_g) + -2logL = 74186.8156222511 : AIC = 74210.8156222511 + In round 16 convergence= 0.914868527779608 + delta convergence= 2172.70628289739 + new R + 8.5233 -0.24614 + -0.24614 0.67473 + new G + 9067.3 -9067.3 + -9067.3 9067.3 + new G + 11.248 -31.194 + -31.194 86.514 + new G + 0.93280 -0.79520E-01 + -0.79520E-01 0.96590 + G not positive definite: fixed (setup_g) + -2logL = 76384.3215879314 : AIC = 76408.3215879314 + In round 17 convergence= 0.999998933728289 + delta convergence= 564668221.156852 + new R + 9.2794 -0.16078 + -0.16078 0.68234 + new G + 0.16384E+09 -0.16388E+09 + -0.16388E+09 0.16391E+09 + new G + 0.10000E-09 0.15227E+10 + 0.15227E+10 0.10000E-09 + new G + 0.57112E+09 -0.57211E+09 + -0.57211E+09 0.57309E+09 + G not positive definite: fixed (setup_g) + -2logL = 127618.272638329 : AIC = 127642.272638329 + In round 18 convergence= 2.647369507442350E-013 + delta convergence= 152.298741911667 + new R + 7.9725 -0.31913 + -0.31913 0.66886 + new G + 0.16384E+09 -0.16388E+09 + -0.16388E+09 0.16391E+09 + new G + 0.76135E+09 0.76135E+09 + 0.76135E+09 0.76135E+09 + new G + 0.57112E+09 -0.57211E+09 + -0.57211E+09 0.57309E+09 + solutions and s.e. stored in file: "solutions" + +Final Estimates + Genetic variance(s) for effect 2 + 0.16384E+09 -0.16388E+09 + -0.16388E+09 0.16391E+09 + correlations + 1.0000 -1.0000 + -1.0000 1.0000 + eigenvectors + -0.70718 -0.70703 + -0.70703 0.70718 + eigenvalues + 19.253 0.32775E+09 + Genetic variance(s) for effect 3 + 0.76135E+09 0.76135E+09 + 0.76135E+09 0.76135E+09 + correlations + 1.0000 1.0000 + 1.0000 1.0000 + eigenvectors + 0.70711 -0.70711 + -0.70711 -0.70711 + eigenvalues + -965.54 0.15227E+10 + Genetic variance(s) for effect 4 + 0.57112E+09 -0.57211E+09 + -0.57211E+09 0.57309E+09 + correlations + 1.0000 -1.0000 + -1.0000 1.0000 + eigenvectors + -0.70771 -0.70650 + -0.70650 0.70771 + eigenvalues + 61.579 0.11442E+10 + Residual variance(s) + 7.9725 -0.31913 + -0.31913 0.66886 + correlations + 1.0000 -0.13820 + -0.13820 1.0000 + eigenvectors + -0.43570E-01 -0.99905 + -0.99905 0.43570E-01 + eigenvalues + 0.65495 7.9864 + inverse of AI matrix (Sampling Variance) + 0.66953E+08 -0.45341E+08 0.23850E+08 0.87210E-07 0.87784E-07 0.81443E-07 -0.12454E-05 0.14470E-05 -0.16188E-05 -0.84854E-14 + 0.10419E-15 -0.15857E-27 + -0.45341E+08 0.45474E+08 -0.45348E+08 -0.14551E-09 -0.87170E-08 0.22999E-08 0.22507E-07 0.72905E-08 -0.56436E-07 0.82048E-15 + 0.85370E-18 -0.21149E-26 + 0.23850E+08 -0.45348E+08 0.66985E+08 -0.79133E-07 -0.62481E-07 -0.78161E-07 0.12423E-05 -0.14019E-05 0.15689E-05 0.70168E-14 + -0.10816E-15 -0.18815E-26 + 0.87210E-07 -0.14551E-09 -0.79133E-07 0.45666E+08 0.45345E+08 0.45153E+08 -0.85793E-08 -0.31080E-07 0.40594E-07 0.24772E-14 + -0.24650E-16 -0.59714E-29 + 0.87784E-07 -0.87170E-08 -0.62481E-07 0.45345E+08 0.45474E+08 0.45345E+08 0.94006E-08 -0.40545E-08 -0.31921E-07 0.24777E-14 + -0.24648E-16 -0.69515E-27 + 0.81443E-07 0.22999E-08 -0.78161E-07 0.45153E+08 0.45345E+08 0.45666E+08 -0.18991E-07 -0.22845E-07 0.34433E-07 0.24284E-14 + -0.24079E-16 0.44584E-27 + -0.12454E-05 0.22507E-07 0.12423E-05 -0.85793E-08 0.94006E-08 -0.18991E-07 0.11341E+09 -0.45423E+08 -0.22672E+08 -0.22083E-13 + 0.24918E-15 0.19725E-28 + 0.14470E-05 0.72905E-08 -0.14019E-05 -0.31080E-07 -0.40545E-08 -0.22845E-07 -0.45423E+08 0.45474E+08 -0.45267E+08 0.99294E-14 + -0.12135E-15 -0.18421E-26 + -0.16188E-05 -0.56436E-07 0.15689E-05 0.40594E-07 -0.31921E-07 0.34433E-07 -0.22672E+08 -0.45267E+08 0.11357E+09 0.23879E-14 + -0.83377E-17 -0.82619E-27 + -0.84854E-14 0.82048E-15 0.70168E-14 0.24772E-14 0.24777E-14 0.24284E-14 -0.22083E-13 0.99294E-14 0.23879E-14 0.27169E-01 + -0.31470E-03 0.44825E-05 + 0.10419E-15 0.85370E-18 -0.10816E-15 -0.24650E-16 -0.24648E-16 -0.24079E-16 0.24918E-15 -0.12135E-15 -0.83377E-17 -0.31470E-03 + 0.96551E-03 -0.22697E-04 + -0.15857E-27 -0.21149E-26 -0.18815E-26 -0.59714E-29 -0.69515E-27 0.44584E-27 0.19725E-28 -0.18421E-26 -0.82619E-27 0.44825E-05 + -0.22697E-04 0.13679E-03 + Correlations from inverse of AI matrix + 1.0000 -0.82173 0.35614 0.15772E-14 0.15909E-14 0.14729E-14 -0.14292E-13 0.26225E-13 -0.18565E-13 + -0.62915E-17 0.40979E-18 -0.16570E-29 + -0.82173 1.0000 -0.82166 -0.31930E-17 -0.19169E-15 0.50470E-16 0.31341E-15 0.16032E-15 -0.78532E-15 + 0.73816E-18 0.40742E-20 -0.26815E-28 + 0.35614 -0.82166 1.0000 -0.14308E-14 -0.11321E-14 -0.14132E-14 0.14253E-13 -0.25400E-13 0.17988E-13 + 0.52014E-17 -0.42529E-18 -0.19656E-28 + 0.15772E-14 -0.31930E-17 -0.14308E-14 1.0000 0.99507 0.98877 -0.11921E-15 -0.68204E-15 0.56368E-15 + 0.22240E-17 -0.11739E-18 -0.75555E-31 + 0.15909E-14 -0.19169E-15 -0.11321E-14 0.99507 1.0000 0.99507 0.13090E-15 -0.89161E-16 -0.44419E-15 + 0.22291E-17 -0.11763E-18 -0.88141E-29 + 0.14729E-14 0.50470E-16 -0.14132E-14 0.98877 0.99507 1.0000 -0.26389E-15 -0.50132E-15 0.47814E-15 + 0.21802E-17 -0.11467E-18 0.56411E-29 + -0.14292E-13 0.31341E-15 0.14253E-13 -0.11921E-15 0.13090E-15 -0.26389E-15 1.0000 -0.63250 -0.19977 + -0.12580E-16 0.75302E-18 0.15837E-30 + 0.26225E-13 0.16032E-15 -0.25400E-13 -0.68204E-15 -0.89161E-16 -0.50132E-15 -0.63250 1.0000 -0.62990 + 0.89332E-17 -0.57912E-18 -0.23356E-28 + -0.18565E-13 -0.78532E-15 0.17988E-13 0.56368E-15 -0.44419E-15 0.47814E-15 -0.19977 -0.62990 1.0000 + 0.13594E-17 -0.25179E-19 -0.66288E-29 + -0.62915E-17 0.73816E-18 0.52014E-17 0.22240E-17 0.22291E-17 0.21802E-17 -0.12580E-16 0.89332E-17 0.13594E-17 + 1.0000 -0.61444E-01 0.23252E-02 + 0.40979E-18 0.40742E-20 -0.42529E-18 -0.11739E-18 -0.11763E-18 -0.11467E-18 0.75302E-18 -0.57912E-18 -0.25179E-19 + -0.61444E-01 1.0000 -0.62457E-01 + -0.16570E-29 -0.26815E-28 -0.19656E-28 -0.75555E-31 -0.88141E-29 0.56411E-29 0.15837E-30 -0.23356E-28 -0.66288E-29 + 0.23252E-02 -0.62457E-01 1.0000 + SE for G + 8182.5 6743.4 + 6743.4 8184.4 + SE for G + 6757.6 6743.4 + 6743.4 6757.6 + SE for G + 10650. 6743.4 + 6743.4 10657. + SE for R + 0.16483 0.31073E-01 + 0.31073E-01 0.11696E-01 + + Sampling variances of covariances function of random effects (n=5000) + +Heritability - Function: g_2_2_1_1/(g_2_2_1_1+g_3_3_1_1+g_4_4_1_1+r_1_1) + Mean: 0.10950 + Sample Mean: 0.10950 + Sample SD: 0.49345E-05 + elapsed time 4.512653 diff --git a/inst/testdata/index.json b/inst/testdata/index.json new file mode 100644 index 0000000..8b87c27 --- /dev/null +++ b/inst/testdata/index.json @@ -0,0 +1,45 @@ +[ + { + "file_name": "airemlf90_log_1.txt", + "program": "AIREMLF90", + "data_type": "log", + "n_traits": 2, + "n_effects": 2, + "n_parameters": 3, + "n_records": 1000, + "n_random_effects": 0, + "matrix_size": 102, + "matrix_rank": 102, + "n_rounds": 8, + "converged": "TRUE" + }, + { + "file_name": "airemlf90_log_2.txt", + "program": "AIREMLF90", + "data_type": "log", + "n_traits": 2, + "n_effects": 2, + "n_parameters": 6, + "n_records": 1000, + "n_random_effects": 1, + "matrix_size": 102, + "matrix_rank": 102, + "n_rounds": 9, + "converged": "TRUE" + }, + { + "file_name": "airemlf90_log_3.txt", + "program": "AIREMLF90", + "data_type": "log", + "n_traits": 2, + "n_effects": 3, + "n_parameters": 12, + "n_records": 1000, + "n_random_effects": 3, + "matrix_size": 6454, + "matrix_rank": 6454, + "n_rounds": 18, + "converged": "TRUE", + "notes": "parse invAI matrix difficult: matrix lines are wrapped" + } +] \ No newline at end of file diff --git a/inst/testdata/res_ar.rds b/inst/testdata/res_ar.rds new file mode 100644 index 0000000..ffce8e4 Binary files /dev/null and b/inst/testdata/res_ar.rds differ diff --git a/inst/testdata/res_blk.rds b/inst/testdata/res_blk.rds new file mode 100644 index 0000000..d09bb95 Binary files /dev/null and b/inst/testdata/res_blk.rds differ diff --git a/inst/testdata/res_fixonly.rds b/inst/testdata/res_fixonly.rds new file mode 100644 index 0000000..5f431e4 Binary files /dev/null and b/inst/testdata/res_fixonly.rds differ diff --git a/inst/testdata/res_ped_ar.rds b/inst/testdata/res_ped_ar.rds new file mode 100644 index 0000000..7bede90 Binary files /dev/null and b/inst/testdata/res_ped_ar.rds differ diff --git a/inst/testdata/res_spl.rds b/inst/testdata/res_spl.rds new file mode 100644 index 0000000..4ecb199 Binary files /dev/null and b/inst/testdata/res_spl.rds differ diff --git a/man/Extract.metagene.Rd b/man/Extract.metagene.Rd index 08bdfd8..601f548 100644 --- a/man/Extract.metagene.Rd +++ b/man/Extract.metagene.Rd @@ -1,9 +1,9 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/metagene-class.R \name{Extract.metagene} +\alias{Extract.metagene} \alias{$.metagene} \alias{$<-.metagene} -\alias{Extract.metagene} \alias{[.metagene} \title{Extract or replace data in a metagene object} \usage{ @@ -36,4 +36,3 @@ Other metagene: \code{\link{get_ntraits}}, \code{\link{get_pedigree}}, \code{\link{ngenerations}}, \code{\link{nindividuals}} } - diff --git a/man/additive_genetic.Rd b/man/additive_genetic.Rd index 2b9244c..a2aaecc 100644 --- a/man/additive_genetic.Rd +++ b/man/additive_genetic.Rd @@ -26,4 +26,3 @@ ped <- pedigreemm::pedigree(sire = c(NA,NA,1, 1,4,5), inc <- cbind(0, 0, diag(4)) breedR:::additive_genetic(ped, inc) } - diff --git a/man/additive_genetic_animal.Rd b/man/additive_genetic_animal.Rd index 54d2ddf..e637b2e 100644 --- a/man/additive_genetic_animal.Rd +++ b/man/additive_genetic_animal.Rd @@ -33,4 +33,3 @@ dat <- data.frame(id = 1:4, ped <- build_pedigree(1:3, data = dat) breedR:::additive_genetic_animal(ped, dat$id) } - diff --git a/man/additive_genetic_competition.Rd b/man/additive_genetic_competition.Rd index 16abbeb..c641e31 100644 --- a/man/additive_genetic_competition.Rd +++ b/man/additive_genetic_competition.Rd @@ -46,4 +46,3 @@ dat <- data.frame(id = 1:5, ped <- build_pedigree(1:3, data = dat) breedR:::additive_genetic_competition(ped, coord = dat[, c('x', 'y')], dat$id, 2) } - diff --git a/man/as.triplet.Rd b/man/as.triplet.Rd index 748b51d..3c4f021 100644 --- a/man/as.triplet.Rd +++ b/man/as.triplet.Rd @@ -13,4 +13,3 @@ as.triplet(x) It only gives the lower triangular elements, and **do not** check for symmetry. } - diff --git a/man/b.values.Rd b/man/b.values.Rd index 9322605..e513e62 100644 --- a/man/b.values.Rd +++ b/man/b.values.Rd @@ -12,4 +12,3 @@ b.values(x) \description{ Breeding values } - diff --git a/man/bispline_incidence.Rd b/man/bispline_incidence.Rd index 5821194..2a7aa16 100644 --- a/man/bispline_incidence.Rd +++ b/man/bispline_incidence.Rd @@ -31,4 +31,3 @@ Need at least 2*ord -1 knots (typically, 7) but in fact, we need at least temperature interaction using two-dimensional penalized signal regression. \emph{Chemometrics and Intelligent Laboratory Systems} 66(2), 159-174. } - diff --git a/man/breedR-package.Rd b/man/breedR-package.Rd index 5721743..dcf5ca2 100644 --- a/man/breedR-package.Rd +++ b/man/breedR-package.Rd @@ -2,8 +2,8 @@ % Please edit documentation in R/help.R \docType{package} \name{breedR-package} -\alias{breedR} \alias{breedR-package} +\alias{breedR} \title{Frequentist and Bayesian methods for breeders, quantitative geneticists and forest genetic resources analysts.} \description{ @@ -58,4 +58,3 @@ Traits}. Sinauer Associates, Inc. \code{\link[pedigreemm]{pedigreemm}} } \keyword{package} - diff --git a/man/breedR.get.HOME.Rd b/man/breedR.get.HOME.Rd index cca0d82..d1b55c9 100644 --- a/man/breedR.get.HOME.Rd +++ b/man/breedR.get.HOME.Rd @@ -10,4 +10,3 @@ breedR.get.HOME() Relies on \code{Sys.getenv('HOME')}, or under windows, on \code{Sys.getenv("USERPROFILE"))} changing backslashes to slashes. } - diff --git a/man/breedR.get.USER.Rd b/man/breedR.get.USER.Rd index 7c4094f..d1cb96c 100644 --- a/man/breedR.get.USER.Rd +++ b/man/breedR.get.USER.Rd @@ -9,4 +9,3 @@ breedR.get.USER() \description{ Determine the user name } - diff --git a/man/breedR.option.Rd b/man/breedR.option.Rd index 113a23c..1570c15 100644 --- a/man/breedR.option.Rd +++ b/man/breedR.option.Rd @@ -1,10 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/options.R \name{breedR.option} -\alias{breedR.getOption} \alias{breedR.option} +\alias{breedR.getOption} \alias{breedR.options} \alias{breedR.setOption} +\alias{breedR.setOption} \title{Set and get global options for breedR} \usage{ breedR.getOption(option = c("ar.eval", "breedR.bin", "splines.nok", @@ -26,7 +27,8 @@ parameters should be evaluated if not otherwise specified gives the number of knots (nok) to be used for a splines model, if not otherwise specified -\code{default.initial.variance}: a default value for all variance components +\code{default.initial.variance}: a function of the numeric response vector +or matrix which returns a default initial value for a variance component \code{col.seq}: a vector with the specification of default extreme breedR col for sequential scales in spatial quantitative plots. See Details. @@ -93,4 +95,3 @@ writeLines(c("remote.host = '123.45.678.999'", con = file.path(Sys.getenv('HOME'), '.breedRrc') } } - diff --git a/man/breedR.os.32or64bit.Rd b/man/breedR.os.32or64bit.Rd index bf254ae..7f0502f 100644 --- a/man/breedR.os.32or64bit.Rd +++ b/man/breedR.os.32or64bit.Rd @@ -12,4 +12,3 @@ Either "32" or "64" \description{ Give precedence to current R architecture } - diff --git a/man/breedR.os.Rd b/man/breedR.os.Rd index 41aa72d..71d0611 100644 --- a/man/breedR.os.Rd +++ b/man/breedR.os.Rd @@ -15,4 +15,3 @@ Identifies host operating system. \details{ Relies on \code{.Platform$OS.type}, but distinguishes between linux or mac. } - diff --git a/man/breedR.remote.Rd b/man/breedR.remote.Rd index 68e134b..17ae078 100644 --- a/man/breedR.remote.Rd +++ b/man/breedR.remote.Rd @@ -16,4 +16,3 @@ breedR.remote(jobid, breedR.call, verbose = TRUE) \description{ Assumes that all the relevant files are in the current directory. } - diff --git a/man/breedr_ar.Rd b/man/breedr_ar.Rd index a4baaf2..10b8996 100644 --- a/man/breedr_ar.Rd +++ b/man/breedr_ar.Rd @@ -30,4 +30,3 @@ Given the coordinates of the observations, the autocorrelation parameters and the autofill logical value, computes the incidence matrix B and the covariance matrix U } - diff --git a/man/breedr_blocks.Rd b/man/breedr_blocks.Rd index 50c8789..72e48fc 100644 --- a/man/breedr_blocks.Rd +++ b/man/breedr_blocks.Rd @@ -23,4 +23,3 @@ Given the coordinates of the observations, the *factor* identifying blocks, and the logical autofill, build the incidence and covariance matrices of a blocks model. } - diff --git a/man/breedr_effect.Rd b/man/breedr_effect.Rd index 8327140..690a647 100644 --- a/man/breedr_effect.Rd +++ b/man/breedr_effect.Rd @@ -2,12 +2,17 @@ % Please edit documentation in R/breedr_effect.R \name{breedr_effect} \alias{breedr_effect} -\title{Constructor for a generic effect} +\alias{dim.breedr_effect} +\title{Constructor for a generic breedR effect} \usage{ breedr_effect(incidence) + +\method{dim}{breedr_effect}(x) } \arguments{ \item{incidence}{matrix-like object} + +\item{x}{A \code{breedr_effect}.} } \value{ A list with a single element \code{incidence.matrix}. @@ -21,4 +26,3 @@ subclasses like generic, diagonal, spatial or additive_genetic. This constructor performs the arguments checks. But the implementation details (i.e., storage format and handling) is left for the subclasses. } - diff --git a/man/breedr_progsf90_repo.Rd b/man/breedr_progsf90_repo.Rd index c40f478..2265b9a 100644 --- a/man/breedr_progsf90_repo.Rd +++ b/man/breedr_progsf90_repo.Rd @@ -9,4 +9,3 @@ breedr_progsf90_repo() \description{ Default repository for PROGSF90 binaries } - diff --git a/man/breedr_splines.Rd b/man/breedr_splines.Rd index 45e2749..f06e228 100644 --- a/man/breedr_splines.Rd +++ b/man/breedr_splines.Rd @@ -46,4 +46,3 @@ with. This is probably convenient only for really big datasets in comparison with RAM size. The covariance matrix is always stored in sparse format, as it is particularly sparse. } - diff --git a/man/build_grid.Rd b/man/build_grid.Rd index 9077441..801ae90 100644 --- a/man/build_grid.Rd +++ b/man/build_grid.Rd @@ -29,4 +29,3 @@ Build the minimal regularly-spaced grid containing a given set of points. Note that \code{autofill = FALSE} virtually removes the empty lines, considering the spacing as constant. } - diff --git a/man/build_pedigree.Rd b/man/build_pedigree.Rd index 34a643a..9f5df6e 100644 --- a/man/build_pedigree.Rd +++ b/man/build_pedigree.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/pedigree.R \name{build_pedigree} -\alias{as.data.frame.pedigree} \alias{build_pedigree} +\alias{as.data.frame.pedigree} \title{Build pedigree} \usage{ build_pedigree(x, self = x[[1]], sire = x[[2]], dam = x[[3]], data) @@ -51,6 +51,7 @@ map)} back-transforms to original codes. the first column being the identification code, and the other two columns are dad and mum codes respectively. }} + \examples{ # Founders are missing in the globulus dataset data(globulus) @@ -62,4 +63,3 @@ check_pedigree(ped) \seealso{ \code{\link{check_pedigree}} } - diff --git a/man/check_pedigree.Rd b/man/check_pedigree.Rd index ef65ab3..79d52d6 100644 --- a/man/check_pedigree.Rd +++ b/man/check_pedigree.Rd @@ -58,4 +58,3 @@ check_pedigree(build_pedigree(1:3, data = ped_notconsec)) \seealso{ \code{\link{build_pedigree}} } - diff --git a/man/check_progsf90.Rd b/man/check_progsf90.Rd index 0a011fe..abc64e6 100644 --- a/man/check_progsf90.Rd +++ b/man/check_progsf90.Rd @@ -25,4 +25,3 @@ This function does not check whether the binaries are for the right platform or architecture. It only checks the presence of files with the expected names. } - diff --git a/man/check_var.ini.Rd b/man/check_var.ini.Rd new file mode 100644 index 0000000..e92908b --- /dev/null +++ b/man/check_var.ini.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checks.R +\name{check_var.ini} +\alias{check_var.ini} +\title{Check initial variances specification} +\usage{ +check_var.ini(x, random, response) +} +\arguments{ +\item{x}{list. user specification of var.ini (or NULL)} + +\item{random}{formula. user specification of random effects.} + +\item{response}{numeric vector or matrix.} +} +\value{ +A list with initial covariance matrices for all random effects in the + model. A logical attribute `var.ini.default` is TRUE if values were set by + default. + +matrix of observation values. +} +\description{ +If the user specified initial values, verify that all random effects were +included. Otherwise, set default values. In any case, validate all initial +values. +} diff --git a/man/compare.plots.Rd b/man/compare.plots.Rd index e594053..841d853 100644 --- a/man/compare.plots.Rd +++ b/man/compare.plots.Rd @@ -7,12 +7,12 @@ compare.plots(plots) } \arguments{ -\item{plots}{List of ggplots with meaningful names - -The names of the objects in the list will be used for facet labels.} +\item{plots}{List of ggplots with meaningful names} } \description{ This function presents several ggplots of the same type side by side under the same scale, while keeping annotations. } - +\details{ +The names of the objects in the list will be used for facet labels. +} diff --git a/man/competition.Rd b/man/competition.Rd index e58b7d5..48930d7 100644 --- a/man/competition.Rd +++ b/man/competition.Rd @@ -44,4 +44,3 @@ Weighted Neighbour Competition effect over one's phenotype is given by constant which makes \eqn{Var(wnc) = \sigma_{a_c}^2} and independent of the number of neighbours. } - diff --git a/man/coordinates_breedR.Rd b/man/coordinates_breedR.Rd index 78f6682..d171864 100644 --- a/man/coordinates_breedR.Rd +++ b/man/coordinates_breedR.Rd @@ -2,13 +2,13 @@ % Please edit documentation in R/coordinates.R, R/metagene-class.R \docType{methods} \name{coordinates_breedR} +\alias{coordinates_breedR} \alias{coordinates,breedR-method} +\alias{coordinates<-,breedR-method} \alias{coordinates,effect_group-method} -\alias{coordinates,metagene-method} \alias{coordinates,spatial-method} -\alias{coordinates<-,breedR-method} +\alias{coordinates,metagene-method} \alias{coordinates<-,metagene-method} -\alias{coordinates_breedR} \title{breedR coordinates methods} \usage{ \S4method{coordinates}{breedR}(obj, ...) @@ -35,4 +35,3 @@ \description{ breedR coordinates methods } - diff --git a/man/default_initial_variance.Rd b/man/default_initial_variance.Rd new file mode 100644 index 0000000..e265744 --- /dev/null +++ b/man/default_initial_variance.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/options.R +\name{default_initial_variance} +\alias{default_initial_variance} +\title{Default initial value for variance components} +\usage{ +default_initial_variance(x, dim = 1, cor.trait = NULL, cor.effect = 0.1, + digits = NULL) +} +\arguments{ +\item{x}{numeric vector or matrix with the phenotypic observations. Each +trait in one column.} + +\item{dim}{integer. dimension of the random effect for each trait. Default is +1.} + +\item{cor.trait}{a number strictly in (-1, 1). The initial value for the +correlation across traits. Default is NULL, which makes the function to +take the value from the data. See Details.} + +\item{cor.effect}{a number strictly in (0, 1). The initial value for the +correlation across the different dimensions of the random effect. Default +is 0.1.} + +\item{digits}{numeric. If not NULL (as default), the resulting matrix is rounded up +to 2 significant digits.} +} +\description{ +A function of the response vector or matrix (multi-trait case) returning a +SPD matrix of conforming dimensions. +} +\details{ +The default initial covariance matrix across traits is computed as half the +empirical covariance kronecker times a Positive-Definite matrix with Compound +Symmetry Structure with a constant diagonal with value 1 and constant +off-diagonal elements with the positive value given by \code{cor.effect}, +i.e. \deqn{\Sigma = Var(x)/2 \%*\% \psi(dim).} This implies that the default +initial \strong{correlations} across traits equal the empirical correlations, +except if \code{cor.trait} is not \code{NULL}. + +\eqn{\psi(dim)} is intendend to model correlated random effects within +traits, and only has an effect when \code{dim} > 1. + +If any column in \code{x} is constant (i.e. empirical variance of 0) then the +function stops. It is better to remove this trait from the analysis. +} +\examples{ + ## Initial covariance matrix for a bidimensional random effect + ## acting independently over three traits + x <- cbind(rnorm(100, sd = 1), rnorm(100, sd = 2), rnorm(100, sd = 3)) + breedR:::default_initial_variance(x, dim = 2, cor.effect = 0.5) +} diff --git a/man/determine.n.knots.Rd b/man/determine.n.knots.Rd index 5071417..eaca888 100644 --- a/man/determine.n.knots.Rd +++ b/man/determine.n.knots.Rd @@ -26,4 +26,3 @@ basis of unidimensional B-splines splines. \emph{Journal of Computational and Graphical Statistics} 11, 735–757. } - diff --git a/man/diagonal.Rd b/man/diagonal.Rd index 4761101..669eecc 100644 --- a/man/diagonal.Rd +++ b/man/diagonal.Rd @@ -22,4 +22,3 @@ Uses sparse storage. It does not support nesting (yet). So it is not possible to build random regression coefficients for each level of a grouping factor. This is in the TODO list. } - diff --git a/man/distribute_knots_uniformgrid.Rd b/man/distribute_knots_uniformgrid.Rd index 72a533f..676d8e0 100644 --- a/man/distribute_knots_uniformgrid.Rd +++ b/man/distribute_knots_uniformgrid.Rd @@ -25,4 +25,3 @@ The margin is calculated as half the median separation between observations. Furthermore, three more knots are added with equal spacing at each side, for each dimension. } - diff --git a/man/douglas.Rd b/man/douglas.Rd index f1387b7..630e3b0 100644 --- a/man/douglas.Rd +++ b/man/douglas.Rd @@ -57,4 +57,3 @@ ggplot(douglas, aes(x, y)) + facet_wrap(~ site) } - diff --git a/man/effect_group.Rd b/man/effect_group.Rd index 0215bd8..5f6fe7b 100644 --- a/man/effect_group.Rd +++ b/man/effect_group.Rd @@ -2,14 +2,19 @@ % Please edit documentation in R/breedr_effect.R \name{effect_group} \alias{effect_group} +\alias{dim.effect_group} \title{Constructor for a group of effects} \usage{ -effect_group(x, cov.ini) +effect_group(x, cov.ini, ntraits) + +\method{dim}{effect_group}(x) } \arguments{ \item{x}{list of breedr_effect elements} \item{cov.ini}{initial covariance matrix for the estimation algorithm} + +\item{ntraits}{number of traits in the model} } \value{ A list of \code{breedr_effect} elements. @@ -21,5 +26,6 @@ Builds an \code{effect_group} from a list of \code{breer_effect} elements. Temporarily, this takes the \code{cov.ini} argument and includes it in the object. In the future, the initial covariance matrix will be a matter of the inference engine, not inherent to the model. -} +The `ntraits` is used to check the dimension of the initial variance matrix. +} diff --git a/man/effect_size.Rd b/man/effect_size.Rd deleted file mode 100644 index b6d1d7a..0000000 --- a/man/effect_size.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGeneric.R, R/effect_size.R -\name{effect_size} -\alias{effect_size} -\alias{effect_size.breedr_effect} -\alias{effect_size.effect_group} -\title{Size of a (group of) effect(s)} -\usage{ -effect_size(x) - -\method{effect_size}{effect_group}(x) - -\method{effect_size}{breedr_effect}(x) -} -\arguments{ -\item{x}{element of the breedr_modelframe} -} -\description{ -Returns 0 for a \code{fixed} effect, and the size of a \code{effect_group} -} -\section{Methods (by class)}{ -\itemize{ -\item \code{effect_group}: Size of an \code{effect_group} - -\item \code{breedr_effect}: Size of an \code{breedr_effect} -}} - diff --git a/man/effect_type.Rd b/man/effect_type.Rd index 8ea9bc7..3e7716c 100644 --- a/man/effect_type.Rd +++ b/man/effect_type.Rd @@ -2,8 +2,8 @@ % Please edit documentation in R/AllGeneric.R, R/effect_type.R \name{effect_type} \alias{effect_type} -\alias{effect_type.breedr_effect} \alias{effect_type.effect_group} +\alias{effect_type.breedr_effect} \title{Type of a (group of) effect(s)} \usage{ effect_type(x) diff --git a/man/fill_holes.Rd b/man/fill_holes.Rd index ceeb8ee..6bc47fd 100644 --- a/man/fill_holes.Rd +++ b/man/fill_holes.Rd @@ -14,4 +14,3 @@ fill_holes(x, label) \description{ Find and fill all the holes in a vector } - diff --git a/man/fixed.Rd b/man/fixed.Rd index 29d9bbc..97ae2cf 100644 --- a/man/fixed.Rd +++ b/man/fixed.Rd @@ -15,4 +15,3 @@ A breedr_effect with element \code{incidence.matrix}. \description{ Constructor for a fixed effect } - diff --git a/man/fixef.Rd b/man/fixef.Rd index 23fc16a..2adbca2 100644 --- a/man/fixef.Rd +++ b/man/fixef.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/remlf90-class.R \name{fixef} -\alias{fixed.effects} \alias{fixef} -\alias{fixef.breedR} \alias{fixef.remlf90} +\alias{fixed.effects} +\alias{fixef.breedR} \title{Extract fixed-effects estimates} \usage{ \method{fixef}{remlf90}(object, ...) @@ -30,4 +30,3 @@ Extract the estimates of the fixed-effects parameters from a fitted model. fixef(res) } \keyword{models} - diff --git a/man/generic.Rd b/man/generic.Rd index 111ce44..05b7776 100644 --- a/man/generic.Rd +++ b/man/generic.Rd @@ -25,4 +25,3 @@ Check conformity of arguments and return a \code{generic} object. A generic random effect stores the incidence and structure matrices in Matrix form, which tries to take advantage of sparsity, if it exists. } - diff --git a/man/genetic.Rd b/man/genetic.Rd index 58d086c..533c264 100644 --- a/man/genetic.Rd +++ b/man/genetic.Rd @@ -26,4 +26,3 @@ Check conformity of arguments and return a \code{genetic} object. \details{ This is a virtual class. No objects are expected to be created directly. } - diff --git a/man/get_efnames.Rd b/man/get_efnames.Rd index 55748b8..1a00634 100644 --- a/man/get_efnames.Rd +++ b/man/get_efnames.Rd @@ -13,4 +13,3 @@ get_efnames(effects) Give the names of the (components) of the effects in a breedr_modelframe. Internal function. Not exported. } - diff --git a/man/get_ntraits.Rd b/man/get_ntraits.Rd index b0db27d..46837c9 100644 --- a/man/get_ntraits.Rd +++ b/man/get_ntraits.Rd @@ -19,4 +19,3 @@ Other metagene: \code{\link{Extract.metagene}}, \code{\link{get_pedigree}}, \code{\link{ngenerations}}, \code{\link{nindividuals}} } - diff --git a/man/get_param.Rd b/man/get_param.Rd index 979592f..94869b9 100644 --- a/man/get_param.Rd +++ b/man/get_param.Rd @@ -2,9 +2,9 @@ % Please edit documentation in R/AllGeneric.R, R/get_param.R \name{get_param} \alias{get_param} +\alias{get_param.remlf90} \alias{get_param.breedr_modelframe} \alias{get_param.effect_group} -\alias{get_param.remlf90} \alias{get_param.spatial} \title{Parameters of a breedR component} \usage{ diff --git a/man/get_pedigree.Rd b/man/get_pedigree.Rd index a4843dd..bb46ef8 100644 --- a/man/get_pedigree.Rd +++ b/man/get_pedigree.Rd @@ -2,11 +2,11 @@ % Please edit documentation in R/AllGeneric.R, R/get_pedigree.R \name{get_pedigree} \alias{get_pedigree} +\alias{get_pedigree.metagene} +\alias{get_pedigree.remlf90} \alias{get_pedigree.breedr_modelframe} \alias{get_pedigree.effect_group} \alias{get_pedigree.genetic} -\alias{get_pedigree.metagene} -\alias{get_pedigree.remlf90} \title{Get the Pedigree from an object} \usage{ get_pedigree(x, ...) @@ -43,6 +43,7 @@ Internal function. \item \code{genetic}: Get the pedigree from a \code{genetic} object }} + \references{ \code{\link[pedigreemm]{pedigree-class}} from package \code{pedigreemm} @@ -52,4 +53,3 @@ Other metagene: \code{\link{Extract.metagene}}, \code{\link{get_ntraits}}, \code{\link{ngenerations}}, \code{\link{nindividuals}} } - diff --git a/man/get_structure.Rd b/man/get_structure.Rd index ed38ae4..dcdcca0 100644 --- a/man/get_structure.Rd +++ b/man/get_structure.Rd @@ -3,8 +3,8 @@ \name{get_structure} \alias{get_structure} \alias{get_structure.breedR} -\alias{get_structure.breedr_effect} \alias{get_structure.effect_group} +\alias{get_structure.breedr_effect} \title{Covariance structure of a breedR component} \usage{ get_structure(x) @@ -30,7 +30,8 @@ in the group. \itemize{ \item \code{breedR}: Return the structure matrices of all structured random effects -\item \code{effect_group}: Check that all elements share the same structure and return it. +\item \code{effect_group}: Check that all elements share the same structure +and return it. \item \code{breedr_effect}: Return the structure matrix with an attribute indicating its \code{type}. diff --git a/man/globulus.Rd b/man/globulus.Rd index dc92cca..3350dbb 100644 --- a/man/globulus.Rd +++ b/man/globulus.Rd @@ -25,4 +25,3 @@ The plantation is gridded with a separation of 3 m. \examples{ data(globulus) } - diff --git a/man/group_size.Rd b/man/group_size.Rd deleted file mode 100644 index 5cc1f93..0000000 --- a/man/group_size.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/breedr_effect.R -\name{group_size} -\alias{group_size} -\title{Size of a group of effects} -\usage{ -group_size(x) -} -\arguments{ -\item{x}{object of class \code{effect_group}} -} -\description{ -Size of a group of effects -} - diff --git a/man/install_progsf90.Rd b/man/install_progsf90.Rd index 969164f..017f034 100644 --- a/man/install_progsf90.Rd +++ b/man/install_progsf90.Rd @@ -27,4 +27,3 @@ Copy the binaries for the specified platform into a directory. \details{ The url can be either of form http:// or of form file:// for local urls. } - diff --git a/man/larix.Rd b/man/larix.Rd index 505a91a..34b3b87 100644 --- a/man/larix.Rd +++ b/man/larix.Rd @@ -53,4 +53,3 @@ if (require(GGally)) { ggpairs(larix[, c('map', 'mat', 'mi', 'LAS', 'DOS')]) } } - diff --git a/man/loc_grid.Rd b/man/loc_grid.Rd index 4d2af75..e43c0ed 100644 --- a/man/loc_grid.Rd +++ b/man/loc_grid.Rd @@ -25,4 +25,3 @@ list of row and column coordinates of spatial units \description{ Returns a list row and column coordinates of observations } - diff --git a/man/m1.Rd b/man/m1.Rd index 3565acd..7dfa6b9 100644 --- a/man/m1.Rd +++ b/man/m1.Rd @@ -32,4 +32,3 @@ The 1600 descendants were arranged at random in a \eqn{40\times 40}{40 x 40} spa qplot(BV_X, phe_X-BV_X, colour = dad, data = as.data.frame(m1)) + geom_abline(intercept=0, slope=0, col='gray') } - diff --git a/man/m4.Rd b/man/m4.Rd index 04ecd3a..f8e4310 100644 --- a/man/m4.Rd +++ b/man/m4.Rd @@ -34,4 +34,3 @@ The 6400 individuals from generations 1 to 4 were arranged at random in a \eqn{8 qplot(BV_X, phe_X-BV_X, facets = .~gen, data = as.data.frame(m4)) + geom_abline(intercept=0, slope=0, col='gray') } - diff --git a/man/neighbours.at.Rd b/man/neighbours.at.Rd index 01b9cfb..6a70a48 100644 --- a/man/neighbours.at.Rd +++ b/man/neighbours.at.Rd @@ -2,8 +2,8 @@ % Please edit documentation in R/AllGeneric.R, R/neighbours.at.R \name{neighbours.at} \alias{neighbours.at} -\alias{neighbours.at.list} \alias{neighbours.at.matrix} +\alias{neighbours.at.list} \title{'move' an arrangement in a given direction} \usage{ neighbours.at(x, dir) diff --git a/man/ngenerations.Rd b/man/ngenerations.Rd index 97f8e78..28156c9 100644 --- a/man/ngenerations.Rd +++ b/man/ngenerations.Rd @@ -19,4 +19,3 @@ Other metagene: \code{\link{Extract.metagene}}, \code{\link{get_ntraits}}, \code{\link{get_pedigree}}, \code{\link{nindividuals}} } - diff --git a/man/nindividuals.Rd b/man/nindividuals.Rd index f6d963a..b5f5f82 100644 --- a/man/nindividuals.Rd +++ b/man/nindividuals.Rd @@ -19,4 +19,3 @@ Other metagene: \code{\link{Extract.metagene}}, \code{\link{get_ntraits}}, \code{\link{get_pedigree}}, \code{\link{ngenerations}} } - diff --git a/man/normalise_coordinates.Rd b/man/normalise_coordinates.Rd index 2879134..32782d7 100644 --- a/man/normalise_coordinates.Rd +++ b/man/normalise_coordinates.Rd @@ -18,4 +18,3 @@ a two-column data.frame, with numeric values. \description{ If checks succeed, returns a complete normalised specification. } - diff --git a/man/parse.txtmat.Rd b/man/parse.txtmat.Rd new file mode 100644 index 0000000..1ac23c6 --- /dev/null +++ b/man/parse.txtmat.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/progsf90.R +\name{parse.txtmat} +\alias{parse.txtmat} +\title{Parse a matrix from a text output robustly} +\usage{ +parse.txtmat(x, names = NULL, square = TRUE) +} +\arguments{ +\item{x}{A character vector with space-separated numbers} + +\item{names}{A character vector with row and column names for the output matrix.} + +\item{square}{logical. Whether to assume that the matrix is square. + +If the matrix is not necessarily} +} +\description{ +Each row of the matrix is a string. If rows are too long, they can continue +in another line. Hence, the number of lines might be a multiple of the number +of columns +} diff --git a/man/permanent_environmental_competition.Rd b/man/permanent_environmental_competition.Rd index 30fae0b..fc24eb9 100644 --- a/man/permanent_environmental_competition.Rd +++ b/man/permanent_environmental_competition.Rd @@ -33,4 +33,3 @@ dat <- data.frame(id = 1:5, y = c(rep(1:2, each = 2), 3)) breedR:::permanent_environmental_competition(coord = dat[, c('x', 'y')], decay = 2) } - diff --git a/man/pf90_code_missing.Rd b/man/pf90_code_missing.Rd index efd48d5..69e60b2 100644 --- a/man/pf90_code_missing.Rd +++ b/man/pf90_code_missing.Rd @@ -23,4 +23,3 @@ observed values. E.g., for observations in the range -40 -- 28, the code is \examples{ breedR:::pf90_code_missing(rnorm(100)) } - diff --git a/man/pf90_default_heritability.Rd b/man/pf90_default_heritability.Rd index ba2c532..ac67ebb 100644 --- a/man/pf90_default_heritability.Rd +++ b/man/pf90_default_heritability.Rd @@ -4,25 +4,26 @@ \alias{pf90_default_heritability} \title{Default formula for heritability} \usage{ -pf90_default_heritability(rglist, quiet = FALSE) +pf90_default_heritability(rglist, traits = NULL, quiet = FALSE) } \arguments{ \item{rglist}{list of random groups in the parameters of a \code{\link{progsf90}} object} +\item{traits}{A character vector with trait names, or NULL for single trait.} + \item{quiet}{logical. If FALSE, the function issues a message when it fails to build a formula.} } +\value{ +A character vector with one option specification per trait. +} \description{ If all random effects are independent, and there is an additive-genetic effect, computes a default formula in PROGSF90 notation by dividing the genetic variance by the sum of all variance components plus the residual variance. } -\details{ -Assumes only one trait. -} \references{ http://nce.ads.uga.edu/wiki/doku.php?id=readme.aireml#options } - diff --git a/man/plot.remlf90.Rd b/man/plot.remlf90.Rd index 8f207be..1fc5be9 100644 --- a/man/plot.remlf90.Rd +++ b/man/plot.remlf90.Rd @@ -20,4 +20,3 @@ coordinates. Overrides \code{type}.} \description{ Plots the predicted values of the component effects of the phenotype. } - diff --git a/man/progsf90.Rd b/man/progsf90.Rd index efd1707..46ca192 100644 --- a/man/progsf90.Rd +++ b/man/progsf90.Rd @@ -22,4 +22,3 @@ This function parses a model frame and extracts the relevant fields that are to be written in the parameter, data and auxiliary files of the progsf90 programs. } - diff --git a/man/random.Rd b/man/random.Rd index f7e6760..0067010 100644 --- a/man/random.Rd +++ b/man/random.Rd @@ -28,4 +28,3 @@ This constructor performs the arguments and conformance checks. But the implementation details (i.e., storage format and handling) is left for the subclasses. } - diff --git a/man/ranef.Rd b/man/ranef.Rd index c5cdb63..10a7c8d 100644 --- a/man/ranef.Rd +++ b/man/ranef.Rd @@ -2,8 +2,8 @@ % Please edit documentation in R/remlf90-class.R \name{ranef} \alias{ranef} -\alias{ranef.breedR} \alias{ranef.remlf90} +\alias{ranef.breedR} \title{Extract the modes of the random effects} \usage{ \method{ranef}{remlf90}(object, ...) @@ -15,9 +15,9 @@ \item{...}{not used} } \value{ -An object of class \code{ranef.breedR} composed of a list of vectors, - one for each random effect. The length of the vectors are the number of - levels of the corresponding random effect. +An object of class \code{ranef.breedR} composed of a list of vectors + or matrices (multitrait case), one for each random effect. The length of + the vectors are the number of levels of the corresponding random effect. Each random effect has an attribute called \code{"se"} which is a vector with the standard errors. @@ -49,4 +49,3 @@ res <- remlf90(phe_X ~ bl, str(rr <- ranef(res)) plot(rr) } - diff --git a/man/read.metagene.Rd b/man/read.metagene.Rd index 5b0c5cc..05618c5 100644 --- a/man/read.metagene.Rd +++ b/man/read.metagene.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/metagene-class.R \name{read.metagene} -\alias{as.data.frame.metagene} -\alias{get_ntraits.metagene} +\alias{read.metagene} \alias{metagene} +\alias{summary.metagene} +\alias{print.summary.metagene} +\alias{plot.metagene} +\alias{get_ntraits.metagene} \alias{ngenerations.metagene} \alias{nindividuals.metagene} -\alias{plot.metagene} -\alias{print.summary.metagene} -\alias{read.metagene} -\alias{summary.metagene} +\alias{as.data.frame.metagene} \title{Metagene Data Input} \usage{ read.metagene(fname) @@ -84,7 +84,7 @@ spatial component of the phenotype. Pass further \item \code{as.data.frame}: Coerce to a data.frame }} + \references{ \url{http://www.igv.fi.cnr.it/noveltree/} } - diff --git a/man/remlf90.Rd b/man/remlf90.Rd index d5f983f..32433b5 100644 --- a/man/remlf90.Rd +++ b/man/remlf90.Rd @@ -319,4 +319,3 @@ progsf90 wiki page: \url{http://nce.ads.uga.edu/wiki/doku.php} \seealso{ \code{\link[pedigreemm]{pedigree}} } - diff --git a/man/remote.Rd b/man/remote.Rd index a3cf915..7a2071b 100644 --- a/man/remote.Rd +++ b/man/remote.Rd @@ -1,15 +1,19 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/remote.R \name{remote} -\alias{breedR.qdel} +\alias{remote} \alias{breedR.qget} -\alias{breedR.qnuke} \alias{breedR.qstat} -\alias{breedR.remote_load} +\alias{breedR.qdel} +\alias{breedR.qnuke} +\alias{summary.breedR.q} \alias{print.breedR.q} -\alias{remote} +\alias{breedR.remote_load} \alias{submit} -\alias{summary.breedR.q} +\alias{breedR.qdel} +\alias{breedR.qstat} +\alias{breedR.qnuke} +\alias{breedR.remote_load} \title{Control and view a remote breedR-queue of submitted jobs} \usage{ breedR.qget(id, remove = TRUE) @@ -81,6 +85,7 @@ Control and view a remote breedR-queue of submitted jobs \code{remote.bin}. You can permanently set these options in the file \code{.breedRrc} in your home directory. See ?\code{breedR.setOption}. } + \examples{ \dontrun{ r = remlf90(y~1, data = data.frame(y=rnorm(10)), breedR.bin = "submit") @@ -95,4 +100,3 @@ summary(r) # results of the analysis \seealso{ \code{\link{remlf90}} } - diff --git a/man/renderpf90.Rd b/man/renderpf90.Rd index c9e54c7..321e886 100644 --- a/man/renderpf90.Rd +++ b/man/renderpf90.Rd @@ -2,18 +2,18 @@ % Please edit documentation in R/AllGeneric.R, R/renderpf90.R \name{renderpf90} \alias{renderpf90} -\alias{renderpf90.additive_genetic_animal} -\alias{renderpf90.additive_genetic_competition} -\alias{renderpf90.ar} -\alias{renderpf90.blocks} -\alias{renderpf90.breedr_modelframe} \alias{renderpf90.default} +\alias{renderpf90.fixed} \alias{renderpf90.diagonal} +\alias{renderpf90.breedr_modelframe} \alias{renderpf90.effect_group} -\alias{renderpf90.fixed} \alias{renderpf90.generic} +\alias{renderpf90.additive_genetic_animal} +\alias{renderpf90.additive_genetic_competition} \alias{renderpf90.permanent_environmental_competition} \alias{renderpf90.splines} +\alias{renderpf90.blocks} +\alias{renderpf90.ar} \title{Render a progsf90 effect} \usage{ renderpf90(x) @@ -24,7 +24,7 @@ renderpf90(x) \method{renderpf90}{diagonal}(x) -\method{renderpf90}{breedr_modelframe}(x, ntraits) +\method{renderpf90}{breedr_modelframe}(x, ntraits, weights) \method{renderpf90}{effect_group}(x) @@ -46,6 +46,8 @@ renderpf90(x) \item{x}{object of class breedr_modelframe, effect_group or breedr_effect.} \item{ntraits}{integer. Number of traits in the model.} + +\item{weights}{logical. Whether there is an additional column of weights.} } \value{ The number of levels and type for each 'virtual' effect; the progsf90 @@ -107,7 +109,7 @@ a blocks effect. \item \code{ar}: Compute the parameters of a progsf90 representation of an AR effect. }} + \seealso{ Other renderpf90: \code{\link{renderpf90.matrix}} } - diff --git a/man/renderpf90.matrix.Rd b/man/renderpf90.matrix.Rd index a406e25..eda283b 100644 --- a/man/renderpf90.matrix.Rd +++ b/man/renderpf90.matrix.Rd @@ -29,4 +29,3 @@ index. The gaps are filled with zeros. \seealso{ Other renderpf90: \code{\link{renderpf90}} } - diff --git a/man/retrieve_remote.Rd b/man/retrieve_remote.Rd index 993359d..326ebd6 100644 --- a/man/retrieve_remote.Rd +++ b/man/retrieve_remote.Rd @@ -15,4 +15,3 @@ dir name where the results are retrieved \description{ Use scp to transfer compressed files. Clean up afterwards. } - diff --git a/man/sim.spatial.Rd b/man/sim.spatial.Rd index 34d784d..9354142 100644 --- a/man/sim.spatial.Rd +++ b/man/sim.spatial.Rd @@ -39,4 +39,3 @@ heritability. The spatial unit is the distance between consecutive trees. } - diff --git a/man/simulation.Rd b/man/simulation.Rd index 2bf90c9..a1762de 100644 --- a/man/simulation.Rd +++ b/man/simulation.Rd @@ -1,12 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/simulation.R \name{simulation} +\alias{simulation} +\alias{breedR.sample.phenotype} \alias{breedR.sample.AR} +\alias{breedR.sample.splines} \alias{breedR.sample.BV} \alias{breedR.sample.pedigree} -\alias{breedR.sample.phenotype} -\alias{breedR.sample.splines} -\alias{simulation} +\alias{breedR.sample.ranef} \title{Simulation of phenotypes and model components} \usage{ breedR.sample.phenotype(fixed = NULL, random = NULL, genetic = NULL, @@ -19,6 +20,9 @@ breedR.sample.splines(coord, nkn, sigma2, N = 1) breedR.sample.BV(ped, Sigma, N = 1) breedR.sample.pedigree(Nobs, Nparents, check.factorial = TRUE) + +breedR.sample.ranef(dim, var, Nlevels, labels = NULL, N = Nlevels, + vname = "X") } \arguments{ \item{fixed}{a numeric vector of regression coefficients.} @@ -66,6 +70,16 @@ randomly mate.} \item{check.factorial}{logical. If TRUE (default), it checks whether all the possible matings had taken place at least once. If not, it stops with an error.} + +\item{dim}{numeric. Dimension of the effect (e.g. n. of traits)} + +\item{var}{numeric matrix. (Co)variance matrix} + +\item{Nlevels}{numeric. Number of individuals values to sample} + +\item{labels}{character vector of labels for each level.} + +\item{vname}{string. A name for the resulting variables} } \description{ These functions allow to draw samples from several models @@ -143,6 +157,9 @@ The design matrix for the \code{fixed} effects (if given) is a from random mating of independent founders. Note that if \code{check.factorial} is \code{FALSE}, you can have some founders removed from the pedigree. + +\code{breedR.sample.ranef} simulates a random effect with a given + variance. } \examples{ @@ -159,4 +176,3 @@ breedR.sample.phenotype(fixed = c(mu = 10, x = 2), sigma2_s = 1), residual.variance = 1) } - diff --git a/man/spatial.Rd b/man/spatial.Rd index 5ff8923..32ddc95 100644 --- a/man/spatial.Rd +++ b/man/spatial.Rd @@ -24,4 +24,3 @@ A list with elements \code{coordinates}, \code{incidence.matrix}, \description{ Check conformity of arguments and return a \code{spatial} object. } - diff --git a/man/spatial.plot.Rd b/man/spatial.plot.Rd index 4a34cd3..68b05e1 100644 --- a/man/spatial.plot.Rd +++ b/man/spatial.plot.Rd @@ -16,4 +16,3 @@ with different colours. 'sequential' uses a gradient scale of two colours.} \description{ Plot an spatially arranged continuous variable } - diff --git a/man/splat.Rd b/man/splat.Rd new file mode 100644 index 0000000..aa39bb7 --- /dev/null +++ b/man/splat.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{splat} +\alias{splat} +\title{'Splat' arguments to a function} +\usage{ +splat(flat) +} +\arguments{ +\item{flat}{function to splat + +This is useful when you want to pass a function a row of data frame or array, +and don't want to manually pull it apart in your function. + +Borrowed from \code{\link[plyr]{splat}}} +} +\value{ +a function +} +\description{ +Wraps a function in do.call, so instead of taking multiple arguments, it +takes a single named list which will be interpreted as its arguments. +} +\examples{ + args <- replicate(3, runif(5), simplify = FALSE) + identical(breedR:::splat(rbind)(args), do.call(rbind, args)) +} diff --git a/man/validate_variance.Rd b/man/validate_variance.Rd index efa821e..f1e8a50 100644 --- a/man/validate_variance.Rd +++ b/man/validate_variance.Rd @@ -15,9 +15,8 @@ validate_variance(x, dimension = dim(as.matrix(x)), where = "") error messages only. E.g. \code{where = 'competition specification'}.} } \value{ -\code{TRUE} is all checks pass +\code{TRUE} if all checks pass } \description{ Check properties for a covariance matrix } - diff --git a/man/variogram.Rd b/man/variogram.Rd index 7c044fa..2266b1a 100644 --- a/man/variogram.Rd +++ b/man/variogram.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/variogram.R \name{variogram} -\alias{print.breedR.variogram} \alias{variogram} +\alias{print.breedR.variogram} \title{Empirical variograms of residuals} \usage{ variogram(x, plot = c("all", "isotropic", "anisotropic", "perspective", @@ -57,6 +57,7 @@ spatial-temporal variogram be fitted? \itemize{ \item \code{print}: Print a breedR variogram }} + \examples{ data(globulus) @@ -102,4 +103,3 @@ variogram(res.sp, z = PBV) \seealso{ \code{\link[fields]{vgram.matrix}} } - diff --git a/man/vcov.remlf90.Rd b/man/vcov.remlf90.Rd index bc6dcf2..f9ce63e 100644 --- a/man/vcov.remlf90.Rd +++ b/man/vcov.remlf90.Rd @@ -17,4 +17,3 @@ \description{ Returns the variance-covariance matrix of the specified random effect. } - diff --git a/man/vgram.matrix.Rd b/man/vgram.matrix.Rd index 43b8776..7a52d1f 100644 --- a/man/vgram.matrix.Rd +++ b/man/vgram.matrix.Rd @@ -25,4 +25,3 @@ Copyright 2004-2013, Institute for Mathematics Applied Geosciences University Corporation for Atmospheric Research Licensed under the GPL -- www.gpl.org/licenses/gpl.html } - diff --git a/tests/integration/helper-testdata.R b/tests/integration/helper-testdata.R new file mode 100644 index 0000000..d4b1556 --- /dev/null +++ b/tests/integration/helper-testdata.R @@ -0,0 +1,72 @@ +# Generate (or update) testdata used by unit tests +message("Generating test data ...") + +## target directory +testdata <- system.file("testdata", package = "breedR") + + +#### fitted models #### + +res <- suppressMessages( + list( + ## A simple model with one fixed effect + fixonly = remlf90( + fixed = phe_X ~ gg, + data = globulus + ), + ## A spatial blocks model + blk = remlf90( + fixed = phe_X ~ 1, + spatial = list( + model = 'blocks', + coord = globulus[, c('x','y')], + id = 'bl' + ), + data = globulus + ), + ## An spatial autoregressive model with one random effect + ar = remlf90( + fixed = phe_X ~ 1, + random = ~ gg, + spatial = list( + model = 'AR', + coord = globulus[, c('x','y')], + rho = c(.85, .8) + ), + data = globulus + ), + ## An spatial splines (2x2 knots) model fitted with EM + spl = remlf90( + fixed = phe_X ~ 1, + spatial = list( + model = 'splines', + coord = globulus[, c('x','y')], + n.knots = c(2, 2) + ), + data = globulus, + method = 'em' + ), + ## A genetic-AR model with a fixed effect + ped_ar = remlf90( + fixed = phe_X ~ gg, + genetic = list( + model = 'add_animal', + pedigree = globulus[,1:3], + id = 'self' + ), + spatial = list( + model = 'AR', + coord = globulus[, c('x','y')], + rho = c(.85, .8) + ), + data = globulus + ) + ) +) + + +for (idx in seq_along(res)){ + fn <- paste0("res_", names(res)[idx], ".rds") + saveRDS(res[[idx]], file = file.path(testdata, fn)) +} + diff --git a/tests/integration/test-AR.R b/tests/integration/test-AR.R new file mode 100644 index 0000000..db09512 --- /dev/null +++ b/tests/integration/test-AR.R @@ -0,0 +1,323 @@ + +#### Context: AR models with different arrangements of trees #### +context("AR models with diffferent arrangements of trees") + + +#### Build small testbeds #### +build.testbed <- function(corner = c(0, 0), size, treesep = c(1, 1), beta){ + n = size[1] * size[2] + # A planar spatial effect + s.mat = matrix(NA, nrow = size[1], ncol = size[2]) + j = 1:size[2] + for(i in 1:size[1]) + s.mat[i,j] = 0.1*(i+2*j) + + ## a covariate + set.seed(2) + z.mat = matrix(runif(n), size[1], size[2]) + ## noise + set.seed(2) + noise.mat = matrix(rnorm(n, sd = 0.3), size[1], size[2]) + ## make simulated data + y.mat = beta * z.mat + s.mat + noise.mat + ## build final dataset + dat <- data.frame(i = rep(seq(corner[1], by = treesep[1], length = size[1]), + times = size[2]), + j = rep(seq(corner[2], by = treesep[2], length = size[2]), + each = size[1]), + z = as.vector(z.mat), + y = as.vector(y.mat), + true.s = as.vector(s.mat)) + return(dat) +} + +beta = 0.5 +datlist <- list(# small square regular grid + small.sq.reg = build.testbed(corner = c(0, 0), + size = c(5, 5), + treesep = c(1, 1), + beta = beta), + # small rectangular grid with different spacings and coordinates + small.rect.irr = build.testbed(corner = c(134, 77), + size = c(5, 7), + treesep = c(3, 4), + beta = beta)) + +# triangular configuration +datlist <- c(datlist, + triang = list(datlist[[1]][which(as.vector(Matrix::tril(matrix(TRUE, 5, 5)))),])) + + + + +# Fit models both with EM and AI-REML +run.model <- function(dat, method) { + res = try( + suppressMessages( + remlf90( + fixed = y ~ 1 + z, + spatial = list(model = 'AR', + coord = dat[, 1:2], + rho = c(.9, .9)), + data = dat, + method = method) + ) + ) + return(list(dat = dat, + method = method, + res = res)) +} + +reslist <- c(lapply(datlist, run.model, method = 'em'), + lapply(datlist, run.model, method = 'ai')) + +# Check results +# summary(reslist[[1]]) +# res <- reslist[[1]] +# dat <- datlist[[1]] +# require(plyr) +check.result <- function(m, datlabel, debug.plot = FALSE) { + test_that(paste("AR model runs OK with dataset", datlabel, "and method", m$method), { + expect_true(!inherits(m$res, 'try-error')) + }) + + if( !inherits(m$res, 'try-error') ){ + fit.s <- fixef(m$res)$Intercept + + as.vector(model.matrix(m$res)$spatial %*% ranef(m$res)$spatial) + if(debug.plot) { + print(qplot(as.vector(m$dat$true.s), fit.s) + + geom_abline(intercept = 0, slope = 1)) + } + # Mean Square Error for the spatial effect + mse <- mean((as.vector(m$dat$true.s) - fit.s)^2) + test_that(paste("MSE of the spatial effect estimation is reasonable for dataset", + datlabel, "and method", m$method), { + expect_that(mse, is_less_than(1)) + }) + + # Estimate of the linear coefficient + beta.e <- beta - fixef(m$res)$z + test_that(paste("The linear coefficient is estimated within 3 se for dataset", + datlabel, "and method", m$method), { + expect_that(abs(beta.e), is_less_than(3*attr(fixef(m$res)$z, "se"))) + }) + } +} + +for(i in 1:length(reslist)) + check.result(reslist[[i]], names(reslist)[i], debug.plot = FALSE) + + + +#### Context: selection of autoregressive parameters #### +context("Selection of autoregressive parameters") + +res.unset <- try( + suppressMessages( + remlf90( + fixed = y ~ z, + spatial = list(model = 'AR', + coordinat = datlist[[1]][, 1:2]), + data = datlist[[1]]) + ) +) + +test_that("if rho unset, remlf90 tries a grid of combinations", { + # remlf90() returns an evaluation grid + expect_that(exists('rho', as.environment(res.unset)), is_true()) + # the evaluation grid returns the loglikelihood for each default combination + expect_that(all(complete.cases(res.unset$rho$loglik)), is_true()) +}) + + +gridlist <- list(expand.grid(seq(80, 90, 5), c(87, 93))/100, + expand.grid(seq(80, 90, 5), NA)/100, + expand.grid(NA, c(87, 93))/100) +reslist.spec <- lapply(gridlist, function(g) + try( + suppressMessages( + remlf90( + fixed = y ~ z, + spatial = list(model = 'AR', + coord = datlist[[1]][, 1:2], + rho = g), + data = datlist[[1]]) + ) + ) +) + +test_that("the user can specify a full or partial grid of combinations", { + + for(i in 1:length(reslist.spec)) { + res <- reslist.spec[[i]] + grid <- gridlist[[i]] + + # remlf90() returns an evaluation grid + expect_that(exists('rho', as.environment(res)), is_true()) + + # The evaluation grid conforms to the user specification + get_levels <- function(levels) { + if(all(is.na(levels))) return(breedR.getOption('ar.eval')) + else return(levels) + } + eval.grid <- expand.grid(lapply(lapply(grid, unique), get_levels), + KEEP.OUT.ATTRS = FALSE) + names(eval.grid) <- names(res$rho)[1:2] + expect_identical(eval.grid, + res$rho[, 1:2]) + + # the evaluation grid returns the loglikelihood for each combination specified + expect_that(all(complete.cases(res$rho$loglik)), + is_true()) + } +}) + + +# # Debug +# image(s.mat) +# image(matrix(res.bR$spatial$fit$z, nrow, ncol)) +# qplot(as.vector(s.mat), res.bR$spatial$fit$z) + geom_abline(intercept = 0, slope = 1, col = 'darkgray') +# summary(res.bR) + + + + +#### Context: Extraction of results from spatial AR model #### +context("Extraction of results from spatial AR model") + +data(m1) +dat <- as.data.frame(m1) + +## Remove some observations to provoke +## misalignment beetween the observations and the spatial random effects +dat <- dat[-sample(1:nrow(dat), 50), ] + +fixed.fml <- phe_X ~ sex + +n.obs <- nrow(dat) +n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) +nlevels.fixed <- nlevels(dat$sex) +rho <- c(.9, .9) +coord = dat[, 1:2] + +## Number of levels of the AR effect +n.AR <- prod(sapply(loc_grid(coord, autofill = TRUE), length)) + +# Use a different number of knots for rows and columns +res <- try( + suppressMessages( + remlf90(fixed = fixed.fml, + spatial = list(model = 'AR', + coord = coord, + rho = rho), + data = dat, + method = 'ai') + ) +) + + +test_that("The AR model runs with EM-REML without errors", { + expect_that(!inherits(res, "try-error"), is_true()) +}) + +test_that("coef() gets a named vector of coefficients", { + expect_is(coef(res), 'numeric') + expect_equal(length(coef(res)), nlevels.fixed + n.AR) + expect_named(coef(res)) +}) + +test_that("ExtractAIC() gets one number", { + expect_is(extractAIC(res), 'numeric') + expect_equal(length(extractAIC(res)), 1) +}) + +test_that("fitted() gets a vector of length N", { + expect_is(fitted(res), 'numeric') + expect_equal(length(fitted(res)), n.obs) +}) + +test_that("fixef() gets a named list of numeric vectors with estimated values and s.e.", { + x <- fixef(res) + expect_is(x, 'breedR_estimates') + expect_named(x) + expect_equal(length(x), n.fixed) + for (f in x) { + expect_is(f, 'numeric') + expect_false(is.null(fse <- attr(f, 'se'))) + expect_is(fse, 'numeric') + expect_equal(length(fse), length(f)) + } +}) + +test_that("get_pedigree() returns NULL", { + expect_null(get_pedigree(res)) +}) + +test_that("logLik() gets an object of class logLik", { + expect_is(logLik(res), 'logLik') +}) + +test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { + x <- model.frame(res) + expect_is(x, 'data.frame') + expect_is(terms(x), 'terms') + expect_equal(dim(x), c(n.obs, n.fixed + 1)) +}) + +test_that("model.matrix() gets a named list of fixed and random incidence matrices", { + x <- model.matrix(res) + expect_is(x, 'list') + expect_named(x, names(res$effects)) + expect_equal(dim(x$sex), c(n.obs, nlevels.fixed)) + expect_is(x$spatial, 'sparseMatrix') + expect_equal(dim(x$spatial), c(n.obs, n.AR)) +}) + +test_that("nobs() gets the number of observations", { + expect_equal(nobs(res), n.obs) +}) + +test_that("plot(, type = *) returns ggplot objects", { + expect_is(plot(res, type = 'phenotype'), 'ggplot') + expect_is(plot(res, type = 'fitted'), 'ggplot') + expect_is(plot(res, type = 'spatial'), 'ggplot') + expect_is(plot(res, type = 'fullspatial'), 'ggplot') + expect_is(plot(res, type = 'residuals'), 'ggplot') +}) + +test_that("print() shows some basic information", { + ## Not very informative currently... + expect_output(print(res), 'Data') +}) + +test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { + x <- ranef(res) + expect_is(x, 'ranef.breedR') + expect_equal(length(x), 1) + expect_named(x, c('spatial')) + + expect_is(x$spatial, 'numeric') + expect_equal(length(x$spatial), n.AR) + expect_false(is.null(xse <- attr(x$spatial, 'se'))) + + expect_is(xse, 'numeric') + expect_equal(length(xse), n.AR) +}) + +test_that("residuals() gets a vector of length N", { + rsd <- residuals(res) + expect_is(rsd, 'numeric') + expect_equal(length(rsd), n.obs) +}) + +test_that("summary() shows summary information", { + expect_output(print(summary(res)), 'Variance components') + expect_output(print(summary(res)), 'rho:') +}) + +test_that("vcov() gets the covariance matrix of the spatial component of the observations", { + x <- vcov(res) + expect_is(x, 'Matrix') + expect_equal(dim(x), rep(n.obs, 2)) +}) + diff --git a/tests/integration/test-animal.R b/tests/integration/test-animal.R new file mode 100644 index 0000000..f3ff3b9 --- /dev/null +++ b/tests/integration/test-animal.R @@ -0,0 +1,184 @@ + +data(m1) +dat <- as.data.frame(m1) +ped <- get_pedigree(m1) + + +#### Context: Animal Models #### +context("Results from Animal Models") + +fixed_models <- list(phe_X ~ sex) + +# Run REML and lm and save estimates and MLEs +run_model <- function(m, data = dat, method) { + res.reml <- try( + suppressMessages( + remlf90(fixed = m, + genetic = list(model = 'add_animal', + pedigree = ped, + id = 'self'), + data = data, + method = method) + ) + ) + return(res.reml) +} + +# Compare progsf90 and pedigreemm results +run_expectations <- function(m, data = dat, method) { + res <- run_model(m, data, method) + + # It runs without errors + test_that("The animal model runs without errors", { + expect_that(!inherits(res, "try-error"), is_true()) + }) + + # TODO: + # other checks, like: + # - compare the estimated genetic and residual vaiances with true values + # - compare the estimated and true Breeding Values + # - compare results to those from package pedigreemm + # (an extension to lme4 to include animal models) + +} + + + +# Run expectations for all models and methods +test_that("remlf90() estimates matches lm()'s", { + lapply(fixed_models, run_expectations, method = 'em') +}) + +test_that("airemlf90() estimates matches lm()'s", { + lapply(fixed_models, run_expectations, method = 'ai') +}) + + +#### Context: Extraction of results from add_animal model #### +context("Extraction of results from add_animal model") +######################## + + +fixed.fml <- phe_X ~ sex +n.obs <- nrow(dat) +n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) +nlevels.fixed <- nlevels(dat$sex) +n.bvs <- nrow(as.data.frame(ped)) + +res <- run_model(fixed_models[[1]], method = 'ai') + + +test_that("The add_animal model runs with EM-REML without errors", { + expect_that(!inherits(res, "try-error"), is_true()) +}) + +test_that("coef() gets a named vector of coefficients", { + expect_is(coef(res), 'numeric') + expect_equal(length(coef(res)), nlevels.fixed + n.bvs) + expect_named(coef(res)) +}) + +test_that("ExtractAIC() gets one number", { + expect_is(extractAIC(res), 'numeric') + expect_equal(length(extractAIC(res)), 1) +}) + +test_that("fitted() gets a vector of length N", { + expect_is(fitted(res), 'numeric') + expect_equal(length(fitted(res)), n.obs) +}) + +test_that("fixef() gets a named list of numeric vectors with estimated values and s.e.", { + x <- fixef(res) + expect_is(x, 'breedR_estimates') + expect_named(x) + expect_equal(length(x), n.fixed) + for (f in x) { + expect_is(f, 'numeric') + expect_false(is.null(fse <- attr(f, 'se'))) + expect_is(fse, 'numeric') + expect_equal(length(fse), length(f)) + } +}) + +test_that("get_pedigree() returns the given pedigree", { + expect_identical(get_pedigree(res), ped) +}) + +test_that("logLik() gets an object of class logLik", { + expect_is(logLik(res), 'logLik') +}) + +test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { + x <- model.frame(res) + expect_is(x, 'data.frame') + expect_is(terms(x), 'terms') + expect_equal(dim(x), c(n.obs, n.fixed + 1)) +}) + +test_that("model.matrix() gets a named list of incidence matrices", { + x <- model.matrix(res) + expect_is(x, 'list') + expect_named(x, names(res$effects)) + expect_equal(dim(x$sex), c(n.obs, nlevels.fixed)) + expect_is(x$genetic, 'sparseMatrix') + expect_equal(dim(x$genetic), c(n.obs, n.bvs)) +}) + +test_that("nobs() gets the number of observations", { + expect_equal(nobs(res), n.obs) +}) + +test_that("plot(, type = *) returns ggplot objects after providing coords", { + ## An error mesage is expected as the spatial structure is missing + expect_error(suppressMessages(plot(res, type = 'phenotype')), + 'Missing spatial structure') + + ## We can still plot phenotype, fitted and residuals if provide coords + coordinates(res) <- dat[, 1:2] + expect_is(plot(res, type = 'phenotype'), 'ggplot') + expect_is(plot(res, type = 'fitted'), 'ggplot') + expect_is(plot(res, type = 'residuals'), 'ggplot') + + ## But still get errors for the absent spatial components + expect_error(plot(res, type = 'spatial'), 'no spatial effect') + expect_error(plot(res, type = 'fullspatial'), 'no spatial effect') +}) + +test_that("print() shows some basic information", { + ## Not very informative currently... + expect_output(print(res), 'Data') +}) + +test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { + x <- ranef(res) + expect_is(x, 'ranef.breedR') + expect_equal(length(x), 1) + expect_named(x, c('genetic')) + + expect_is(x$genetic, 'numeric') + expect_equal(length(x$genetic), n.bvs) + expect_false(is.null(xse <- attr(x$genetic, 'se'))) + + expect_is(xse, 'numeric') + expect_equal(length(xse), n.bvs) +}) + +test_that("residuals() gets a vector of length N", { + rsd <- residuals(res) + expect_is(rsd, 'numeric') + expect_equal(length(rsd), n.obs) +}) + +test_that("summary() shows summary information", { + expect_output(print(summary(res)), 'Variance components') +}) + +test_that("vcov() gets the covariance matrix of the genetic component of the observations", { + + x <- try(vcov(res, effect = 'genetic')) + expect_false(inherits(x, 'try-error')) + expect_is(x, 'Matrix') + expect_equal(dim(x), rep(n.obs, 2)) +}) + diff --git a/tests/testthat/test-binaries.R b/tests/integration/test-binaries.R similarity index 94% rename from tests/testthat/test-binaries.R rename to tests/integration/test-binaries.R index 3bf34a9..8af9bf2 100644 --- a/tests/testthat/test-binaries.R +++ b/tests/integration/test-binaries.R @@ -1,7 +1,4 @@ ### Test the management of binary dependencies ### -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) context("Binary dependencies") diff --git a/tests/integration/test-blocks.R b/tests/integration/test-blocks.R new file mode 100644 index 0000000..a7506b7 --- /dev/null +++ b/tests/integration/test-blocks.R @@ -0,0 +1,141 @@ + +#### Context: Extraction of results from spatial blocks model #### +context("Extraction of results from spatial blocks model") + +data(globulus) +dat <- globulus + +fixed.fml <- phe_X ~ gg + +n.obs <- nrow(dat) +n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) +nlevels.fixed <- nlevels(dat$gg) +n.blocks <- nlevels(dat$bl) + +res <- try( + suppressMessages( + remlf90( + fixed = fixed.fml, + spatial = list(model = 'blocks', + coord = globulus[, c('x', 'y')], + id = dat$bl), + data = dat) + ) +) + +# # Manual verification of block estimates: +# library(dplyr) +# fixef(res) +# globulus %>% group_by(gg) %>% summarise(group_mean = mean(phe_X)) + +# Debug +# tb <- breedr_blocks(globulus[, c('x', 'y')], dat$bl) +# +# effpf90 <- renderpf90.breedr_modelframe(res$effects, 1) +# pf90 <- progsf90(res$mf, res$effects, opt = '', res.var.ini = 10) + +test_that("The blocks model runs with EM-REML without errors", { + expect_that(!inherits(res, "try-error"), is_true()) +}) + +test_that("coef() gets a named vector of coefficients", { + expect_is(coef(res), 'numeric') + expect_equal(length(coef(res)), nlevels.fixed + n.blocks) + expect_named(coef(res)) +}) + +test_that("ExtractAIC() gets one number", { + expect_is(extractAIC(res), 'numeric') + expect_equal(length(extractAIC(res)), 1) +}) + +test_that("fitted() gets a vector of length N", { + expect_is(fitted(res), 'numeric') + expect_equal(length(fitted(res)), n.obs) +}) + +test_that("fixef() gets a named list of numeric vectors with estimated values and s.e.", { + x <- fixef(res) + expect_is(x, 'breedR_estimates') + expect_named(x) + expect_equal(length(x), n.fixed) + for (f in x) { + expect_is(f, 'numeric') + expect_false(is.null(fse <- attr(f, 'se'))) + expect_is(fse, 'numeric') + expect_equal(length(fse), length(f)) + } +}) + +test_that("get_pedigree() returns NULL", { + expect_null(get_pedigree(res)) +}) + +test_that("logLik() gets an object of class logLik", { + expect_is(logLik(res), 'logLik') +}) + +test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { + x <- model.frame(res) + expect_is(x, 'data.frame') + expect_is(terms(x), 'terms') + expect_equal(dim(x), c(n.obs, n.fixed + 1)) +}) + +test_that("model.matrix() gets a named list of fixed and random incidence matrices", { + x <- model.matrix(res) + expect_is(x, 'list') + expect_named(x, names(res$effects)) + expect_equal(dim(x$gg), c(n.obs, nlevels.fixed)) + expect_is(x$spatial, 'sparseMatrix') + expect_equal(dim(x$spatial), c(n.obs, n.blocks)) +}) + + +test_that("nobs() gets the number of observations", { + expect_equal(nobs(res), n.obs) +}) + +test_that("plot(, type = *) returns ggplot objects", { + expect_is(plot(res, type = 'phenotype'), 'ggplot') + expect_is(plot(res, type = 'fitted'), 'ggplot') + expect_is(plot(res, type = 'spatial'), 'ggplot') + expect_is(plot(res, type = 'fullspatial'), 'ggplot') + expect_is(plot(res, type = 'residuals'), 'ggplot') +}) + +test_that("print() shows some basic information", { + ## Not very informative currently... + expect_output(print(res), 'Data') +}) + +test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { + x <- ranef(res) + expect_is(x, 'ranef.breedR') + expect_equal(length(x), 1) + expect_named(x, c('spatial')) + + expect_is(x$spatial, 'numeric') + expect_equal(length(x$spatial), n.blocks) + expect_false(is.null(xse <- attr(x$spatial, 'se'))) + + expect_is(xse, 'numeric') + expect_equal(length(xse), n.blocks) +}) + +test_that("residuals() gets a vector of length N", { + rsd <- residuals(res) + expect_is(rsd, 'numeric') + expect_equal(length(rsd), n.obs) +}) + +test_that("summary() shows summary information", { + expect_output(print(summary(res)), 'Variance components') + expect_output(print(summary(res)), 'blocks') +}) + +test_that("vcov() gets the covariance matrix of the spatial component of the observations", { + x <- vcov(res) + expect_is(x, 'Matrix') + expect_equal(dim(x), rep(n.obs, 2)) +}) diff --git a/tests/integration/test-generic.R b/tests/integration/test-generic.R new file mode 100644 index 0000000..e45896f --- /dev/null +++ b/tests/integration/test-generic.R @@ -0,0 +1,142 @@ + +context("Extraction of results from generic model") +######################## + +dat <- globulus + +fixed.fml <- phe_X ~ gg + x +n.obs <- nrow(dat) +n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) +nlevels.fixed <- nlevels(dat$gg) + 1 +nlevels.random <- nlevels(dat$bl) + +inc.mat <- model.matrix(~ 0 + bl, globulus) +cov.mat <- diag(nlevels(globulus$bl)) + +res <- try( + suppressMessages( + remlf90( + fixed = fixed.fml, + generic = list(bl = list(inc.mat, + cov.mat)), + data = dat) + ) +) + + + +test_that("The generic model runs with AI-REML without errors", { + expect_error(res, NA) +}) + +test_that("coef() gets a named vector of coefficients", { + expect_is(coef(res), 'numeric') + expect_equal(length(coef(res)), nlevels.fixed + nlevels.random) + expect_named(coef(res)) +}) + +test_that("ExtractAIC() gets one number", { + expect_is(extractAIC(res), 'numeric') + expect_equal(length(extractAIC(res)), 1) +}) + +test_that("fitted() gets a vector of length N", { + expect_is(fitted(res), 'numeric') + expect_equal(length(fitted(res)), n.obs) +}) + +test_that("fixef() gets a named list of numeric vectors with estimated values and s.e.", { + x <- fixef(res) + expect_is(x, 'breedR_estimates') + expect_named(x) + expect_equal(length(x), n.fixed) + for (f in x) { + expect_is(f, 'numeric') + expect_false(is.null(fse <- attr(f, 'se'))) + expect_is(fse, 'numeric') + expect_equal(length(fse), length(f)) + } +}) + +test_that("get_pedigree() returns NULL", { + expect_null(get_pedigree(res)) +}) + +test_that("logLik() gets an object of class logLik", { + expect_is(logLik(res), 'logLik') +}) + +test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { + x <- model.frame(res) + expect_is(x, 'data.frame') + expect_is(terms(x), 'terms') + expect_equal(dim(x), c(n.obs, n.fixed + 1)) +}) + +test_that("model.matrix() gets a named list of fixed and random incidence matrices", { + x <- model.matrix(res) + expect_is(x, 'list') + expect_named(x, names(res$effects)) + expect_equal(dim(x$gg), c(n.obs, nlevels.fixed-1)) + expect_equal(dim(x$x), c(n.obs, 1)) + expect_is(x$bl, 'sparseMatrix') + expect_equal(dim(x$bl), c(n.obs, nlevels.random)) +}) + +test_that("nobs() gets the number of observations", { + expect_equal(nobs(res), n.obs) +}) + +test_that("plot(, type = *) returns ggplot objects after providing coords", { + ## An error mesage is expected as the spatial structure is missing + expect_error(suppressMessages(plot(res, type = 'phenotype')), + 'Missing spatial structure') + + ## We can still plot phenotype, fitted and residuals if provide coords + coordinates(res) <- dat[, c('x', 'y')] + expect_is(plot(res, type = 'phenotype'), 'ggplot') + expect_is(plot(res, type = 'fitted'), 'ggplot') + expect_is(plot(res, type = 'residuals'), 'ggplot') + + ## But still get errors for the absent spatial components + expect_error(plot(res, type = 'spatial'), 'no spatial effect') + expect_error(plot(res, type = 'fullspatial'), 'no spatial effect') +}) + +test_that("print() shows some basic information", { + ## Not very informative currently... + expect_output(print(res), 'Data') +}) + +test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { + x <- ranef(res) + expect_is(x, 'ranef.breedR') + expect_equal(length(x), 1) + expect_named(x, c('bl')) + + expect_is(x$bl, 'numeric') + expect_equal(length(x$bl), nlevels.random) + expect_false(is.null(xse <- attr(x$bl, 'se'))) + + expect_is(xse, 'numeric') + expect_equal(length(xse), nlevels.random) +}) + +test_that("residuals() gets a vector of length N", { + rsd <- residuals(res) + expect_is(rsd, 'numeric') + expect_equal(length(rsd), n.obs) +}) + +test_that("summary() shows summary information", { + expect_output(print(summary(res)), 'Variance components') +}) + +test_that("vcov() gets the covariance matrix of the bl component of the observations", { + + ## Make it available after refactoring + ## when we can recover the structure and model matrices + expect_error(vcov(res, effect = 'bl'), 'should be one of') + # expect_is(x, 'Matrix') + # expect_equal(dim(x), rep(n.obs, 2)) +}) diff --git a/tests/testthat/test-interactions.R b/tests/integration/test-interactions.R similarity index 93% rename from tests/testthat/test-interactions.R rename to tests/integration/test-interactions.R index 9f6908f..512a387 100644 --- a/tests/testthat/test-interactions.R +++ b/tests/integration/test-interactions.R @@ -1,7 +1,6 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) -require(spam) +suppressPackageStartupMessages( + require(spam) +) #### Context: Models with several effects working together #### context("Models with several effects working together") diff --git a/tests/testthat/test-lmm.R b/tests/integration/test-lmm.R similarity index 96% rename from tests/testthat/test-lmm.R rename to tests/integration/test-lmm.R index eefada6..c07b0b5 100644 --- a/tests/testthat/test-lmm.R +++ b/tests/integration/test-lmm.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) #### Simulated dataset #### # dataset size @@ -70,7 +67,7 @@ run_expectations <- function(m, data = dat, method) { equals(lm.beta, check.attributes = FALSE)) # equal standard errors (with more tolerance) - pf90.se <- drop(unlist(sapply(fixef(res[[1]]), function(x) x$'s.e.'))) + pf90.se <- drop(sapply(fixef(res[[1]]), attr, "se")) lm.se <- coef(summary(res[[2]]))[, 'Std. Error'] expect_that(pf90.se, equals(lm.se, check.attributes = FALSE, tolerance = 1e-05)) @@ -126,7 +123,9 @@ test_that("airemlf90() estimates matches lm()'s using AI", { #### Context: Linear Mixed Models #### context("Linear Mixed Models") -require(lme4) +suppressPackageStartupMessages( + require(lme4) +) # Re-use lm_models terms as fixed and the available # factors as random @@ -206,7 +205,7 @@ run_lmmexpectations <- function(m, data = dat, method, tol = 1e-03) { lmm.fitted <- fitted(res[[2]]) expect_that(pf90.fitted, equals(lmm.fitted, check.attributes = FALSE, tolerance = tol)) - qplot(pf90.fitted, lmm.fitted) + geom_abline(intercept = 0, slope = 1) + # qplot(pf90.fitted, lmm.fitted) + geom_abline(intercept = 0, slope = 1) } # Run character conversion test for each method diff --git a/tests/integration/test-pedigree.R b/tests/integration/test-pedigree.R new file mode 100644 index 0000000..f57f45e --- /dev/null +++ b/tests/integration/test-pedigree.R @@ -0,0 +1,79 @@ +#### pedigree building and checking #### + +context("Pedigree") + +# Toy dataset with silly pedigree +test.dat <- data.frame(matrix(sample(100, 15), 5, 3, + dimnames = list(NULL, c('self', 'sire', 'dam'))), + y = rnorm(5)) +ped.fix <- suppressWarnings(build_pedigree(1:3, data = test.dat)) +test.res <- try( + suppressMessages( + suppressWarnings( + remlf90(y~1, + genetic = list(model = 'add_animal', + pedigree = test.dat[, 1:3], + id = 'self'), + data = test.dat) + ) + ), + silent = TRUE +) + +test_that('remlf90() builds and recodes the pedigree', { + expect_false(inherits(test.res, 'try-error')) +}) + +test_that('get_pedigree() returns the recoded pedigree', { + expect_identical(ped.fix, get_pedigree(test.res)) +}) + + +# Check that remlf90 handles correctly recoded pedigrees +# by comparing the genetics evaluations of a dataset with or without +# a shuffled pedigree + +data(m1) +dat <- as.data.frame(m1) +ped <- get_pedigree(m1) + +res_ok <- try( + suppressMessages( + remlf90(fixed = phe_X ~ sex, + genetic = list(model = 'add_animal', + pedigree = ped, + id = 'self'), + data = dat) + ) +) + +# Shuffle the pedigree +mcode <- max(as.data.frame(ped), na.rm = TRUE) +map <- rep(NA, mcode) +set.seed(1234) +map <- sample(10*mcode, size = mcode) +m1_shuffled <- m1 +m1_shuffled$Data[, 1:3] <- sapply(as.data.frame(ped), function(x) map[x]) + +ped_fix <- suppressWarnings( + build_pedigree(1:3, data = as.data.frame(get_pedigree(m1_shuffled))) +) + + +res_shuffled <- try( + suppressMessages( + remlf90(fixed = phe_X ~ sex, + genetic = list(model = 'add_animal', + pedigree = ped_fix, + id = 'self'), + data = as.data.frame(m1_shuffled)) + ) +) + +# Except the call, and the reml output everything must be the same +# Update: also need to omit the shuffled random effects estimations +# which should be the same, but reordered +test_that('remlf90 handles recoded pedigrees correctly', { + omit.idx <- match(c('call', 'effects', 'reml', 'ranef'), names(res_ok)) + expect_that(res_ok[-omit.idx], equals(res_shuffled[-omit.idx])) +}) diff --git a/tests/testthat/test-pf90_options.R b/tests/integration/test-pf90_options.R similarity index 96% rename from tests/testthat/test-pf90_options.R rename to tests/integration/test-pf90_options.R index fdc1fe6..6fc06eb 100644 --- a/tests/testthat/test-pf90_options.R +++ b/tests/integration/test-pf90_options.R @@ -1,7 +1,6 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) -require(spam) +suppressPackageStartupMessages( + require(spam) +) ### Test the interface to PROGSF90 OPTIONS ### @@ -96,7 +95,8 @@ test_that('AI-remlf90() returns heritability and inverse AI matrix', { expect_output(print(summary(res)), "Heritability") # reported SE are consistent with AI matrix - expect_equal(res$var[, 'S.E.'], sqrt(diag(res$reml$invAI)), tol = 1e-04) + expect_equal(res$var[, 'S.E.'], sqrt(diag(res$reml$invAI)), + tol = 1e-04, check.attributes = FALSE) }) diff --git a/tests/testthat/test-reml-competition.R b/tests/integration/test-reml-competition.R similarity index 93% rename from tests/testthat/test-reml-competition.R rename to tests/integration/test-reml-competition.R index 8d4657f..c085a27 100644 --- a/tests/testthat/test-reml-competition.R +++ b/tests/integration/test-reml-competition.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### For testing competition, we perform a simulation excercise ### @@ -145,12 +142,11 @@ dat <- transform(dat, z = a + wnc + pec + e) -#### Fitting the competition model with remlf90 +#### Fitting the competition model with remlf90 ################################ context('Fitting competition models') -######################## -res <- try( - suppressMessages( +expect_error( + res <- suppressMessages( remlf90( fixed = z ~ 1, genetic = list(model = c('comp'), @@ -162,20 +158,16 @@ res <- try( data = dat, method = 'em', debug = F) - ) -) + ), + NA) + # ggplot2::qplot(dat$z - dat$e, fitted(res)) + # ggplot2::geom_abline(intercept = 0, slope = 1, col = 'darkgray') - - -test_that('remlf90() suceeds in fitting a single competition model', { - expect_false(inherits(res, 'try-error')) -}) - +#### Context: Extraction of results from competition model ##################### context("Extraction of results from competition model") -######################## + n.fixed <- 1 nlevels.fixed <- 1 @@ -198,14 +190,16 @@ test_that("fitted() gets a vector of length N", { expect_equal(length(fitted(res)), Nobs) }) -test_that("fixef() gets a named list of data.frames with estimated values and s.e.", { +test_that("fixef() gets a named list of numeric vectors with estimated values and s.e.", { x <- fixef(res) - expect_is(x, 'list') + expect_is(x, 'breedR_estimates') expect_named(x) expect_equal(length(x), n.fixed) for (f in x) { - expect_is(f, 'data.frame') - expect_named(f, c('value', 's.e.')) + expect_is(f, 'numeric') + expect_false(is.null(fse <- attr(f, 'se'))) + expect_is(fse, 'numeric') + expect_equal(length(fse), length(f)) } }) diff --git a/tests/integration/test-reml-interface.R b/tests/integration/test-reml-interface.R new file mode 100644 index 0000000..748bd56 --- /dev/null +++ b/tests/integration/test-reml-interface.R @@ -0,0 +1,267 @@ + +data(globulus) +ped <- build_pedigree(1:3, data = globulus) +# Test function +fit.model <- function(vi, vigen, random, dat = globulus, ...) { + try( + suppressMessages( + remlf90(fixed = phe_X ~ gen, + random = random, + var.ini = vi, + genetic = list(model = 'add_animal', + var.ini = vigen, + pedigree = ped, + id = 'self'), + data = dat) + ), + silent = TRUE) +} + +# Test data +testdat <- list( + list( + vi = NULL, # Missing specification: FAIL + vigen = 1, + random = ~ bl, + expectation = 0 + ), + list( + vi = list(bl = 1), # Missing specification of residual: FAIL + vigen = 1, + random = ~ bl, + expectation = 0 + ), + list( + vi = list(gg = 1, # Missing specification of bloc: FAIL + resid = 1), + vigen = 1, + random = ~ bl + gg, + expectation = 0 + ), + list( + vi = list(bl = 1, # Missing specification of gg: FAIL + resid = 1), + vigen = 1, + random = ~ bl + gg, + expectation = 0 + ), + list( + vi = list(bl = 1, # Missing genetic specification: FAIL + resid = 1), + vigen = NULL, + random = ~ bl, + expectation = 0 + ), + list( + vi = NULL, # OK: no specification at all + vigen = NULL, + random = ~ bl, + expectation = 1 + ), + list( + vi = list(bl = 1, # OK + resid = 1), + vigen = 1, + random = ~ bl, + expectation = 1 + ), + list( + vi = list(bl = 1, # OK + gg = 1, + resid = 1), + vigen = 1, + random = ~ bl + gg, + expectation = 1 + ), + list( + vi = list(resid = 1), # OK + vigen = 1, + random = NULL, + expectation = 1 + ) +) + + +#### Context: Variance components specifications #### +context("Variance components specifications") + +# reml results +# fit.model(vi=list(resid = 1), vigen=1, random = NULL) +# do.call('fit.model', testdat[[1]]) +# do.call('fit.model', testdat[[7]]) +reslst <- lapply(testdat, function(x) do.call(fit.model, x)) + + +# Compare expected and true results +run_expectations <- function(m, res) { + # Check that remlf90 behaves as expected + test_that("remlf90 requires either full or null variance specifications", { + ifelse( m$expectation, + expect_true(!inherits(res, "try-error")), + expect_true(inherits(res, "try-error")) ) + }) +} + +for(i in seq_along(testdat)) { +# cat(i) + run_expectations(testdat[[i]], reslst[[i]]) +} + +#### Context: Multitrait specifications #### +context("Multitrait interface") + +## two correlated variables +dim <- 3 +Nobs <- 1e4 +Nbl <- 50 +beta_X <- c(-1, 5, 3) +sample_covar <- function(dim) { + x <- sample(-2:dim, size = dim**2, replace = TRUE) + crossprod(matrix(x, nrow = dim)) +} +set.seed(123) +S_bl <- sample_covar(dim) # 5 & 3 & 5 // 22 & 10 // 11 +S_resid <- sample_covar(dim) # 9 & 3 & -3 // 9 & 9 // 14 +# diag(1/sqrt(diag(S_bl))) %*% S_bl %*% diag(1/sqrt(diag(S_bl))) + +dimnames(S_bl) <- dimnames(S_resid) <- + rep(list(paste0("y", seq_len(dim))), 2) + +bl_levels <- paste0( + "bl", + sprintf(paste0("%0", floor(log10(Nbl)+1), "d"), seq_len(Nbl)) +) + +testdat <- data.frame( + X = runif(Nobs), + breedR.sample.ranef( + dim, S_bl, Nbl, labels = bl_levels, N = Nobs, vname = 'bl' + ), + breedR.sample.ranef(dim, S_resid, Nobs, vname = 'e')) + +# var(testdat[, c('e1', 'e2')]) # ~ S_resid + +testdat <- + transform(testdat, + y1 = beta_X[1]*X + bl_y1 + e_y1, + y2 = beta_X[2]*X + bl_y2 + e_y2, + y3 = beta_X[3]*X + bl_y3 + e_y3) + + +test_that("Residual variance acurately identified in a fixed-effects model", { + + ## All fixed effects (AI fails with 3 traits) + res <- remlf90( + cbind(y1, y2, y3) ~ X + bl, + data = testdat, + method = "em" + ) + + expect_equal(S_resid, res$var$Residual, tol = .01) +}) + + +test_that("Simulated values reasonably recovered using one or more traits", { + + ## 1 trait + res_1 <- remlf90( + cbind(y1) ~ 0 + X, + random = ~ bl, + data = testdat + ) + + expect_equal(S_resid[1, 1], res_1$var["Residual", 1], tol = .01) + expect_equal(S_bl[1, 1], res_1$var["bl", 1], tol = .1) + expect_equal(beta_X[1], fixef(res_1)$X, tol = .1, check.attributes = FALSE) + + ## 2 trait + res_2 <- remlf90( + cbind(y1, y2) ~ 0 + X, + random = ~ bl, + data = testdat, + method = "ai" + ) + + expect_equal(S_resid[-3, -3], res_2$var[["Residual", 1]], tol = .01) + expect_equal(S_bl[-3, -3], res_2$var[["bl", 1]], tol = 1) + expect_equal(beta_X[-3], fixef(res_2)$X, tol = .1, check.attributes = FALSE) + + ## 3 trait (with "em" since otherwise does not converge) + res_3 <- remlf90( + cbind(y1, y2, y3) ~ 0 + X, + random = ~ bl, + data = testdat, + method = "em" + ) + + expect_equal(S_resid, res_3$var$Residual, tol = .01) + expect_equal(S_bl, res_3$var$bl, tol = 1) + expect_equal(beta_X, fixef(res_3)$X, tol = .01, check.attributes = FALSE) +}) + + + +# mf <- model.frame(cbind(V1, V2) ~ 0 + mu, transform(testdat, mu = 1)) +# attr(attr(mf, 'terms'), 'term.types') <- list(mu = "fixed") +# eff <- build.effects(mf, genetic = NULL, spatial = NULL, generic = NULL, var.ini = S) +# pf90 <- progsf90(mf, eff, res.var.ini = S) + +## Use larix dataset: +## - Two phenotypes: LAS and DOS +## - repeated measurements along 16 years (yr) + +inc.mat <- model.matrix(~ 0 + bl, larix) +cov.mat <- diag(nlevels(larix$bl)) + +test_that("Multitrait model with all kind of effects works as expected", { + + fullrun <- function(method, opt = NULL) { + try( + remlf90( + fixed = cbind(LAS, DOS) ~ rep, + random = ~ bl, + genetic = list(model = 'add_animal', + pedigree = larix[, 1:3], + id = 'self'), + spatial = list(model = 'AR', + coordinates = larix[, c('x', 'y')], + rho = c(.8, .8)), + generic = list(block = list(inc.mat, + cov.mat)), + data = larix, + method = method, + progsf90.options = opt + ) + ) + } + + ## make things fast, as I am not looking at numerical results + res_ai <- fullrun("ai", opt = c("maxrounds 2")) + ## cannot use it with em as the logfile would not report final estimates + res_em <- fullrun("em") + + fixef_names <- "rep" + ranef_names <- c("bl", "genetic", "spatial", "block") + + + ## No errors + expect_false(inherits(res_em, "try-error")) + expect_false(inherits(res_ai, "try-error")) + + ## fixed effect estimates + expect_identical(names(fixef(res_em)), fixef_names) + expect_identical(names(fixef(res_ai)), fixef_names) + + ## variance component estimates + ## em: a list -> names + ## ai: a matrix (effects x (estimate, se)) -> rownames + expect_identical(names(res_em$var), c(ranef_names, "Residual")) + expect_identical(rownames(res_ai$var), c(ranef_names, "Residual")) + + ## random effect blups + expect_identical(names(ranef(res_em)), ranef_names) + expect_identical(names(ranef(res_ai)), ranef_names) + +}) + + diff --git a/tests/testthat/test-reml-prediction.R b/tests/integration/test-reml-prediction.R similarity index 94% rename from tests/testthat/test-reml-prediction.R rename to tests/integration/test-reml-prediction.R index 5446b90..5987511 100644 --- a/tests/testthat/test-reml-prediction.R +++ b/tests/integration/test-reml-prediction.R @@ -1,7 +1,4 @@ ### For testing prediction, we perform a cross-validation excercise ### -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) data(m1) @@ -107,6 +104,6 @@ test_that('(ai)remlf90() predict correctly when missing code is not 0', { NA ) - expect_equal(fitted(res)[1], fixef(res)$group[1, 'value'], + expect_equal(fitted(res)[1], fixef(res)$group[1], check.attributes = FALSE) }) diff --git a/tests/integration/test-splines.R b/tests/integration/test-splines.R new file mode 100644 index 0000000..89f7bc5 --- /dev/null +++ b/tests/integration/test-splines.R @@ -0,0 +1,133 @@ + +context("Extraction of results from spatial splines model") +######################## + +data(m1) +dat <- as.data.frame(m1) + +fixed.fml <- phe_X ~ sex + +n.obs <- nrow(dat) +n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) +nlevels.fixed <- nlevels(dat$sex) +n.knots <- c(4, 3) +n.splines <- prod(n.knots + 2) + +# Use a different number of knots for rows and columns +res <- try( + suppressMessages( + remlf90(fixed = fixed.fml, + spatial = list(model = 'splines', + coord = coordinates(m1), + n.knots = n.knots), + data = dat, + method = 'em') + ) +) + + +test_that("The splines model runs with EM-REML without errors", { + expect_that(!inherits(res, "try-error"), is_true()) +}) + +test_that("coef() gets a named vector of coefficients", { + expect_is(coef(res), 'numeric') + expect_equal(length(coef(res)), nlevels.fixed + n.splines) + expect_named(coef(res)) +}) + +test_that("ExtractAIC() gets one number", { + expect_is(extractAIC(res), 'numeric') + expect_equal(length(extractAIC(res)), 1) +}) + +test_that("fitted() gets a vector of length N", { + expect_is(fitted(res), 'numeric') + expect_equal(length(fitted(res)), n.obs) +}) + +test_that("fixef() gets a named list of numeric vectors with estimated values and s.e.", { + x <- fixef(res) + expect_is(x, 'breedR_estimates') + expect_named(x) + expect_equal(length(x), n.fixed) + for (f in x) { + expect_is(f, 'numeric') + expect_false(is.null(fse <- attr(f, 'se'))) + expect_is(fse, 'numeric') + expect_equal(length(fse), length(f)) + } +}) + +test_that("get_pedigree() returns NULL", { + expect_null(get_pedigree(res)) +}) + +test_that("logLik() gets an object of class logLik", { + expect_is(logLik(res), 'logLik') +}) + +test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { + x <- model.frame(res) + expect_is(x, 'data.frame') + expect_is(terms(x), 'terms') + expect_equal(dim(x), c(n.obs, n.fixed + 1)) +}) + +test_that("model.matrix() gets a named list of fixed and random incidence matrices", { + x <- model.matrix(res) + expect_is(x, 'list') + expect_named(x, names(res$effects)) + expect_equal(dim(x$sex), c(n.obs, nlevels.fixed)) + expect_is(x$spatial, 'sparseMatrix') + expect_equal(dim(x$spatial), c(n.obs, n.splines)) +}) + +test_that("nobs() gets the number of observations", { + expect_equal(nobs(res), n.obs) +}) + +test_that("plot(, type = *) returns ggplot objects", { + expect_is(plot(res, type = 'phenotype'), 'ggplot') + expect_is(plot(res, type = 'fitted'), 'ggplot') + expect_is(plot(res, type = 'spatial'), 'ggplot') + expect_is(plot(res, type = 'fullspatial'), 'ggplot') + expect_is(plot(res, type = 'residuals'), 'ggplot') +}) + +test_that("print() shows some basic information", { + ## Not very informative currently... + expect_output(print(res), 'Data') +}) + +test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { + x <- ranef(res) + expect_is(x, 'ranef.breedR') + expect_equal(length(x), 1) + expect_named(x, c('spatial')) + + expect_is(x$spatial, 'numeric') + expect_equal(length(x$spatial), n.splines) + expect_false(is.null(xse <- attr(x$spatial, 'se'))) + + expect_is(xse, 'numeric') + expect_equal(length(xse), n.splines) +}) + +test_that("residuals() gets a vector of length N", { + rsd <- residuals(res) + expect_is(rsd, 'numeric') + expect_equal(length(rsd), n.obs) +}) + +test_that("summary() shows summary information", { + expect_output(print(summary(res)), 'Variance components') + expect_output(print(summary(res)), 'knots:') +}) + +test_that("vcov() gets the covariance matrix of the spatial component of the observations", { + x <- vcov(res) + expect_is(x, 'Matrix') + expect_equal(dim(x), rep(n.obs, 2)) +}) + diff --git a/tests/testthat/helper-testdata.R b/tests/testthat/helper-testdata.R new file mode 100644 index 0000000..33bb335 --- /dev/null +++ b/tests/testthat/helper-testdata.R @@ -0,0 +1,7 @@ +## test data directory +testdata <- system.file("testdata", package = "breedR") + +load_res <- function(key, dir = testdata) { + fn <- paste0("res_", key, ".rds") + readRDS(file.path(dir, fn)) +} \ No newline at end of file diff --git a/tests/testthat/test-AR.R b/tests/testthat/test-AR.R index 5b5c13f..76932ae 100644 --- a/tests/testthat/test-AR.R +++ b/tests/testthat/test-AR.R @@ -1,7 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) - #### Context: breedr_ar() #### context("AR infrastructure") @@ -38,326 +34,3 @@ check_build.ar.model <- function(x) { } for (x in reslst) check_build.ar.model(x) - - - -#### Context: AR models with different arrangements of trees #### -context("AR models with diffferent arrangements of trees") - - -#### Build small testbeds #### -build.testbed <- function(corner = c(0, 0), size, treesep = c(1, 1), beta){ - n = size[1] * size[2] - # A planar spatial effect - s.mat = matrix(NA, nrow = size[1], ncol = size[2]) - j = 1:size[2] - for(i in 1:size[1]) - s.mat[i,j] = 0.1*(i+2*j) - - ## a covariate - set.seed(2) - z.mat = matrix(runif(n), size[1], size[2]) - ## noise - set.seed(2) - noise.mat = matrix(rnorm(n, sd = 0.3), size[1], size[2]) - ## make simulated data - y.mat = beta * z.mat + s.mat + noise.mat - ## build final dataset - dat <- data.frame(i = rep(seq(corner[1], by = treesep[1], length = size[1]), - times = size[2]), - j = rep(seq(corner[2], by = treesep[2], length = size[2]), - each = size[1]), - z = as.vector(z.mat), - y = as.vector(y.mat), - true.s = as.vector(s.mat)) - return(dat) -} - -beta = 0.5 -datlist <- list(# small square regular grid - small.sq.reg = build.testbed(corner = c(0, 0), - size = c(5, 5), - treesep = c(1, 1), - beta = beta), - # small rectangular grid with different spacings and coordinates - small.rect.irr = build.testbed(corner = c(134, 77), - size = c(5, 7), - treesep = c(3, 4), - beta = beta)) - -# triangular configuration -datlist <- c(datlist, - triang = list(datlist[[1]][which(as.vector(Matrix::tril(matrix(TRUE, 5, 5)))),])) - - - - -# Fit models both with EM and AI-REML -run.model <- function(dat, method) { - res = try( - suppressMessages( - remlf90( - fixed = y ~ 1 + z, - spatial = list(model = 'AR', - coord = dat[, 1:2], - rho = c(.9, .9)), - data = dat, - method = method) - ) - ) - return(list(dat = dat, - method = method, - res = res)) -} - -reslist <- c(lapply(datlist, run.model, method = 'em'), - lapply(datlist, run.model, method = 'ai')) - -# Check results -# summary(reslist[[1]]) -# res <- reslist[[1]] -# dat <- datlist[[1]] -# require(plyr) -check.result <- function(m, datlabel, debug.plot = FALSE) { - test_that(paste("AR model runs OK with dataset", datlabel, "and method", m$method), { - expect_true(!inherits(m$res, 'try-error')) - }) - - if( !inherits(m$res, 'try-error') ){ - fit.s <- fixef(m$res)$Intercept$value + - model.matrix(m$res)$spatial %*% ranef(m$res)$spatial - if(debug.plot) { - print(qplot(as.vector(m$dat$true.s), fit.s) + - geom_abline(intercept = 0, slope = 1)) - } - # Mean Square Error for the spatial effect - mse <- mean((as.vector(m$dat$true.s) - fit.s)^2) - test_that(paste("MSE of the spatial effect estimation is reasonable for dataset", - datlabel, "and method", m$method), { - expect_that(mse, is_less_than(1)) - }) - - # Estimate of the linear coefficient - beta.e <- beta - fixef(m$res)$z$value - test_that(paste("The linear coefficient is estimated within 3 se for dataset", - datlabel, "and method", m$method), { - expect_that(abs(beta.e), is_less_than(3*fixef(m$res)$z$s.e.)) - }) - } -} - -for(i in 1:length(reslist)) - check.result(reslist[[i]], names(reslist)[i], debug.plot = FALSE) - - - -#### Context: selection of autoregressive parameters #### -context("Selection of autoregressive parameters") - -res.unset <- try( - suppressMessages( - remlf90( - fixed = y ~ z, - spatial = list(model = 'AR', - coordinat = datlist[[1]][, 1:2]), - data = datlist[[1]]) - ) -) - -test_that("if rho unset, remlf90 tries a grid of combinations", { - # remlf90() returns an evaluation grid - expect_that(exists('rho', as.environment(res.unset)), is_true()) - # the evaluation grid returns the loglikelihood for each default combination - expect_that(all(complete.cases(res.unset$rho$loglik)), is_true()) -}) - - -gridlist <- list(expand.grid(seq(80, 90, 5), c(87, 93))/100, - expand.grid(seq(80, 90, 5), NA)/100, - expand.grid(NA, c(87, 93))/100) -reslist.spec <- lapply(gridlist, function(g) - try( - suppressMessages( - remlf90( - fixed = y ~ z, - spatial = list(model = 'AR', - coord = datlist[[1]][, 1:2], - rho = g), - data = datlist[[1]]) - ) - ) -) - -test_that("the user can specify a full or partial grid of combinations", { - - for(i in 1:length(reslist.spec)) { - res <- reslist.spec[[i]] - grid <- gridlist[[i]] - - # remlf90() returns an evaluation grid - expect_that(exists('rho', as.environment(res)), is_true()) - - # The evaluation grid conforms to the user specification - get_levels <- function(levels) { - if(all(is.na(levels))) return(breedR.getOption('ar.eval')) - else return(levels) - } - eval.grid <- expand.grid(lapply(lapply(grid, unique), get_levels), - KEEP.OUT.ATTRS = FALSE) - names(eval.grid) <- names(res$rho)[1:2] - expect_identical(eval.grid, - res$rho[, 1:2]) - - # the evaluation grid returns the loglikelihood for each combination specified - expect_that(all(complete.cases(res$rho$loglik)), - is_true()) - } -}) - - -# # Debug -# image(s.mat) -# image(matrix(res.bR$spatial$fit$z, nrow, ncol)) -# qplot(as.vector(s.mat), res.bR$spatial$fit$z) + geom_abline(intercept = 0, slope = 1, col = 'darkgray') -# summary(res.bR) - - - - -context("Extraction of results from spatial AR model") -######################## - -data(m1) -dat <- as.data.frame(m1) - -## Remove some observations to provoke -## misalignment beetween the observations and the spatial random effects -dat <- dat[-sample(1:nrow(dat), 50), ] - -fixed.fml <- phe_X ~ sex - -n.obs <- nrow(dat) -n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) -nlevels.fixed <- nlevels(dat$sex) -rho <- c(.9, .9) -coord = dat[, 1:2] - -## Number of levels of the AR effect -n.AR <- prod(sapply(loc_grid(coord, autofill = TRUE), length)) - -# Use a different number of knots for rows and columns -res <- try( - suppressMessages( - remlf90(fixed = fixed.fml, - spatial = list(model = 'AR', - coord = coord, - rho = rho), - data = dat, - method = 'ai') - ) -) - - -test_that("The AR model runs with EM-REML without errors", { - expect_that(!inherits(res, "try-error"), is_true()) -}) - -test_that("coef() gets a named vector of coefficients", { - expect_is(coef(res), 'numeric') - expect_equal(length(coef(res)), nlevels.fixed + n.AR) - expect_named(coef(res)) -}) - -test_that("ExtractAIC() gets one number", { - expect_is(extractAIC(res), 'numeric') - expect_equal(length(extractAIC(res)), 1) -}) - -test_that("fitted() gets a vector of length N", { - expect_is(fitted(res), 'numeric') - expect_equal(length(fitted(res)), n.obs) -}) - -test_that("fixef() gets a named list of data.frames with estimated values and s.e.", { - x <- fixef(res) - expect_is(x, 'list') - expect_named(x) - expect_equal(length(x), n.fixed) - for (f in x) { - expect_is(f, 'data.frame') - expect_named(f, c('value', 's.e.')) - } -}) - -test_that("get_pedigree() returns NULL", { - expect_null(get_pedigree(res)) -}) - -test_that("logLik() gets an object of class logLik", { - expect_is(logLik(res), 'logLik') -}) - -test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { - x <- model.frame(res) - expect_is(x, 'data.frame') - expect_is(terms(x), 'terms') - expect_equal(dim(x), c(n.obs, n.fixed + 1)) -}) - -test_that("model.matrix() gets a named list of fixed and random incidence matrices", { - x <- model.matrix(res) - expect_is(x, 'list') - expect_named(x, names(res$effects)) - expect_equal(dim(x$sex), c(n.obs, nlevels.fixed)) - expect_is(x$spatial, 'sparseMatrix') - expect_equal(dim(x$spatial), c(n.obs, n.AR)) -}) - -test_that("nobs() gets the number of observations", { - expect_equal(nobs(res), n.obs) -}) - -test_that("plot(, type = *) returns ggplot objects", { - expect_is(plot(res, type = 'phenotype'), 'ggplot') - expect_is(plot(res, type = 'fitted'), 'ggplot') - expect_is(plot(res, type = 'spatial'), 'ggplot') - expect_is(plot(res, type = 'fullspatial'), 'ggplot') - expect_is(plot(res, type = 'residuals'), 'ggplot') -}) - -test_that("print() shows some basic information", { - ## Not very informative currently... - expect_output(print(res), 'Data') -}) - -test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { - x <- ranef(res) - expect_is(x, 'ranef.breedR') - expect_equal(length(x), 1) - expect_named(x, c('spatial')) - - expect_is(x$spatial, 'numeric') - expect_equal(length(x$spatial), n.AR) - expect_false(is.null(xse <- attr(x$spatial, 'se'))) - - expect_is(xse, 'numeric') - expect_equal(length(xse), n.AR) -}) - -test_that("residuals() gets a vector of length N", { - rsd <- residuals(res) - expect_is(rsd, 'numeric') - expect_equal(length(rsd), n.obs) -}) - -test_that("summary() shows summary information", { - expect_output(print(summary(res)), 'Variance components') - expect_output(print(summary(res)), 'rho:') -}) - -test_that("vcov() gets the covariance matrix of the spatial component of the observations", { - x <- vcov(res) - expect_is(x, 'Matrix') - expect_equal(dim(x), rep(n.obs, 2)) -}) - diff --git a/tests/testthat/test-animal.R b/tests/testthat/test-animal.R index ead3471..3eece57 100644 --- a/tests/testthat/test-animal.R +++ b/tests/testthat/test-animal.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) data(m1) dat <- as.data.frame(m1) @@ -37,181 +34,3 @@ test_that("Correctly builds structure of additive_genetic_animal component", { expect_identical(aga$structure.type, 'covariance') expect_identical(aga$pedigree, ped) }) - - -#### Context: Animal Models #### -context("Results from Animal Models") - -fixed_models <- list(phe_X ~ sex) - -# Run REML and lm and save estimates and MLEs -run_model <- function(m, data = dat, method) { - res.reml <- try( - suppressMessages( - remlf90(fixed = m, - genetic = list(model = 'add_animal', - pedigree = ped, - id = 'self'), - data = data, - method = method) - ) - ) - return(res.reml) -} - -# Compare progsf90 and pedigreemm results -run_expectations <- function(m, data = dat, method) { - res <- run_model(m, data, method) - - # It runs without errors - test_that("The animal model runs without errors", { - expect_that(!inherits(res, "try-error"), is_true()) - }) - - # TODO: - # other checks, like: - # - compare the estimated genetic and residual vaiances with true values - # - compare the estimated and true Breeding Values - # - compare results to those from package pedigreemm - # (an extension to lme4 to include animal models) - -} - - - -# Run expectations for all models and methods -test_that("remlf90() estimates matches lm()'s", { - lapply(fixed_models, run_expectations, method = 'em') -}) - -test_that("airemlf90() estimates matches lm()'s", { - lapply(fixed_models, run_expectations, method = 'ai') -}) - - - -context("Extraction of results from add_animal model") -######################## - - -fixed.fml <- phe_X ~ sex -n.obs <- nrow(dat) -n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) -nlevels.fixed <- nlevels(dat$sex) -n.bvs <- nrow(as.data.frame(ped)) - -res <- run_model(fixed_models[[1]], method = 'ai') - - -test_that("The add_animal model runs with EM-REML without errors", { - expect_that(!inherits(res, "try-error"), is_true()) -}) - -test_that("coef() gets a named vector of coefficients", { - expect_is(coef(res), 'numeric') - expect_equal(length(coef(res)), nlevels.fixed + n.bvs) - expect_named(coef(res)) -}) - -test_that("ExtractAIC() gets one number", { - expect_is(extractAIC(res), 'numeric') - expect_equal(length(extractAIC(res)), 1) -}) - -test_that("fitted() gets a vector of length N", { - expect_is(fitted(res), 'numeric') - expect_equal(length(fitted(res)), n.obs) -}) - -test_that("fixef() gets a named list of data.frames with estimated values and s.e.", { - x <- fixef(res) - expect_is(x, 'list') - expect_named(x) - expect_equal(length(x), n.fixed) - for (f in x) { - expect_is(f, 'data.frame') - expect_named(f, c('value', 's.e.')) - } -}) - -test_that("get_pedigree() returns the given pedigree", { - expect_identical(get_pedigree(res), ped) -}) - -test_that("logLik() gets an object of class logLik", { - expect_is(logLik(res), 'logLik') -}) - -test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { - x <- model.frame(res) - expect_is(x, 'data.frame') - expect_is(terms(x), 'terms') - expect_equal(dim(x), c(n.obs, n.fixed + 1)) -}) - -test_that("model.matrix() gets a named list of incidence matrices", { - x <- model.matrix(res) - expect_is(x, 'list') - expect_named(x, names(res$effects)) - expect_equal(dim(x$sex), c(n.obs, nlevels.fixed)) - expect_is(x$genetic, 'sparseMatrix') - expect_equal(dim(x$genetic), c(n.obs, n.bvs)) -}) - -test_that("nobs() gets the number of observations", { - expect_equal(nobs(res), n.obs) -}) - -test_that("plot(, type = *) returns ggplot objects after providing coords", { - ## An error mesage is expected as the spatial structure is missing - expect_error(suppressMessages(plot(res, type = 'phenotype')), - 'Missing spatial structure') - - ## We can still plot phenotype, fitted and residuals if provide coords - coordinates(res) <- dat[, 1:2] - expect_is(plot(res, type = 'phenotype'), 'ggplot') - expect_is(plot(res, type = 'fitted'), 'ggplot') - expect_is(plot(res, type = 'residuals'), 'ggplot') - - ## But still get errors for the absent spatial components - expect_error(plot(res, type = 'spatial'), 'no spatial effect') - expect_error(plot(res, type = 'fullspatial'), 'no spatial effect') -}) - -test_that("print() shows some basic information", { - ## Not very informative currently... - expect_output(print(res), 'Data') -}) - -test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { - x <- ranef(res) - expect_is(x, 'ranef.breedR') - expect_equal(length(x), 1) - expect_named(x, c('genetic')) - - expect_is(x$genetic, 'numeric') - expect_equal(length(x$genetic), n.bvs) - expect_false(is.null(xse <- attr(x$genetic, 'se'))) - - expect_is(xse, 'numeric') - expect_equal(length(xse), n.bvs) -}) - -test_that("residuals() gets a vector of length N", { - rsd <- residuals(res) - expect_is(rsd, 'numeric') - expect_equal(length(rsd), n.obs) -}) - -test_that("summary() shows summary information", { - expect_output(print(summary(res)), 'Variance components') -}) - -test_that("vcov() gets the covariance matrix of the genetic component of the observations", { - - x <- try(vcov(res, effect = 'genetic')) - expect_false(inherits(x, 'try-error')) - expect_is(x, 'Matrix') - expect_equal(dim(x), rep(n.obs, 2)) -}) - diff --git a/tests/testthat/test-blocks.R b/tests/testthat/test-blocks.R index 2914ebf..fa4ce25 100644 --- a/tests/testthat/test-blocks.R +++ b/tests/testthat/test-blocks.R @@ -1,9 +1,6 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) +#### Context: Blocks infrastructure #### context("Blocks infrastructure") -######################## test_that("breedr_blocks() constructor gives a list with 5 elements of correct sizes", { x.loc <- 1:100 @@ -28,144 +25,3 @@ test_that("breedr_blocks() constructor gives a list with 5 elements of correct s # The matrix U should be in sparse format: row col value expect_that(cov.mat, is_a('Matrix')) }) - - -context("Extraction of results from spatial blocks model") -######################## - -data(globulus) -dat <- globulus - -fixed.fml <- phe_X ~ gg - -n.obs <- nrow(dat) -n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) -nlevels.fixed <- nlevels(dat$gg) -n.blocks <- nlevels(dat$bl) - -res <- try( - suppressMessages( - remlf90( - fixed = fixed.fml, - spatial = list(model = 'blocks', - coord = globulus[, c('x', 'y')], - id = dat$bl), - data = dat) - ) -) - -# # Manual verification of block estimates: -# library(dplyr) -# fixef(res) -# globulus %>% group_by(gg) %>% summarise(group_mean = mean(phe_X)) - -# Debug -# tb <- breedr_blocks(globulus[, c('x', 'y')], dat$bl) -# -# effpf90 <- renderpf90.breedr_modelframe(res$effects, 1) -# pf90 <- progsf90(res$mf, res$effects, opt = '', res.var.ini = 10) - -test_that("The blocks model runs with EM-REML without errors", { - expect_that(!inherits(res, "try-error"), is_true()) -}) - -test_that("coef() gets a named vector of coefficients", { - expect_is(coef(res), 'numeric') - expect_equal(length(coef(res)), nlevels.fixed + n.blocks) - expect_named(coef(res)) -}) - -test_that("ExtractAIC() gets one number", { - expect_is(extractAIC(res), 'numeric') - expect_equal(length(extractAIC(res)), 1) -}) - -test_that("fitted() gets a vector of length N", { - expect_is(fitted(res), 'numeric') - expect_equal(length(fitted(res)), n.obs) -}) - -test_that("fixef() gets a named list of data.frames with estimated values and s.e.", { - x <- fixef(res) - expect_is(x, 'list') - expect_named(x) - expect_equal(length(x), n.fixed) - for (f in x) { - expect_is(f, 'data.frame') - expect_named(f, c('value', 's.e.')) - } -}) - -test_that("get_pedigree() returns NULL", { - expect_null(get_pedigree(res)) -}) - -test_that("logLik() gets an object of class logLik", { - expect_is(logLik(res), 'logLik') -}) - -test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { - x <- model.frame(res) - expect_is(x, 'data.frame') - expect_is(terms(x), 'terms') - expect_equal(dim(x), c(n.obs, n.fixed + 1)) -}) - -test_that("model.matrix() gets a named list of fixed and random incidence matrices", { - x <- model.matrix(res) - expect_is(x, 'list') - expect_named(x, names(res$effects)) - expect_equal(dim(x$gg), c(n.obs, nlevels.fixed)) - expect_is(x$spatial, 'sparseMatrix') - expect_equal(dim(x$spatial), c(n.obs, n.blocks)) -}) - - -test_that("nobs() gets the number of observations", { - expect_equal(nobs(res), n.obs) -}) - -test_that("plot(, type = *) returns ggplot objects", { - expect_is(plot(res, type = 'phenotype'), 'ggplot') - expect_is(plot(res, type = 'fitted'), 'ggplot') - expect_is(plot(res, type = 'spatial'), 'ggplot') - expect_is(plot(res, type = 'fullspatial'), 'ggplot') - expect_is(plot(res, type = 'residuals'), 'ggplot') -}) - -test_that("print() shows some basic information", { - ## Not very informative currently... - expect_output(print(res), 'Data') -}) - -test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { - x <- ranef(res) - expect_is(x, 'ranef.breedR') - expect_equal(length(x), 1) - expect_named(x, c('spatial')) - - expect_is(x$spatial, 'numeric') - expect_equal(length(x$spatial), n.blocks) - expect_false(is.null(xse <- attr(x$spatial, 'se'))) - - expect_is(xse, 'numeric') - expect_equal(length(xse), n.blocks) -}) - -test_that("residuals() gets a vector of length N", { - rsd <- residuals(res) - expect_is(rsd, 'numeric') - expect_equal(length(rsd), n.obs) -}) - -test_that("summary() shows summary information", { - expect_output(print(summary(res)), 'Variance components') - expect_output(print(summary(res)), 'blocks') -}) - -test_that("vcov() gets the covariance matrix of the spatial component of the observations", { - x <- vcov(res) - expect_is(x, 'Matrix') - expect_equal(dim(x), rep(n.obs, 2)) -}) - diff --git a/tests/testthat/test-checks.R b/tests/testthat/test-checks.R index f7f7e50..12176fc 100644 --- a/tests/testthat/test-checks.R +++ b/tests/testthat/test-checks.R @@ -1,39 +1,45 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Tests of functions for checking model components ### context("Checks for model components") -##Model add_animal## -dat <- data.frame(id = 1:4, +## Model add_animal ## +dat <- data.frame(id = 1:4, sire = c(11, 11, 2, 3), - dam = c(12, NA, 1, 12)) -ped <- build_pedigree(1:3, data = dat) + dam = c(12, NA, 1, 12), + y = rnorm(4), + z = rnorm(4, sd = 2)) +ped <- suppressWarnings(build_pedigree(1:3, data = dat)) id <- dat$id var.ini <- 1.5 +divf <- breedR.getOption('default.initial.variance') + test_that("The minimal add_animal specification checks without error and completes missing values",{ ## Try alternative correct specification formats: - add_animal_minimalspec <- list( - try(check_genetic(model = 'add_animal', - pedigree = ped, - id = id)), - try(check_genetic(model = 'add_animal', - pedigree = ped, - id = 'id', - data = dat)), - try(check_genetic(model = 'add_animal', - pedigree = as.data.frame(ped)[-(1:2),], - id = id)), - try(check_genetic(model = 'add', - pedigree = ped, - id = id)) + animal_minimalspec <- list( + list(model = 'add_animal', + pedigree = ped, + id = id), + list(model = 'add_animal', + pedigree = ped, + id = 'id', + data = dat), + list(model = 'add_animal', + pedigree = as.data.frame(ped)[-(1:2),], + id = id), + list(model = 'add', + pedigree = ped, + id = id) ) + + ## Single-trait + animal_check_input <- lapply(animal_minimalspec, c, response = list(dat$y)) + animal_checks <- + lapply(animal_check_input, function(x) try(do.call('check_genetic', x))) - for (x in add_animal_minimalspec) { + for (x in animal_checks) { expect_false(inherits(x, "try-error")) expect_true(setequal(names(x), @@ -41,279 +47,521 @@ test_that("The minimal add_animal specification checks without error and complet ## var.ini should have been added with the default value ## and the attribute 'var.ini.default' set to TRUE - expect_equal(x$var.ini, breedR.getOption('default.initial.variance')) + expect_equal(x$var.ini, eval(divf)(dat$y, digits = 2)) + expect_true(attr(x, 'var.ini.default')) + } + + ## Two-trait + animal_check_input <- lapply(animal_minimalspec, c, + response = list(cbind(dat$y, dat$z))) + animal_checks <- + lapply(animal_check_input, function(x) try(do.call('check_genetic', x))) + + for (x in animal_checks) { + expect_false(inherits(x, "try-error")) + + expect_true(setequal(names(x), + c('model', 'pedigree', 'id', 'var.ini', 'autofill'))) + + ## var.ini should have been added with the default value + ## and the attribute 'var.ini.default' set to TRUE + expect_equal(x$var.ini, eval(divf)(dat[, c('y', 'z')], digits = 2)) expect_true(attr(x, 'var.ini.default')) } }) -test_that("check_genetic() returns an error if missing values",{ - expect_error(check_genetic(pedigree = ped, id = id, var.ini = var.ini )) - expect_error(check_genetic(model = 'add_animal', pedigree = ped, var.ini = var.ini )) - expect_error(check_genetic(model = 'add_animal')) +test_that("check_genetic() returns an error if missing arguments",{ + expect_error(check_genetic(pedigree = ped, id = id, var.ini = var.ini), + 'model required') + expect_error(check_genetic(model = 'add_animal', pedigree = ped, var.ini = var.ini), + 'id required') + expect_error(check_genetic(model = 'add_animal'), 'pedigree required') }) -test_that("check_genetic() returns an error if var.ini is negative or null, or even not a number ",{ - expect_error(check_genetic(model = 'add_animal', pedigree = ped, id = id, var.ini = -1.1 )) - expect_error(check_genetic(model = 'add_animal', pedigree = ped, id = id, var.ini = 0 )) - expect_error(check_genetic(model = 'add_animal', pedigree = ped, id = id, var.ini = 'test' )) +test_that("check_genetic() returns an error if var.ini is inconsistent",{ + check_var <- function(x, Y = dat$y) + check_genetic(model = 'add_animal', + pedigree = ped, + id = id, + var.ini = x, + response = Y) + + ## var.ini not of right dimension + expect_error(check_var(1, Y = dat[, c('y', 'z')]), '2x2 matrix') }) test_that("check_genetic() returns an error if pedigree is not of class pedigree or data.frame ",{ - expect_error(check_genetic(model = 'add_animal', pedigree = FALSE, id = id, var.ini = var.ini )) + expect_error(check_genetic(model = 'add_animal', + pedigree = FALSE, + id = id, + var.ini = var.ini), + 'argument pedigree') }) -##Model competition## +## Model competition ## coordinates <- matrix(c(1,2,-1,0,0,1,-1,1),4,2) var.ini.mat <- matrix(c(1, -.5, -.5, 1), 2, 2) pec<- list(a = FALSE, b = TRUE, c = FALSE) -test_that("The competition model runs without error",{ +test_that("Correctly-specified competition models runs without error",{ ## Try alternative correct specification formats: comp_minimalspec <- list( - try(check_genetic(model = 'competition', - pedigree = ped, # pedigree - id = id, # vector - coordinates = coordinates, # matrix - pec = TRUE)), # logical spec; default var.ini - try(check_genetic(model = 'competition', - pedigree = ped, # pedigree - id = 'id', # variable name with data spec - coordinates = as.data.frame(coordinates), # data.frame - pec = list(var = 1), # list spec with var.ini abbrev. - var.ini = var.ini.mat, # user var.ini - data = dat)), - try(check_genetic(model = 'competition', - pedigree = as.data.frame(ped)[-(1:2),], # data.frame obs. - id = id, # vector - coordinates = as.list(as.data.frame(coordinates)), # list - pec = list(present = TRUE, var.ini = 2), # full spec - var.ini = var.ini.mat)), # var.ini spec - try(check_genetic(model = 'comp', # abbreviated name - pedigree = ped, # pedigree - id = id, # vector - coordinates = coordinates, # matrix - pec = list(pres = TRUE))) # list spec; default var.ini + list(model = 'competition', + pedigree = ped, # pedigree + id = id, # vector + coordinates = coordinates, # matrix + pec = TRUE), # logical spec; default var.ini + list(model = 'competition', + pedigree = ped, # pedigree + id = 'id', # variable name with data spec + coordinates = as.data.frame(coordinates), # data.frame + pec = list(var = 1), # list spec with var.ini abbrev. + var.ini = var.ini.mat, # user var.ini + data = dat), + list(model = 'competition', + pedigree = as.data.frame(ped)[-(1:2),], # data.frame obs. + id = id, # vector + coordinates = as.list(as.data.frame(coordinates)), # list + pec = list(present = TRUE, var.ini = 2), # full spec + var.ini = var.ini.mat), # var.ini spec + list(model = 'comp', # abbreviated name + pedigree = ped, # pedigree + id = id, # vector + coordinates = coordinates, # matrix + pec = list(pres = TRUE)) # list spec; default var.ini ) - for (i in seq.int(comp_minimalspec)) { - x <- comp_minimalspec[[i]] - var.ini.default <- c(TRUE, FALSE, FALSE, TRUE) - - expect_false(inherits(x, "try-error")) - - expect_true(setequal(names(x), - c('model', 'pedigree', 'id', 'coordinates', 'pec', - 'competition_decay', 'var.ini', 'autofill'))) + ## Single-trait + comp_check_input <- lapply(comp_minimalspec, c, response = list(dat$y)) - expect_true(setequal(names(x$pec), c('present', 'var.ini'))) - - ## var.ini should have been added with the default value - ## in the cases where isTRUE(var.ini.default[[i]]) - ## and the attribute 'var.ini.default' set to TRUE - var.ini.def <- diag(breedR.getOption('default.initial.variance'), 2) - var.ini.def[1,2] <- var.ini.def[2,1] <- -var.ini.def[1,1]/2 - - if (var.ini.default[[i]]) { - expect_equal(x$var.ini, var.ini.def) - } - - expect_equal(attr(x, 'var.ini.default'), var.ini.default[[i]]) - } + comp_checks <- + lapply(comp_check_input, function(x) do.call('check_genetic', x)) + + all.names <- c('model', 'pedigree', 'id', 'coordinates', 'pec', + 'competition_decay', 'var.ini', 'autofill') + expect_true(all(sapply(lapply(comp_checks, names), setequal, all.names))) + + pec.names <- lapply(lapply(comp_checks, function(x) x$pec), names) + expect_true(all(sapply(pec.names, setequal, c('present', 'var.ini')))) + + ## var.ini should have been added with the default value + ## in the cases where isTRUE(var.ini.default[[i]]) + ## and the attribute 'var.ini.default' set to TRUE + expect_defvar <- eval(divf)(dat$y, dim = 2, digits = 2) + expect_var <- list(expect_defvar, var.ini.mat, var.ini.mat, expect_defvar) + expect_identical(lapply(comp_checks, function(x) x$var.ini), + expect_var) + + expect_var.ini.default <- c(TRUE, FALSE, FALSE, TRUE) + expect_identical(sapply(comp_checks, attr, 'var.ini.default'), + expect_var.ini.default) + + + ## Two traits + var.ini.mat <- Matrix::bdiag(list(var.ini.mat, var.ini.mat)) + comp_minimalspec[[2]]$var.ini <- comp_minimalspec[[3]]$var.ini <- var.ini.mat + comp_check_input <- lapply(comp_minimalspec, c, + response = list(dat[, c('y', 'z')])) + comp_checks <- + lapply(comp_check_input, function(x) do.call('check_genetic', x)) + + all.names <- c('model', 'pedigree', 'id', 'coordinates', 'pec', + 'competition_decay', 'var.ini', 'autofill') + expect_true(all(sapply(lapply(comp_checks, names), setequal, all.names))) + + pec.names <- lapply(lapply(comp_checks, function(x) x$pec), names) + expect_true(all(sapply(pec.names, setequal, c('present', 'var.ini')))) + + ## var.ini should have been added with the default value + ## in the cases where isTRUE(var.ini.default[[i]]) + ## and the attribute 'var.ini.default' set to TRUE + expect_defvar <- eval(divf)(dat[, c('y', 'z')], dim = 2, digits = 2) + expect_var <- list(expect_defvar, var.ini.mat, var.ini.mat, expect_defvar) + expect_identical(lapply(comp_checks, function(x) x$var.ini), + expect_var) + + expect_var.ini.default <- c(TRUE, FALSE, FALSE, TRUE) + expect_identical(sapply(comp_checks, attr, 'var.ini.default'), + expect_var.ini.default) + }) -test_that("check_genetic() returns an error if missing 'coordinates' component",{ - expect_error(check_genetic( - model = 'competition', pedigree = ped, id = id, var.ini = var.ini - )) +test_that("check_genetic() returns an error if missing arguments",{ + expect_error(check_genetic(model = 'competition', + pedigree = ped, + id = id, + var.ini = var.ini.mat, + response = dat$y), + 'coordinates required') }) -test_that("check_genetic() returns an error if var.ini is not a SPD matrix",{ +test_that("check_genetic() returns an error if var.ini is incorrect",{ + + ## Single trait expect_error( check_genetic( model = 'competition', pedigree = ped, coordinates = coordinates, - id = id, var.ini = diag(8,2,3) - ) + id = id, var.ini = diag(-1,4,4), response = dat$y + ), + '2x2 matrix' ) + + ## Two traits expect_error( check_genetic( model = 'competition', pedigree = ped, coordinates = coordinates, - id = id, var.ini = diag(-1,4,4) - ) + id = id, var.ini = diag(1,2,2), response = dat[, c('y', 'z')] + ), + '4x4 matrix' ) }) test_that("check_genetic() returns an error if coordinates has not exactly two columns",{ expect_error( check_genetic( - model = 'competition', pedigree = ped, id = id, var.ini = var.ini - , coordinates = matrix(c(1,4,6,8,5,2,3,1,5,2,1,1),4,3) - ) + model = 'competition', pedigree = ped, id = id, var.ini = var.ini.mat + , coordinates = matrix(c(1,4,6,8,5,2,3,1,5,2,1,1),4,3), response = dat$y + ), + 'two dimensions admitted for coordinates' ) }) test_that("check_genetic() returns an error if pec is not a named list with logical elements",{ expect_error( check_genetic( - model = 'competition', pedigree = ped, id = id, var.ini = var.ini - , coordinates = coordinates, pec = list(FALSE, TRUE, TRUE) - ) + model = 'competition', + pedigree = ped, + id = id, + var.ini = var.ini.mat, + coordinates = coordinates, + pec = list(FALSE, TRUE, TRUE), + response = dat$y + ), + 'pec must be a named list' ) + expect_error( check_genetic( - model = 'competition', pedigree = ped, id = id, var.ini = var.ini - , coordinates = coordinates, pec = list(a = 5, b = - 'TRUE', c = TRUE) - ) + model = 'competition', + pedigree = ped, + id = id, + var.ini = var.ini.mat , + coordinates = coordinates, + pec = list(a = 5, b = 'TRUE', c = TRUE), + response = dat$y + ), + 'should be one of' ) }) test_that("check_genetic() returns an error if competition_decay is not a positive number",{ expect_error( check_genetic( - model = 'competition', pedigree = ped, id = id, var.ini = var.ini - , coordinates = coordinates, pec = pec, competition_decay = -5 - ) + model = 'competition', pedigree = ped, id = id, var.ini = var.ini.mat, + coordinates = coordinates, pec = 1, competition_decay = -5, response = dat$y + ), + 'competition_decay > 0' ) + expect_error( check_genetic( - model = 'competition', pedigree = ped, id = id, var.ini = var.ini - , coordinates = coordinates, pec = pec, competition_decay = 'test' - ) + model = 'competition', pedigree = ped, id = id, var.ini = var.ini.mat, + coordinates = coordinates, pec = 1, competition_decay = 'test', response = dat$y + ), + 'is.numeric\\(competition_decay\\)' ) }) ## Spatial +var.ini <- 1.2 -## Model splines## -var.ini <- 1.2 +## Model splines ## n.knots <- c(7,7) -test_that("Minimal specification of splines",{ - test_splines <- check_spatial(model = 'splines', - coordinates = coordinates) - x <- test_splines - expect_false(inherits(x, "try-error")) +test_that("Minimal correct specification of splines",{ - expect_true(all(names(x) %in% + ## One trait + spl_check <- check_spatial(model = 'splines', + coordinates = coordinates, + response = dat$y) + + expect_false(inherits(spl_check, "try-error")) + + expect_true(all(names(spl_check) %in% + c('model', 'coordinates', 'var.ini', 'autofill', 'sparse'))) + + ## var.ini should have been added with the default value + ## and the attribute 'var.ini.default' set to TRUE + expect_equal(spl_check$var.ini, eval(divf)(dat$y, digits = 2)) + expect_true(attr(spl_check, 'var.ini.default')) + + ## Two traits + spl_check <- check_spatial(model = 'splines', + coordinates = coordinates, + response = dat[, c('y', 'z')]) + + expect_false(inherits(spl_check, "try-error")) + + expect_true(all(names(spl_check) %in% c('model', 'coordinates', 'var.ini', 'autofill', 'sparse'))) ## var.ini should have been added with the default value ## and the attribute 'var.ini.default' set to TRUE - expect_equal(x$var.ini, breedR.getOption('default.initial.variance')) - expect_true(attr(x, 'var.ini.default')) + expect_equal(spl_check$var.ini, eval(divf)(dat[, c('y', 'z')], digits = 2)) + expect_true(attr(spl_check, 'var.ini.default')) }) -test_that("Full specification of splines",{ - test_splines <- check_spatial(model = 'splines', - coordinates = coordinates, - n.knots = n.knots, - var.ini = var.ini) - expect_false(inherits(test_splines, "try-error")) +test_that("Full correct specification of splines",{ + + ## One trait + spl_check <- check_spatial(model = 'splines', + coordinates = coordinates, + n.knots = n.knots, + var.ini = var.ini, + response = dat$y) + expect_false(inherits(spl_check, "try-error")) + + ## Two traits + spl_check <- check_spatial(model = 'splines', + coordinates = coordinates, + n.knots = n.knots, + var.ini = diag(rep(var.ini, 2)), + response = dat[, c('y', 'z')]) + expect_false(inherits(spl_check, "try-error")) }) -test_that("check_spatial returns an error if missing 'coordinates' component",{ +test_that("check_spatial() errors if 'coordinates' is wrongly specified",{ + expect_error(check_spatial(model = 'splines', n.knots = n.knots, - var.ini = var.ini)) -}) + var.ini = var.ini, + response = dat$y), + 'coordinates required') -test_that("check_spatial returns an error if n.knots is not a vector of two integers",{ - expect_error(check_spatial(model = 'splines', coordinates = coordinates, n.knots = c(3,3,3) - , var.ini = var.ini)) - expect_error(check_spatial(model = 'splines', coordinates = coordinates, n.knots = TRUE - , var.ini = var.ini)) - expect_error(check_spatial(model = 'splines', coordinates = coordinates, n.knots = c(1.2,1.2) - , var.ini = var.ini)) + expect_error(check_spatial(model = 'splines', + coordinates = diag(3), + n.knots = n.knots, + var.ini = var.ini, + response = dat$y), + 'Only two dimensions admitted for coordinates') }) -## Model AR## -rho <- c(0.3,0.3) - -test_that("The AR model runs without error",{ - test_ar <- check_spatial(model = 'AR', coordinates = coordinates, rho = rho, var.ini = var.ini) - expect_false(inherits(test_ar, "try-error")) +test_that("check_spatial() errors if 'n.knots' is wrongly specified",{ + + expect_nk_error <- function(x) + eval(bquote( + expect_error( + check_spatial(model = 'splines', + coordinates = coordinates, + n.knots = .(x), + var.ini = var.ini, + response = dat$y), + 'n.knots must be a vector of two integers') + )) + + expect_nk_error(c(3,3,3)) + expect_nk_error(TRUE) + expect_nk_error(c(1.2,1.2)) + }) -test_that("check_spatial returns an error if coordinates is not a two-dimensions vector",{ - expect_error(check_spatial(model = 'AR', coordinates = diag(3), rho = rho, var.ini = var.ini)) -}) +test_that("check_spatial() errors if var.ini is inconsistent",{ + + ## Single trait + expect_error( + check_spatial( + model = 'splines', coordinates = coordinates, + id = id, var.ini = diag(-1,4,4), response = dat$y + ), + '1x1 matrix' + ) -test_that("check_spatial returns an error if rho does not contain what is expected",{ - expect_error(check_spatial(model = 'AR', coordinates = coordinates, rho = c(-2,1), var.ini = var.ini), - 'must contain numbers strictly between -1 and 1') - expect_error(check_spatial(model = 'AR', coordinates = coordinates, rho = matrix(c(0.5,0,1,0),2,2), var.ini = var.ini), - 'must contain numbers strictly between -1 and 1') - expect_error(check_spatial(model = 'AR', coordinates = coordinates, rho = c(.1,.1,.1), var.ini = var.ini), - 'must contain exactly two components') - expect_error(check_spatial(model = 'AR', coordinates = coordinates, rho = 'test', var.ini = var.ini), - 'must be numeric') + ## Two traits + expect_error( + check_spatial( + model = 'splines', coordinates = coordinates, + id = id, var.ini = diag(1,4,4), response = dat[, c('y', 'z')] + ), + '2x2 matrix' + ) }) -## Generic +## Model AR ## +rho <- c(0.3,0.3) -x1 <- list(inc = matrix((1:12),4,3), cov = diag(3), var.ini = 6) -x2 <- list(inc = matrix((3:8),3,2), pre = diag(2), var.ini = 4) -x <- list (a = x1, b = x2) +test_that("The AR model runs without error",{ + + ## One trait + ar_check <- check_spatial(model = 'AR', + coordinates = coordinates, + rho = rho, + response = dat$y) + + expect_false(inherits(ar_check, "try-error")) + expect_true(all(names(ar_check) %in% + c('model', 'coordinates', 'rho', 'var.ini', 'autofill', 'sparse'))) + + ## var.ini should have been added with the default value + ## and the attribute 'var.ini.default' set to TRUE + expect_equal(ar_check$var.ini, eval(divf)(dat$y, digits = 2)) + expect_true(attr(ar_check, 'var.ini.default')) + + ## Two traits + ar_check <- check_spatial(model = 'AR', + coordinates = coordinates, + rho = rho, + response = dat[, c('y', 'z')]) + + expect_false(inherits(ar_check, "try-error")) + expect_true(all(names(ar_check) %in% + c('model', 'coordinates', 'rho', 'var.ini', 'autofill', 'sparse'))) + + ## var.ini should have been added with the default value + ## and the attribute 'var.ini.default' set to TRUE + expect_equal(ar_check$var.ini, eval(divf)(dat[, c('y', 'z')], digits = 2)) + expect_true(attr(ar_check, 'var.ini.default')) + +}) + +test_that("check_spatial() errors if 'coordinates' is wrongly specified",{ + expect_error(check_spatial(model = 'AR', + rho = rho, + var.ini = var.ini), + 'coordinates required') -test_that("The function check_generic runs without error",{ - test_gen <- check_generic(x) - expect_false(inherits(test_gen, "try-error")) + expect_error(check_spatial(model = 'AR', + coordinates = diag(3), + rho = rho, + var.ini = var.ini), + 'Only two dimensions admitted for coordinates') }) +test_that("check_spatial() errors if 'rho' is incorrectly specified",{ + + expect_rho <- function(x, msg) { + eval(bquote( + expect_error( + check_spatial(model = 'AR', + coordinates = coordinates, + rho = .(x), + var.ini = var.ini, + response = dat$y), + msg) + )) + } + + expect_rho(c(-2,1), 'strictly between -1 and 1') + expect_rho(matrix(c(0.5,0,1,0),2,2), 'strictly between -1 and 1') + expect_rho(c(.1,.1,.1), 'exactly two components') + expect_rho('test', 'be numeric') -test_that("check_generic returns null if specification is empty",{ - expect_null(check_generic()) }) -test_that("check_generic returns an error if argument x is not a list",{ - expect_error(check_generic(c(1,1))) +test_that("check_spatial() errors if var.ini is inconsistent",{ + + ## Single trait + expect_error( + check_spatial( + model = 'AR', coordinates = coordinates, + id = id, var.ini = diag(-1,4,4), response = dat$y + ), + '1x1 matrix' + ) + + ## Two traits + expect_error( + check_spatial( + model = 'AR', coordinates = coordinates, + id = id, var.ini = diag(1,4,4), response = dat[, c('y', 'z')] + ), + '2x2 matrix' + ) }) -test_that("check_generic returns an error if argument x not a named list",{ - expect_error(check_generic(list(x1, x2))) -}) -test_that("check_generic returns an error if all elements in x are not lists",{ - expect_error(check_generic(list(a = x1, b = x2, c = 5))) -}) -test_that("check_generic returns an error if x is not a named list with different names",{ - expect_error(check_generic(list(a = x1, a = x2))) -}) +## Generic +x1 <- list(inc = matrix((1:12),4,3), cov = diag(3), var.ini = 6) +x2 <- list(inc = matrix((3:8),3,2), pre = diag(2), var.ini = 4) +x <- list (a = x1, b = x2) -test_that("check_generic returns an error if the incidence matrix is missing",{ - expect_error(check_generic(list(a = list( cov = diag(3), var.ini = 6)))) -}) -test_that("check_generic returns an error if both covariance and precision matrix are given",{ - expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), cov = diag(3), - pre = diag(2), var.ini = 6)))) -}) +test_that("Correct specification of individual generic elements", { -test_that("check_generic returns an error if both covariance and precision matrix are missing",{ - expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), var.ini = 6)))) + expect_ok <- function(x, Y) { + eval(bquote( + expect_error(do.call('validate_generic_element', + c(.(x), response = list(.(Y)))), + NA) + )) + } + + ## Single trait + expect_ok(x1, dat$y) + expect_ok(x2, dat$y) + expect_ok(x1[-3], dat$y) + expect_ok(x2[-3], dat$y) + + ## Two traits + x1$var.ini <- x2$var.ini <- diag(1,2) + expect_ok(x1, dat[, c('y', 'z')]) + expect_ok(x2, dat[, c('y', 'z')]) + expect_ok(x1[-3], dat[, c('y', 'z')]) + expect_ok(x2[-3], dat[, c('y', 'z')]) + }) -test_that("check_generic returns an error if cov is not a matrix",{ - expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), cov = 'test', var.ini = 6)))) - expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), cov = c(1:3), var.ini = 6)))) +test_that("Correct specifications of check_generic()",{ + expect_error(check_generic(x, response = dat$y), NA) }) -test_that("check_generic returns an error if the dimensions are inconsistent",{ - expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), cov = diag(5), var.ini = 6)))) + +test_that("check_generic returns null if specification is empty",{ + expect_null(check_generic()) }) -test_that("check_generic returns an error var. ini is not a positive number",{ - expect_error(check_generic(list(a = x1, b = list(inc = matrix((3:8),3,2), pre = diag(2), var.ini = -5)))) - expect_error(check_generic(list(a = x1, b = list(inc = matrix((3:8),3,2), pre = diag(2), var.ini = 'test')))) +test_that("check_generic() errors if specification is wrong",{ + + expect_error(check_generic(c(1,1)), 'be a list') + + expect_error(check_generic(list(x1, x2)), 'be a named list') + + expect_error(check_generic(list(a = x1, b = x2, c = 5)), 'be list elements') + + expect_error(check_generic(list(a = x1, a = x2)), 'different names') + + expect_error(check_generic(list(a = list(cov = diag(3), var.ini = 6)), + response = dat$y), 'incidence required') + + expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), + cov = diag(3), + pre = diag(2))), + response = dat$y), + 'one argument between covariance and precision') + + expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), var.ini = 6)), + response = dat$y), + 'one argument between covariance and precision') + + expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), cov = 'test')), + response = dat$y), + 'covariance must be of type matrix') + + expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), cov = c(1:3))), + response = dat$y), + 'covariance must be of type matrix') + + expect_error(check_generic(list(a = list(inc = matrix((1:12),4,3), cov = diag(5))), + response = dat$y), + 'conformant incidence and covariance') }) @@ -326,11 +574,130 @@ test_that('validate_variance() returns TRUE for correct variance specifications' expect_true(validate_variance(1.5)) expect_true(validate_variance(1000)) expect_true(validate_variance(matrix(c(1,-.5,-.5,1), 2, 2))) + + ## sparse matrices + expect_true(validate_variance(Matrix::bdiag(matrix(c(1,-.5,-.5,1), 2, 2)))) + + ## named (possibly differently) matrices + testM <- structure(matrix(c(1,-.5,-.5,1),2,2), + dimnames = list(1:2, 3:4)) + expect_true(validate_variance(testM)) }) test_that('validate_variance() stops for inconsistent values of variance', { - expect_error(validate_variance(0), 'positive number') expect_error(validate_variance(c(1, 1)), 'square matrix') + expect_error(validate_variance(c(1, 1), dim = c(1,1)), 'square matrix') + expect_error(validate_variance(c(1, 1), dim = c(1,2)), 'square matrix') + + expect_error(validate_variance(0), 'SPD matrix') expect_error(validate_variance(matrix(1, 2, 2)), 'SPD matrix') - expect_error(validate_variance(-1.5, where = 'test'), 'positive number in the test') + expect_error(validate_variance(-1.5, where = 'test'), 'SPD matrix') + + expect_error(validate_variance(1, dim = c(2,2)), '2x2 matrix') +}) + +test_that('default_initial_variance() works as expected', { + + ## One trait: always return half the phenotypic variance + x <- runif(100) + + expect_identical(as.matrix(var(x)/2), default_initial_variance(x)) + expect_identical(as.matrix(var(x)/2), default_initial_variance(x, cor.trait = 0)) + expect_identical(as.matrix(var(x)/2), default_initial_variance(x, cor.effect = 0)) + + ## One trait - 2 dimensional effect (e.g. competition) + x <- runif(100) + dim = 2 + default.covar <- 0.1*var(x)/2 + + div <- default_initial_variance(x, dim = dim) + expect_equal(rep(as.matrix(var(x)/2), dim), diag(div)) + expect_equal(default.covar, div[2,1]) + expect_equal(default.covar, div[1,2]) + + div <- default_initial_variance(x, dim = dim, cor.effect = 0) + expect_identical(rep(as.matrix(var(x)/2), dim), diag(div)) + expect_identical(0, div[2,1]) + + ## 5 traits: half phenotypic variance of each trait and default covariances + ## unless diag + x <- matrix(runif(500), ncol=5) + + expect_equal(default_initial_variance(x), var(x)/2) + + expect_equal(default_initial_variance(x, cor.trait = 0), + diag(diag(var(x)/2))) + + ## Fail at constant traits + x[, 5] <- 123 + expect_error(default_initial_variance(x), 'Trait 5 is constant.') + + ## 2 traits - 2 dimensions: positive definiteness + x <- data.frame(y=rnorm(4), z=rnorm(4, sd = 2)) + varx <- default_initial_variance(x, dim = 2) + expect_error(validate_variance(varx), NA) + +}) + +test_that('The variance checker check.var_ini() works as expected', { + + test_response <- 1:4 + div_fun <- breedR.getOption('default.initial.variance') + default_ini <- + eval(div_fun)(test_response, dim = 1, cor.trait = NULL, digits = 2) + + test_list <- list( + minimal = list( + input = list(x = NULL, random = NULL, response = test_response), + expect_error = NA, + expect_output = structure( + list(residuals = default_ini), + var.ini.default = TRUE) + ), + default = list( + input = list(x = NULL, random = ~ bl + fam, response = test_response), + expect_error = NA, + expect_output = structure( + list(bl = default_ini, + fam = default_ini, + residuals = default_ini), + var.ini.default = TRUE) + ), + full = list( + input = list(x = list(bl = 1, fam = 2, residuals = 3), + random = ~ bl + fam, response = test_response), + expect_error = NA, + expect_output = structure( + list(bl = 1, fam = 2, residuals = 3), + var.ini.default = FALSE) + ), + missing_ranef = list( + input = list(x = list(bl = 1, residuals = 3), + random = ~ bl + fam, response = test_response), + expect_error = NULL, + expect_output = NA + ) + ) + + expect_result <- function(x) { + eval(bquote( + expect_error( + res <- do.call('check_var.ini', .(x$input)), + .(x$expect_error)) + )) + + if (anyNA(x$expect_error)) { + eval(bquote( + expect_equal(res, .(x$expect_output)) + )) + } + } + + for (x in test_list) { + expect_result(x) + } + + + ## two traits + }) diff --git a/tests/testthat/test-competition.R b/tests/testthat/test-competition.R index d1d03cd..ca74aca 100644 --- a/tests/testthat/test-competition.R +++ b/tests/testthat/test-competition.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) #### Context: competition infrastructure #### @@ -13,19 +10,19 @@ dat <- data.frame(id = 1:6, x = c(1,2,-1,0,0,1), y = c(-1,0,0,1,-1,1)) ## Corresponding pedigree with additional offspring -ped <- build_pedigree(1:3, data = rbind(dat, c(7, 1, 2))) -var.ini <- 1.5 +ped <- suppressWarnings(build_pedigree(1:3, data = rbind(dat, c(7, 1, 2)))) var.ini.mat <- matrix(c(1, -.5, -.5, 1), 2, 2) -test_that("Valid alternative model specifications pass checks", { - ## specify var.ini, but use pec=FALSE +test_that("Valid alternative model specifications pass check_genetic()", { + ## specify var.ini, but use pec=FALSE (as by default) expect_error( check_genetic(model = 'competition', pedigree = ped, coordinates = dat[, c('x', 'y')], id = dat$id, - var.ini = var.ini), + var.ini = var.ini.mat, + response = rnorm(nrow(dat))), NA ) @@ -37,7 +34,8 @@ test_that("Valid alternative model specifications pass checks", { pedigree = dat[, 1:3], coordinates = dat[, c('x', 'y')], id = dat$id, - var.ini = var.ini), + var.ini = var.ini.mat, + response = rnorm(nrow(dat))), NA ) @@ -45,17 +43,8 @@ test_that("Valid alternative model specifications pass checks", { -test_that("Invalid alternative model specifications fail checks", { - ## specify var.ini, but use pec=FALSE - expect_error( - check_genetic(model = 'competition', - pedigree = ped, - coordinates = dat[, c('x', 'y')], - id = dat$id, - var.ini = var.ini), - NA - ) - +test_that("Invalid alternative model specifications fail check_genetic()", { + ## incomplete non-recoded pedigrees idx <- attr(ped, 'map')[dat$id] dat[, 1:3] <- as.data.frame(ped)[idx, ] @@ -64,7 +53,8 @@ test_that("Invalid alternative model specifications fail checks", { pedigree = dat[-nrow(dat), 1:3], coordinates = dat[, c('x', 'y')], id = dat$id, - var.ini = var.ini), + var.ini = var.ini.mat, + response = rnorm(nrow(dat))), 'The following individuals in id are not represented' ) }) @@ -73,18 +63,25 @@ test_that("Invalid alternative model specifications fail checks", { test_that("additive_genetic_competition() works as expected", { ## Full specification, from minimal input - comp.spec <- check_genetic(model = 'competition', - pedigree = ped, - id = dat$id, - coordinates = dat[, c('x', 'y')], - pec = TRUE) + comp.spec <- check_genetic( + model = 'competition', + pedigree = ped, + id = dat$id, + coordinates = dat[, c('x', 'y')], + pec = TRUE, + response = rnorm(nrow(dat)) + ) - res <- with(comp.spec, - additive_genetic_competition(pedigree = pedigree, - coordinates = coordinates, - id = id, - decay = competition_decay, - autofill = autofill)) + res <- with( + comp.spec, + additive_genetic_competition( + pedigree = pedigree, + coordinates = coordinates, + id = id, + decay = competition_decay, + autofill = autofill + ) + ) expect_is(res, c("additive_genetic_competition", "additive_genetic", "genetic", "competition", "spatial", "random", "breedr_effect")) diff --git a/tests/testthat/test-effect_group.R b/tests/testthat/test-effect_group.R index 283a242..58f8d0e 100644 --- a/tests/testthat/test-effect_group.R +++ b/tests/testthat/test-effect_group.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Test the effect_group constructor ### @@ -10,7 +7,15 @@ context("effect_group() constructor") test_that('Valid specs of effect groups pass checks', { # one-element effect_group - expect_error(effect_group(list(breedr_effect(1)), cov.ini = 1), NA) + expect_error( + effect_group(list(breedr_effect(1)), cov.ini = 1, ntraits = 1), + NA + ) + + expect_error( + effect_group(list(breedr_effect(1)), cov.ini = diag(2), ntraits = 2), + NA + ) # two-element effect_group eflst <- list(breedr_effect(1), breedr_effect(2)) @@ -26,8 +31,22 @@ test_that('Valid specs of effect groups pass checks', { Matrix::Diagonal(2) # Matrix class ) - expect_cov_ok <- function(x) - eval(bquote(expect_error(effect_group(eflst, cov.ini = .(x)), NA))) + expect_cov_ok <- function(x) { + eval(bquote( + expect_error( + effect_group(eflst, cov.ini = .(x), ntraits = 1), + NA + ) + )) + + xx <- kronecker(as.matrix(x), diag(2)) + eval(bquote( + expect_error( + effect_group(eflst, cov.ini = .(xx), ntraits = 2), + NA + ) + )) + } for(x in matlst) expect_cov_ok(x) @@ -39,32 +58,26 @@ test_that('Invalid specs of effect groups are caught by checks', { x <- list(breedr_effect(1)) # a valid list of (one) effect # missing x - expect_error(effect_group(cov.ini = 1)) + # the specific error msg is locale-dependent + expect_error(effect_group(cov.ini = 1, ntraits = 1)) # missing cov.ini - expect_error(effect_group(x)) + # the specific error msg is locale-dependent + expect_error(effect_group(x, ntraits = 1)) # x not a list - expect_error(effect_group(1, 1), 'is.list.*? is not TRUE') + expect_error(effect_group(1, 1, ntraits = 1), 'is.list.*? is not TRUE') # cov.ini not like a matrix - expect_error(effect_group(x, 'a'), + expect_error(effect_group(x, 'a', ntraits = 1), 'is.numeric.*? is not TRUE') # element in x not a breedr_effect # here x is a list and a breedr_effect, but not its elements. - expect_error(effect_group(breedr_effect(1), 1), + expect_error(effect_group(breedr_effect(1), 1, ntraits = 1), 'must be of class breedr_effect') - # cov.ini not symmetric - expect_error(effect_group(c(x, x), matrix(1:4, 2)), - 'isSymmetric.*? is not TRUE') - - # cov.ini not positive-definite - expect_error(effect_group(c(x, x), matrix(rep(1, 4), 2)), - 'all\\(ev > 0\\) is not TRUE') - # non coforming dimensions - expect_error(effect_group(x, diag(1:2)), 'do not conform') - + expect_error(effect_group(x, diag(1:2), ntraits = 1), 'do not conform') + expect_error(effect_group(x, cov.ini = 1, ntraits = 2), 'do not conform') }) diff --git a/tests/testthat/test-generic.R b/tests/testthat/test-generic.R index bc919f6..2d2d60c 100644 --- a/tests/testthat/test-generic.R +++ b/tests/testthat/test-generic.R @@ -1,10 +1,7 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Test the generic model ### -context("Generic model") +context("Generic infrastructure") test.inc8x4 <- as(rep(1:4, 2), 'indMatrix') # An 8x4 incidence matrix test.cov4x4 <- with(L <- Matrix::tril(matrix(sample(16),4)), @@ -52,147 +49,3 @@ test_that('generic() takes either covariance or precision matrices', { # - model.matrix.breedr_effect() # - random() # - vcov.random() - - - - -context("Extraction of results from generic model") -######################## - -dat <- globulus - -fixed.fml <- phe_X ~ gg + x -n.obs <- nrow(dat) -n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) -nlevels.fixed <- nlevels(dat$gg) + 1 -nlevels.random <- nlevels(dat$bl) - -inc.mat <- model.matrix(~ 0 + bl, globulus) -cov.mat <- diag(nlevels(globulus$bl)) - -res <- try( - suppressMessages( - remlf90( - fixed = fixed.fml, - generic = list(bl = list(inc.mat, - cov.mat)), - data = dat) - ) -) - - - -test_that("The generic model runs with AI-REML without errors", { - expect_error(res, NA) -}) - -test_that("coef() gets a named vector of coefficients", { - expect_is(coef(res), 'numeric') - expect_equal(length(coef(res)), nlevels.fixed + nlevels.random) - expect_named(coef(res)) -}) - -test_that("ExtractAIC() gets one number", { - expect_is(extractAIC(res), 'numeric') - expect_equal(length(extractAIC(res)), 1) -}) - -test_that("fitted() gets a vector of length N", { - expect_is(fitted(res), 'numeric') - expect_equal(length(fitted(res)), n.obs) -}) - -test_that("fixef() gets a named list of data.frames with estimated values and s.e.", { - x <- fixef(res) - expect_is(x, 'list') - expect_named(x) - expect_equal(length(x), n.fixed) - for (f in x) { - expect_is(f, 'data.frame') - expect_named(f, c('value', 's.e.')) - } -}) - -test_that("get_pedigree() returns NULL", { - expect_null(get_pedigree(res)) -}) - -test_that("logLik() gets an object of class logLik", { - expect_is(logLik(res), 'logLik') -}) - -test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { - x <- model.frame(res) - expect_is(x, 'data.frame') - expect_is(terms(x), 'terms') - expect_equal(dim(x), c(n.obs, n.fixed + 1)) -}) - -test_that("model.matrix() gets a named list of fixed and random incidence matrices", { - x <- model.matrix(res) - expect_is(x, 'list') - expect_named(x, names(res$effects)) - expect_equal(dim(x$gg), c(n.obs, nlevels.fixed-1)) - expect_equal(dim(x$x), c(n.obs, 1)) - expect_is(x$bl, 'sparseMatrix') - expect_equal(dim(x$bl), c(n.obs, nlevels.random)) -}) - -test_that("nobs() gets the number of observations", { - expect_equal(nobs(res), n.obs) -}) - -test_that("plot(, type = *) returns ggplot objects after providing coords", { - ## An error mesage is expected as the spatial structure is missing - expect_error(suppressMessages(plot(res, type = 'phenotype')), - 'Missing spatial structure') - - ## We can still plot phenotype, fitted and residuals if provide coords - coordinates(res) <- dat[, c('x', 'y')] - expect_is(plot(res, type = 'phenotype'), 'ggplot') - expect_is(plot(res, type = 'fitted'), 'ggplot') - expect_is(plot(res, type = 'residuals'), 'ggplot') - - ## But still get errors for the absent spatial components - expect_error(plot(res, type = 'spatial'), 'no spatial effect') - expect_error(plot(res, type = 'fullspatial'), 'no spatial effect') -}) - -test_that("print() shows some basic information", { - ## Not very informative currently... - expect_output(print(res), 'Data') -}) - -test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { - x <- ranef(res) - expect_is(x, 'ranef.breedR') - expect_equal(length(x), 1) - expect_named(x, c('bl')) - - expect_is(x$bl, 'numeric') - expect_equal(length(x$bl), nlevels.random) - expect_false(is.null(xse <- attr(x$bl, 'se'))) - - expect_is(xse, 'numeric') - expect_equal(length(xse), nlevels.random) -}) - -test_that("residuals() gets a vector of length N", { - rsd <- residuals(res) - expect_is(rsd, 'numeric') - expect_equal(length(rsd), n.obs) -}) - -test_that("summary() shows summary information", { - expect_output(print(summary(res)), 'Variance components') -}) - -test_that("vcov() gets the covariance matrix of the bl component of the observations", { - - ## Make it available after refactoring - ## when we can recover the structure and model matrices - expect_error(vcov(res, effect = 'bl'), 'should be one of') - # expect_is(x, 'Matrix') - # expect_equal(dim(x), rep(n.obs, 2)) -}) - diff --git a/tests/testthat/test-get_structure.R b/tests/testthat/test-get_structure.R index ea5b74c..3fe3e0f 100644 --- a/tests/testthat/test-get_structure.R +++ b/tests/testthat/test-get_structure.R @@ -1,9 +1,7 @@ ### Test the functions for getting the structure matrices ### -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) +#### Context: Extracting structure matrices #### context("Extracting structure matrices") ## Extracting structure matrices from simple breedR effects @@ -36,7 +34,7 @@ test_that('get_structure() recovers the right structure type', { ## Extracting structure matrices from groups of effects -eg <- effect_group(list(spl, gen), cov.ini = diag(1,2,2)) +eg <- effect_group(list(spl, gen), cov.ini = diag(1,2,2), ntraits = 1) eg.str <- get_structure(eg) test_that('get_structure() recovers the common structure in Matrix format', { @@ -48,12 +46,9 @@ test_that('get_structure() recovers the common structure in Matrix format', { ## Extracting structure matrices from breedR objects test_that('get_structure() retrieves an empty list from a model fit without random effects', { - res.ar <- suppressMessages( - remlf90(fixed = phe_X ~ gg, - data = globulus) - ) - - breedr.str <- get_structure(res.ar) + + res <- load_res("fixonly") + breedr.str <- get_structure(res) expect_is(breedr.str, 'list') expect_equal(breedr.str, list(), check.attributes = FALSE) @@ -61,16 +56,9 @@ test_that('get_structure() retrieves an empty list from a model fit without rand test_that('get_structure() retrieves a list of structure matrices from a model fit', { - res.ar <- suppressMessages( - remlf90(fixed = phe_X ~ 1, - random = ~ gg, - spatial = list(model = 'AR', - coord = globulus[, c('x','y')], - rho = c(.85, .8)), - data = globulus) - ) - - breedr.str <- get_structure(res.ar) + + res <- load_res("ar") + breedr.str <- get_structure(res) expect_is(breedr.str, 'list') sapply(breedr.str, expect_is, 'Matrix') diff --git a/tests/testthat/test-heritability.R b/tests/testthat/test-heritability.R index ff7c9e8..6602afa 100644 --- a/tests/testthat/test-heritability.R +++ b/tests/testthat/test-heritability.R @@ -1,12 +1,9 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Test the rendering to pf90 format ### context("Default heritability") -test_that('pf90_default_heritability() works as expected', { +test_that('pf90_default_heritability() works as expected for single trait', { ## empty list (no random effects) -> NULL rgl <- list() @@ -32,3 +29,37 @@ test_that('pf90_default_heritability() works as expected', { expect_identical(pf90_default_heritability(rgl), ans) }) + +test_that('pf90_default_heritability() works as expected for multiple traits', { + + trts <- paste("y", 1:3, sep = "_") + + ## empty list (no random effects) -> NULL + rgl <- list() + expect_null(pf90_default_heritability(rgl, traits = trts)) + + ## list with no genetic effect -> NULL + rgl <- list(a = list(pos = 1), b = list(pos = 2)) + expect_null(pf90_default_heritability(rgl, traits = trts)) + + ## list with genetic effect, and some group of correlated effects + ## -> don't know how to compute default herit. -> NULL + rgl <- list(a = list(pos = 1:2), genetic = list(pos = 3)) + expect_null(pf90_default_heritability(rgl, traits = trts)) + + ## list with a genetic effect alone -> s_a/(s_a+s_e) + rgl <- list(genetic = list(pos = 3)) + num <- paste("G", 3, 3, seq_along(trts), seq_along(trts), sep = "_") + res <- paste("R", seq_along(trts), seq_along(trts), sep = "_") + denom <- paste(num, res, sep = "+") + ans <- paste0("se_covar_function Heritability:", trts, " ", num, "/(", denom, ")") + expect_identical(pf90_default_heritability(rgl, traits = trts), ans) + + ## list with a genetic effect and some other effects + rgl <- list(a = list(pos = 1), genetic = list(pos = 3)) + denom <- paste(paste("G", 1, 1, seq_along(trts), seq_along(trts), sep = "_"), + num, res, sep = "+") + ans <- paste0("se_covar_function Heritability:", trts, " ", num, "/(", denom, ")") + expect_identical(pf90_default_heritability(rgl, traits = trts), ans) +}) + diff --git a/tests/testthat/test-modelframe.R b/tests/testthat/test-modelframe.R index c7e90af..0495b62 100644 --- a/tests/testthat/test-modelframe.R +++ b/tests/testthat/test-modelframe.R @@ -1,13 +1,10 @@ ### Test the building of model frames ### -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) # In particular, check that the intercept attribute is always set to zero, # and it is manually introduced in the model frame when necessary -context("Model Frame") +context("Model Frame infrastructure") data <- transform(as.data.frame(m1), mum2 = mum, @@ -38,7 +35,7 @@ mlst <- unlist(lapply(fxdlst, # Function that runs checks to each model spec run_expectations <- function(m) { - fc <- call('remlf90', + fc <- call('remlf90', # call only, no eval fixed = m$fxd, random = m$rnd, data = quote(as.data.frame(m1))) @@ -125,17 +122,19 @@ gen_spec <- check_genetic(model = 'competition', pedigree = data[, c('self', 'dad', 'mum')], # pedigree id = data$self, # vector coordinates = data[, c('irow', 'icol')], # matrix - pec = TRUE) + pec = TRUE, + response = data$phe_X) sp_spec <- check_spatial(model = 'splines', - coordinates = data[, c('irow', 'icol')]) + coordinates = data[, c('irow', 'icol')], + response = data$phe_X) x1 <- list(inc = matrix(1,1600,3), cov = diag(3), var.ini = 6) x2 <- list(inc = matrix(1:8,1600,2), pre = diag(2), var.ini = 4) x <- list (a = x1, b = x2) -grc_spec <- check_generic(x) +grc_spec <- check_generic(x, response = data$phe_X) -fc <- call('remlf90', +fc <- call('remlf90', # call only, no eval fixed = m$fxd, random = m$rnd, genetic = gen_spec, diff --git a/tests/testthat/test-modelmatrix.R b/tests/testthat/test-modelmatrix.R index 7ef0fd7..6a9edef 100644 --- a/tests/testthat/test-modelmatrix.R +++ b/tests/testthat/test-modelmatrix.R @@ -1,8 +1,5 @@ ### Test the computation of model matrices ### -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) context("Model Matrix") @@ -59,7 +56,7 @@ test_that('model.matrix(·, fullgrid=TRUE) works as expected with generic object ## Extracting incidence matrices from groups of effects ## with identical covariance structure -eg <- effect_group(list(spl, gen), cov.ini = diag(1,2,2)) +eg <- effect_group(list(spl, gen), cov.ini = diag(1,2,2), ntraits = 1) eg.mm <- model.matrix(eg) test_that('model.matrix() recovers the list of incidence matrices', { diff --git a/tests/testthat/test-pedigree.R b/tests/testthat/test-pedigree.R index f373f9d..b800353 100644 --- a/tests/testthat/test-pedigree.R +++ b/tests/testthat/test-pedigree.R @@ -1,42 +1,19 @@ #### pedigree building and checking #### -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) -context("Pedigree") +context("Pedigree infrastructure") # Retrieve pedigree from remlf90 objects -res.lm <- try(suppressMessages(remlf90(y~1, dat = data.frame(y=rnorm(100))))) -test_that('get_pedigree() returns NULL when there is no genetic effect', { - expect_true(is.null(get_pedigree(res.lm))) -}) -# Toy dataset with silly pedigree -test.dat <- data.frame(matrix(sample(100, 15), 5, 3, - dimnames = list(NULL, c('self', 'sire', 'dam'))), - y = rnorm(5)) -ped.fix <- build_pedigree(1:3, data = test.dat) -test.res <- try( - suppressMessages( - remlf90(y~1, - genetic = list(model = 'add_animal', - pedigree = test.dat[, 1:3], - id = 'self'), - data = test.dat) - ) -) - -test_that('remlf90() builds and recodes the pedigree', { - expect_false(inherits(test.res, 'try-error')) +test_that('get_pedigree() returns NULL when there is no genetic effect', { + res <- load_res("fixonly") + expect_true(is.null(get_pedigree(res))) }) -test_that('get_pedigree() returns the recoded pedigree', { - expect_identical(ped.fix, get_pedigree(test.res)) -}) # Use the pedigree in data(m4) and shuffle the codes data(m4) ped <- as.data.frame(m4)[, c('self', 'dad', 'mum')] + test_that('The pedigree from m4 is not complete, but otherwise correct', { expect_that(!check_pedigree(ped)['full_ped'], is_true()); expect_that(all(check_pedigree(ped)[-1]), is_true()) @@ -58,54 +35,8 @@ test_that('The shuffled pedigree fails all checks', { }) # Reorder and recode -ped_fix <- build_pedigree(1:3, data = ped_shuffled) +ped_fix <- suppressWarnings(build_pedigree(1:3, data = ped_shuffled)) test_that('build_pedigree() fixes everything', { expect_that(all(check_pedigree(ped_fix)), is_true()) }) - -# Check that remlf90 handles correctly recoded pedigrees -# by comparing the genetics evaluations of a dataset with or without -# a shuffled pedigree - -data(m1) -dat <- as.data.frame(m1) -ped <- get_pedigree(m1) - -res_ok <- try( - suppressMessages( - remlf90(fixed = phe_X ~ sex, - genetic = list(model = 'add_animal', - pedigree = ped, - id = 'self'), - data = dat) - ) -) - -# Shuffle the pedigree -mcode <- max(as.data.frame(ped), na.rm = TRUE) -map <- rep(NA, mcode) -set.seed(1234) -map <- sample(10*mcode, size = mcode) -m1_shuffled <- m1 -m1_shuffled$Data[, 1:3] <- sapply(as.data.frame(ped), function(x) map[x]) - -ped_fix <- build_pedigree(1:3, data = as.data.frame(get_pedigree(m1_shuffled))) - -res_shuffled <- try( - suppressMessages( - remlf90(fixed = phe_X ~ sex, - genetic = list(model = 'add_animal', - pedigree = ped_fix, - id = 'self'), - data = as.data.frame(m1_shuffled)) - ) -) - -# Except the call, and the reml output everything must be the same -# Update: also need to omit the shuffled random effects estimations -# which should be the same, but reordered -test_that('remlf90 handles recoded pedigrees correctly', { - omit.idx <- match(c('call', 'effects', 'reml', 'ranef'), names(res_ok)) - expect_that(res_ok[-omit.idx], equals(res_shuffled[-omit.idx])) -}) \ No newline at end of file diff --git a/tests/testthat/test-reml-interface.R b/tests/testthat/test-reml-interface.R deleted file mode 100644 index 4f02e2f..0000000 --- a/tests/testthat/test-reml-interface.R +++ /dev/null @@ -1,91 +0,0 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) - -data(globulus) -ped <- build_pedigree(1:3, data = globulus) -# Test function -fit.model <- function(vi, vigen, random, dat = globulus, ...) { - try( - suppressMessages( - remlf90(fixed = phe_X ~ gen, - random = random, - var.ini = vi, - genetic = list(model = 'add_animal', - var.ini = vigen, - pedigree = ped, - id = 'self'), - data = dat) - ) - ) -} - -# Test data -testdat <- list(list(vi = NULL, # Missing specification: FAIL - vigen = 1, - random = ~ bl, - expectation = 0), - list(vi = list(bl = 1), # Missing specification of residual: FAIL - vigen = 1, - random = ~ bl, - expectation = 0), - list(vi = list(gg = 1, # Missing specification of bloc: FAIL - resid = 1), - vigen = 1, - random = ~ bl + gg, - expectation = 0), - list(vi = list(bl = 1, # Missing specification of gg: FAIL - resid = 1), - vigen = 1, - random = ~ bl + gg, - expectation = 0), - list(vi = list(bl = 1, # Missing genetic specification: FAIL - resid = 1), - vigen = NULL, - random = ~ bl, - expectation = 0), - list(vi = NULL, # OK: no specification at all - vigen = NULL, - random = ~ bl, - expectation = 1), - list(vi = list(bl = 1, # OK - resid = 1), - vigen = 1, - random = ~ bl, - expectation = 1), - list(vi = list(bl = 1, # OK - gg = 1, - resid = 1), - vigen = 1, - random = ~ bl + gg, - expectation = 1), - list(vi = list(resid = 1), # OK - vigen = 1, - random = NULL, - expectation = 1)) - - -#### Context: Variance components specifications #### -context("Variance components specifications") - -# reml results -# fit.model(vi=list(resid = 1), vigen=1, random = NULL) -# do.call('fit.model', testdat[[1]]) -# do.call('fit.model', testdat[[7]]) -reslst <- lapply(testdat, function(x) do.call(fit.model, x)) - - -# Compare expected and true results -run_expectations <- function(m, res) { - # Check that remlf90 behaves as expected - test_that("remlf90 requires either full or null variance specifications", { - ifelse( m$expectation, - expect_true(!inherits(res, "try-error")), - expect_true(inherits(res, "try-error")) ) - }) -} - -for(i in seq_along(testdat)) { -# cat(i) - run_expectations(testdat[[i]], reslst[[i]]) -} diff --git a/tests/testthat/test-renderpf90.R b/tests/testthat/test-renderpf90.R index 8843605..5e344c8 100644 --- a/tests/testthat/test-renderpf90.R +++ b/tests/testthat/test-renderpf90.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Test the rendering to pf90 format ### @@ -31,3 +28,22 @@ test_that('renderpf90.matrix() renders different matrix types', { }) + +test_that('renderpf90.breedr_modelframe() renders a single-trait breedr_modelframe correctly', { + + # TODO... + # testdat <- transform( + # expand.grid(x = 1:4, y = 1:4, KEEP.OUT.ATTRS = FALSE), + # z = rnorm(16), + # mu = 1) + # + # bc <- call('remlf90', fixed = phe_X~1, data = quote(as.data.frame(m1))) + # str(build.mf(bc)) + # + # + # breedrmf <- build.effects(mf = build.mf(bc), + # genetic = NULL, + # spatial = NULL, + # generic = NULL) + # renderpf90.breedr_modelframe(breedrmf, ntraits = 1) +}) diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R index b30c45c..4464ab1 100644 --- a/tests/testthat/test-simulation.R +++ b/tests/testthat/test-simulation.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) #### Context: Simulation infrastructure #### context("Simulation infrastructure") diff --git a/tests/testthat/test-spatial-varcomp.R b/tests/testthat/test-spatial-varcomp.R index 0c0313d..928a2d1 100644 --- a/tests/testthat/test-spatial-varcomp.R +++ b/tests/testthat/test-spatial-varcomp.R @@ -1,48 +1,17 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Scaling of spatial variance components ### context("Scaling of the spatial variance component") -res.blk <- try( - suppressMessages( - remlf90(fixed = phe_X ~ 1, - spatial = list(model = 'blocks', - coord = globulus[, c('x','y')], - id = 'bl'), - data = globulus) - ) -) - -res.spl <- try( - suppressMessages( - remlf90(fixed = phe_X ~ 1, - spatial = list(model = 'splines', - coord = globulus[, c('x','y')], - n.knots = c(2, 2)), - data = globulus, - method = 'em') - ) -) - -res.ar <- try( - suppressMessages( - remlf90(fixed = phe_X ~ gg, - genetic = list(model = 'add_animal', - pedigree = globulus[,1:3], - id = 'self'), - spatial = list(model = 'AR', - coord = globulus[, c('x','y')], - rho = c(.85, .8)), - data = globulus) - ) -) - - test_that("The spatial variance component is the characteristic marginal variance of the spatial effect's contribution to the phenotypic variance", { - expect_equal(breedR:::gmean(Matrix::diag(vcov(res.blk))), res.blk$var['spatial', 1]) - expect_equal(breedR:::gmean(Matrix::diag(vcov(res.spl))), res.spl$var['spatial', 1]) - expect_equal(breedR:::gmean(Matrix::diag(vcov(res.ar))), res.ar$var['spatial', 1]) + + res <- list( + blk = load_res("blk"), + ar = load_res("blk"), + spl = load_res("blk") + ) + + expect_equal(breedR:::gmean(Matrix::diag(vcov(res$blk))), res$blk$var['spatial', 1]) + expect_equal(breedR:::gmean(Matrix::diag(vcov(res$spl))), res$spl$var['spatial', 1]) + expect_equal(breedR:::gmean(Matrix::diag(vcov(res$ar))), res$ar$var['spatial', 1]) }) diff --git a/tests/testthat/test-spatial.R b/tests/testthat/test-spatial.R index 43e6bcf..694815b 100644 --- a/tests/testthat/test-spatial.R +++ b/tests/testthat/test-spatial.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Internal spatial functions ### context("Internal spatial functions") diff --git a/tests/testthat/test-splines.R b/tests/testthat/test-splines.R index 6d63cc3..2b71f2c 100644 --- a/tests/testthat/test-splines.R +++ b/tests/testthat/test-splines.R @@ -1,9 +1,6 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) -context("Number of knots") -########################## +context("Splines infrastructure") +######################## test_that("determine.n.knots works for atomic vectors", { test.length <- 100 @@ -17,10 +14,6 @@ test_that("determine.n.knots fails with few data points", { }) - -context("Splines infrastructure") -######################## - test_that("breedr_splines() constructor gives a list with six elements of correct sizes", { x.loc <- 1:100 y.loc <- seq(1000, by = 5, length = 51) @@ -43,135 +36,3 @@ test_that("breedr_splines() constructor gives a list with six elements of correc expect_that(cov.mat, is_a('Matrix')) }) - - -context("Extraction of results from spatial splines model") -######################## - -data(m1) -dat <- as.data.frame(m1) - -fixed.fml <- phe_X ~ sex - -n.obs <- nrow(dat) -n.fixed <- length(attr(terms(fixed.fml), 'term.labels')) -nlevels.fixed <- nlevels(dat$sex) -n.knots <- c(4, 3) -n.splines <- prod(n.knots + 2) - -# Use a different number of knots for rows and columns -res <- try( - suppressMessages( - remlf90(fixed = fixed.fml, - spatial = list(model = 'splines', - coord = coordinates(m1), - n.knots = n.knots), - data = dat, - method = 'em') - ) -) - - -test_that("The splines model runs with EM-REML without errors", { - expect_that(!inherits(res, "try-error"), is_true()) -}) - -test_that("coef() gets a named vector of coefficients", { - expect_is(coef(res), 'numeric') - expect_equal(length(coef(res)), nlevels.fixed + n.splines) - expect_named(coef(res)) -}) - -test_that("ExtractAIC() gets one number", { - expect_is(extractAIC(res), 'numeric') - expect_equal(length(extractAIC(res)), 1) -}) - -test_that("fitted() gets a vector of length N", { - expect_is(fitted(res), 'numeric') - expect_equal(length(fitted(res)), n.obs) -}) - -test_that("fixef() gets a named list of data.frames with estimated values and s.e.", { - x <- fixef(res) - expect_is(x, 'list') - expect_named(x) - expect_equal(length(x), n.fixed) - for (f in x) { - expect_is(f, 'data.frame') - expect_named(f, c('value', 's.e.')) - } -}) - -test_that("get_pedigree() returns NULL", { - expect_null(get_pedigree(res)) -}) - -test_that("logLik() gets an object of class logLik", { - expect_is(logLik(res), 'logLik') -}) - -test_that("model.frame() gets an Nx2 data.frame with a 'terms' attribute", { - x <- model.frame(res) - expect_is(x, 'data.frame') - expect_is(terms(x), 'terms') - expect_equal(dim(x), c(n.obs, n.fixed + 1)) -}) - -test_that("model.matrix() gets a named list of fixed and random incidence matrices", { - x <- model.matrix(res) - expect_is(x, 'list') - expect_named(x, names(res$effects)) - expect_equal(dim(x$sex), c(n.obs, nlevels.fixed)) - expect_is(x$spatial, 'sparseMatrix') - expect_equal(dim(x$spatial), c(n.obs, n.splines)) -}) - -test_that("nobs() gets the number of observations", { - expect_equal(nobs(res), n.obs) -}) - -test_that("plot(, type = *) returns ggplot objects", { - expect_is(plot(res, type = 'phenotype'), 'ggplot') - expect_is(plot(res, type = 'fitted'), 'ggplot') - expect_is(plot(res, type = 'spatial'), 'ggplot') - expect_is(plot(res, type = 'fullspatial'), 'ggplot') - expect_is(plot(res, type = 'residuals'), 'ggplot') -}) - -test_that("print() shows some basic information", { - ## Not very informative currently... - expect_output(print(res), 'Data') -}) - -test_that("ranef() gets a ranef.breedR object with random effect BLUPs and their s.e.", { - x <- ranef(res) - expect_is(x, 'ranef.breedR') - expect_equal(length(x), 1) - expect_named(x, c('spatial')) - - expect_is(x$spatial, 'numeric') - expect_equal(length(x$spatial), n.splines) - expect_false(is.null(xse <- attr(x$spatial, 'se'))) - - expect_is(xse, 'numeric') - expect_equal(length(xse), n.splines) -}) - -test_that("residuals() gets a vector of length N", { - rsd <- residuals(res) - expect_is(rsd, 'numeric') - expect_equal(length(rsd), n.obs) -}) - -test_that("summary() shows summary information", { - expect_output(print(summary(res)), 'Variance components') - expect_output(print(summary(res)), 'knots:') -}) - -test_that("vcov() gets the covariance matrix of the spatial component of the observations", { - x <- vcov(res) - expect_is(x, 'Matrix') - expect_equal(dim(x), rep(n.obs, 2)) -}) - diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 0000000..ae1f32d --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,5 @@ +### Test the auxiliar functions in utils.R ### + + +context("Auxiliar functions") + diff --git a/tests/testthat/test-variogram.R b/tests/testthat/test-variogram.R index d7832b5..89da89d 100644 --- a/tests/testthat/test-variogram.R +++ b/tests/testthat/test-variogram.R @@ -1,6 +1,3 @@ -old.op <- options(warn = -1, # suppressWarnings - show.error.messages = FALSE) # silent try -on.exit(options(old.op)) ### Empirical Variograms ### context("Empirical Variograms") @@ -34,6 +31,7 @@ truecov.iso <- function(x, par) { # lines(x, yc) # Simulated data +set.seed(1234) truepar <- list(n = 1, s = 5, r = 20) coord <- expand.grid(x = 0:49, y = 0:49) D <- dist(coord) @@ -55,6 +53,8 @@ res <- transform(empvar$isotropic, # lines(distance, truev, col ='red')}) test_that("The isotropic empirical variograms are well computed", { + # qplot(as.numeric(res$variogram), res$truev) + + # geom_abline(intercept = 0, slope = 1) expect_equal(as.numeric(res$variogram), res$truev, tolerance = .2) }) diff --git a/vignettes/Missing-values.Rmd b/vignettes/Missing-values.Rmd index 05a70d7..c95c937 100644 --- a/vignettes/Missing-values.Rmd +++ b/vignettes/Missing-values.Rmd @@ -40,7 +40,7 @@ res <- remlf90(y ~ x, data = dat) ## The predicted phenotype for y[1] is the estimated effect ## of the corresponding level of x -fitted(res)[1] == fixef(res)$x['a', 'value'] +fitted(res)[1] == fixef(res)$x['a'] ``` @@ -48,7 +48,7 @@ fitted(res)[1] == fixef(res)$x['a', 'value'] ## Missing value for a fixed effect This is not allowed, as it would yield an underdetermined system of equations. -`breedR` issues a warning if missing values are detected. +`breedR` issues an error if missing values are detected. ```{r missing-fixed, message = FALSE, error = TRUE} N <- 1e3 @@ -99,7 +99,7 @@ available effects. In this case, the global mean. ```{r missing-diagonal-residual} -fitted(res)[1] == fixef(res)$Intercept[1, 'value'] +fitted(res)[1] == fixef(res)$Intercept[1] ``` @@ -115,7 +115,7 @@ res <- remlf90(y ~ 1, data = dat) c(sum(model.matrix(res)$spatial[1,]) == 0, -fitted(res)[1] == fixef(res)$Intercept[1, 'value']) +fitted(res)[1] == fixef(res)$Intercept[1]) ``` @@ -139,7 +139,7 @@ sample_first_residual <- function(N = 1e3, N.blk = 20) { ```{r variance-missing-residuals} -resid_sample <- replicate(1e3, sample_first_residual()) +resid_sample <- replicate(1e2, sample_first_residual()) var(resid_sample) ``` diff --git a/vignettes/Overview.Rmd b/vignettes/Overview.Rmd index 289f26d..2a7549b 100644 --- a/vignettes/Overview.Rmd +++ b/vignettes/Overview.Rmd @@ -1233,6 +1233,73 @@ round(sqrt(mean((fitted(res.comp.cv)[rm.idx] - true.exp.cv)^2)), 2) +# Multiple traits + +**breedR** provides a basic interface for multi-trait models which only +requires specifying the different traits in the main formula using `cbind()`. + +```{r multitrait-fit} +## Filter site and select relevant variables +dat <- + droplevels( + douglas[douglas$site == "s3", + names(douglas)[!grepl("H0[^4]|AN|BR|site", names(douglas))]] + ) + +res <- + remlf90( + fixed = cbind(H04, C13) ~ orig, + # random = ~ block, + genetic = list( + model = 'add_animal', + pedigree = dat[, 1:3], + id = 'self'), + data = dat + ) +``` + +A full covariance matrix across traits is estimated for each random effect, +and all results, including heritabilities, are expressed effect-wise: + +```{r multitrait-summary, echo = FALSE} +summary(res) +``` + +Although the results are summarized in tabular form, the covariance matrices +can be recovered directly: + +```{r multitrait-genetic-covariances} +res$var[["genetic", "Estimated variances"]] + +## Use cov2cor() to compute correlations +cov2cor(res$var[["genetic", "Estimated variances"]]) +``` + +Estimates of fixed effects and BLUPs of random effects can be recovered with +`fixef()` and `ranef()` as usual. The only difference is that they will return a +list of matrices rather than vectors, with one column per trait. + +The standard errors are given as attributes, and are displayed in tabular form +whenever the object is printed. + +```{r multitrait-fixef-ranef} +fixef(res) ## printed in tabular form, but... +unclass(fixef(res)) ## actually a matrix of estimates with attribute "se" + +str(ranef(res)) +head(ranef(res)$genetic) +``` + +Recovering the breeding values for each observation in the original dataset +follows the same procedure as for one trait: multiply the incidence matrix by +the BLUP matrix. The result, however, will be a matrix with one column per +trait. + +```{r multitrait-blups} +head(model.matrix(res)$genetic %*% ranef(res)$genetic) +``` + + # Some more features