├── .gitignore ├── .Rbuildignore ├── data ├── F2009.rda ├── FG90.rda ├── Q1988.rda ├── Mrode2.rda ├── Mrode3.rda ├── Mrode9.rda ├── Wray90.rda ├── warcolak.rda └── ggTutorial.rda ├── R ├── TDtT.R ├── nadiv-deprecated.R ├── nadiv.R ├── makeA.R ├── sm2list.R ├── makeM.R ├── makeAA.R ├── varTrans.R ├── aic.R ├── constrainFun.R ├── drfx.R ├── aiCI.R ├── genAssign.R ├── founderLine.R ├── makeDufam.R ├── findDFC.R ├── aiFun.R ├── LRTest.R ├── prunePed.R ├── geneDrop.R ├── makeSd.R ├── makeSdsim.R ├── grfx.R ├── numPed.R └── makeDomEpi.R ├── src ├── init.c ├── nadivcc.h ├── cs_norm.c ├── cs_cumsum.c ├── nadiv.h ├── cs_scatter.c ├── cs_malloc.c ├── cs_transpose.c ├── genedrop.cc ├── reT.cc ├── cs_multiply.c ├── dsim.cc ├── Trow.cc ├── ga.cc ├── sdsim.cc ├── cs_util.c ├── sinv.cc ├── dfc.cc └── diif.cc ├── man ├── nadiv-deprecated.Rd ├── Mrode2.Rd ├── Mrode9.Rd ├── Wray90.Rd ├── makeA.Rd ├── makeM.Rd ├── nadiv-package.Rd ├── FG90.Rd ├── sm2list.Rd ├── genAssign.Rd ├── makeAA.Rd ├── Mrode3.Rd ├── constrainFun.Rd ├── simPedHS.Rd ├── varTrans.Rd ├── Q1988.Rd ├── aic.Rd ├── drfx.Rd ├── F2009.Rd ├── aiCI.Rd ├── pin-deprecated.Rd ├── numPed.Rd ├── findDFC.Rd ├── geneDrop.Rd ├── pcc.Rd ├── founderLine.Rd ├── prunePed.Rd ├── simPedMCN.Rd ├── LRTest.Rd ├── prepPed.Rd ├── simPedDFC.Rd ├── makeS.Rd ├── makeDomEpi.Rd ├── aiFun.Rd ├── ggTutorial.Rd ├── makeMinv.Rd ├── grfx.Rd ├── makeTinv.Rd ├── makeAstarMult.Rd └── makeDsim.Rd ├── inst ├── CITATION └── WORDLIST ├── DESCRIPTION ├── NAMESPACE ├── README.md └── cran-comments.md /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.o 3 | *.so 4 | *.rds 5 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^cran-comments\.md$ 2 | ^CRAN-RELEASE$ 3 | ^CRAN-SUBMISSION$ 4 | -------------------------------------------------------------------------------- /data/F2009.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/F2009.rda -------------------------------------------------------------------------------- /data/FG90.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/FG90.rda -------------------------------------------------------------------------------- /data/Q1988.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/Q1988.rda -------------------------------------------------------------------------------- /data/Mrode2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/Mrode2.rda -------------------------------------------------------------------------------- /data/Mrode3.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/Mrode3.rda -------------------------------------------------------------------------------- /data/Mrode9.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/Mrode9.rda -------------------------------------------------------------------------------- /data/Wray90.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/Wray90.rda -------------------------------------------------------------------------------- /data/warcolak.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/warcolak.rda -------------------------------------------------------------------------------- /data/ggTutorial.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matthewwolak/nadiv/HEAD/data/ggTutorial.rda -------------------------------------------------------------------------------- /R/TDtT.R: -------------------------------------------------------------------------------- 1 | TDtT <- function(A, ...){ 2 | ch <- chol(A) 3 | dd <- diag(ch) 4 | return(list(T = t(drop0(zapsmall(ch / dd, ...))), D = Diagonal(nrow(A), dd^2))) 5 | } 6 | 7 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | #include // for NULL 2 | #include 3 | 4 | void R_init_nadiv(DllInfo *dll) 5 | { 6 | R_registerRoutines(dll, NULL, NULL, NULL, NULL); 7 | R_useDynamicSymbols(dll, TRUE); 8 | } 9 | 10 | -------------------------------------------------------------------------------- /R/nadiv-deprecated.R: -------------------------------------------------------------------------------- 1 | #' Deprecated functions in package \pkg{nadiv}. 2 | #' 3 | #' The functions listed below are deprecated and will be defunct in 4 | #' the near future. When possible, alternative functions with similar 5 | #' functionality are also mentioned. Help pages for deprecated functions are 6 | #' available at \code{help("-deprecated")}. 7 | #' @name nadiv-deprecated 8 | #' @keywords internal 9 | NULL 10 | 11 | 12 | -------------------------------------------------------------------------------- /src/nadivcc.h: -------------------------------------------------------------------------------- 1 | #define _NADIVCC_H 2 | 3 | /* #include "cs.h" included by nadiv.h */ 4 | #include "nadiv.h" 5 | //#include already included via R.h 6 | #include 7 | //#include already included via R.h 8 | #include 9 | /* already included 10 | #include "R.h" 11 | #include "Rmath.h" 12 | */ 13 | #include 14 | #include 15 | using namespace std; 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /src/cs_norm.c: -------------------------------------------------------------------------------- 1 | #include "cs.h" 2 | /* 1-norm of a sparse matrix = max (sum (abs (A))), largest column sum */ 3 | double cs_norm (const cs *A) 4 | { 5 | int p, j, n, *Ap ; 6 | double *Ax, norm = 0, s ; 7 | if (!CS_CSC (A) || !A->x) return (-1) ; /* check inputs */ 8 | n = A->n ; Ap = A->p ; Ax = A->x ; 9 | for (j = 0 ; j < n ; j++) 10 | { 11 | for (s = 0, p = Ap [j] ; p < Ap [j+1] ; p++) s += fabs (Ax [p]) ; 12 | norm = CS_MAX (norm, s) ; 13 | } 14 | return (norm) ; 15 | } 16 | -------------------------------------------------------------------------------- /src/cs_cumsum.c: -------------------------------------------------------------------------------- 1 | #include "cs.h" 2 | /* p [0..n] = cumulative sum of c [0..n-1], and then copy p [0..n-1] into c */ 3 | double cs_cumsum (int *p, int *c, int n) 4 | { 5 | int i, nz = 0 ; 6 | double nz2 = 0 ; 7 | if (!p || !c) return (-1) ; /* check inputs */ 8 | for (i = 0 ; i < n ; i++) 9 | { 10 | p [i] = nz ; 11 | nz += c [i] ; 12 | nz2 += c [i] ; /* also in double to avoid int overflow */ 13 | c [i] = p [i] ; /* also copy p[0..n-1] back into c[0..n-1]*/ 14 | } 15 | p [n] = nz ; 16 | return (nz2) ; /* return sum (c [0..n-1]) */ 17 | } 18 | -------------------------------------------------------------------------------- /src/nadiv.h: -------------------------------------------------------------------------------- 1 | #define _NADIV_H 2 | #include "cs.h" 3 | /* #include "R.h" included by cs.h */ 4 | #include "Rmath.h" 5 | 6 | // M&L 1992 algorithm (for `ainvml`) 7 | // as presented in Mrode 2005 8 | //// replaces elements of f and dii with calculated values in place 9 | void ml(int *dam, int *sire, 10 | double *f, double *dii, 11 | int n, int g, int fmiss); 12 | 13 | 14 | // Mutational effects inbreeding and dii 15 | //// based on Meuwissen and Luo 1992 algorithm to obtain f and dii values 16 | //// Extends Wray 1990; Casellas and Medrano 2008 17 | void mml(int *dam, int *sire, 18 | double *h, double *dii, 19 | int n); 20 | 21 | 22 | -------------------------------------------------------------------------------- /man/nadiv-deprecated.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-deprecated.R, R/remlSupport.R 3 | \name{nadiv-deprecated} 4 | \alias{nadiv-deprecated} 5 | \alias{pin} 6 | \title{Deprecated functions in package \pkg{nadiv}.} 7 | \usage{ 8 | pin(object, transform) 9 | } 10 | \description{ 11 | The functions listed below are deprecated and will be defunct in 12 | the near future. When possible, alternative functions with similar 13 | functionality are also mentioned. Help pages for deprecated functions are 14 | available at \code{help("-deprecated")}. 15 | } 16 | \section{\code{pin}}{ 17 | 18 | For \code{pin} with asreml version 4 objects, use \code{asreml::vpredict} 19 | } 20 | 21 | \keyword{internal} 22 | -------------------------------------------------------------------------------- /man/Mrode2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{Mrode2} 5 | \alias{Mrode2} 6 | \title{Pedigree from Table 2.1 of Mrode (2005)} 7 | \format{ 8 | A \code{data.frame} with 6 observations on the following 3 variables: 9 | \describe{ 10 | \item{id }{a numeric vector} 11 | \item{dam }{a numeric vector} 12 | \item{sire }{a numeric vector} 13 | } 14 | } 15 | \source{ 16 | Mrode, R.A. 2005. Linear Models for the Prediction of Animal 17 | Breeding Values, 2nd ed. Cambridge, MA: CABI Publishing. 18 | } 19 | \usage{ 20 | Mrode2 21 | } 22 | \description{ 23 | Pedigree from Table 2.1 of Mrode (2005) 24 | } 25 | \examples{ 26 | str(Mrode2) 27 | } 28 | \keyword{datasets} 29 | -------------------------------------------------------------------------------- /man/Mrode9.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{Mrode9} 5 | \alias{Mrode9} 6 | \title{Pedigree, adapted from example 9.1 of Mrode (2005)} 7 | \format{ 8 | A \code{data.frame} with 12 observations on the following 3 variables: 9 | \describe{ 10 | \item{pig }{a numeric vector} 11 | \item{dam }{a numeric vector} 12 | \item{sire }{a numeric vector} 13 | } 14 | } 15 | \source{ 16 | Mrode, R.A. 2005. Linear Models for the Prediction of Animal 17 | Breeding Values, 2nd ed. Cambridge, MA: CABI Publishing. 18 | } 19 | \usage{ 20 | Mrode9 21 | } 22 | \description{ 23 | Pedigree, adapted from example 9.1 of Mrode (2005) 24 | } 25 | \examples{ 26 | data(Mrode9) 27 | str(Mrode9) 28 | } 29 | \keyword{datasets} 30 | -------------------------------------------------------------------------------- /src/cs_scatter.c: -------------------------------------------------------------------------------- 1 | #include "cs.h" 2 | /* x = x + beta * A(:,j), where x is a dense vector and A(:,j) is sparse */ 3 | int cs_scatter (const cs *A, int j, double beta, int *w, double *x, int mark, 4 | cs *C, int nz) 5 | { 6 | int i, p, *Ap, *Ai, *Ci ; 7 | double *Ax ; 8 | if (!CS_CSC (A) || !w || !CS_CSC (C)) return (-1) ; /* check inputs */ 9 | Ap = A->p ; Ai = A->i ; Ax = A->x ; Ci = C->i ; 10 | for (p = Ap [j] ; p < Ap [j+1] ; p++) 11 | { 12 | i = Ai [p] ; /* A(i,j) is nonzero */ 13 | if (w [i] < mark) 14 | { 15 | w [i] = mark ; /* i is new entry in column j */ 16 | Ci [nz++] = i ; /* add i to pattern of C(:,j) */ 17 | if (x) x [i] = beta * Ax [p] ; /* x(i) = beta*A(i,j) */ 18 | } 19 | else if (x) x [i] += beta * Ax [p] ; /* i exists in C(:,j) already */ 20 | } 21 | return (nz) ; 22 | } 23 | -------------------------------------------------------------------------------- /man/Wray90.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{Wray90} 5 | \alias{Wray90} 6 | \title{Pedigree, adapted from Wray (1990)} 7 | \format{ 8 | A data frame with 8 observations on the following 4 variables: 9 | \describe{ 10 | \item{\code{id} }{a numeric vector} 11 | \item{\code{dam} }{a numeric vector} 12 | \item{\code{sire} }{a numeric vector} 13 | \item{\code{time} }{a numeric vector} 14 | } 15 | } 16 | \source{ 17 | Wray, N.A. 1990. Accounting for mutation effects in the additive 18 | genetic variance-covariance matrix and its inverse. Biometrics. 46:177-186. 19 | } 20 | \usage{ 21 | Wray90 22 | } 23 | \description{ 24 | Pedigree, adapted from Wray (1990) 25 | } 26 | \examples{ 27 | data(Wray90) 28 | str(Wray90) 29 | } 30 | \keyword{datasets} 31 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry(bibtype = "Article", 2 | title = "{nadiv}: an {R} package to create relatedness matrices for estimating non-additive genetic variances in animal models", 3 | author = c(person(given = c("Matthew", "E."), 4 | family = "Wolak")), 5 | journal = "Methods in Ecology and Evolution", 6 | year = "2012", 7 | volume = "3", 8 | number = "5", 9 | pages = "792--796", 10 | url = "https://besjournals.onlinelibrary.wiley.com/doi/full/10.1111/j.2041-210X.2012.00213.x", 11 | 12 | header = "To cite nadiv in publications use:", 13 | textVersion = 14 | paste("Matthew E. Wolak (2012).", 15 | "nadiv: an R package to create relatedness matrices for estimating non-additive genetic variances in animal models.", 16 | "Methods in Ecology and Evolution, 3(5), 792-796.", 17 | "doi:10.1111/j.2041-210X.2012.00213.x.") 18 | ) 19 | 20 | -------------------------------------------------------------------------------- /man/makeA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeA.R 3 | \name{makeA} 4 | \alias{makeA} 5 | \title{Creates the additive genetic relationship matrix} 6 | \usage{ 7 | makeA(pedigree) 8 | } 9 | \arguments{ 10 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 11 | } 12 | \value{ 13 | Returns A, or the numerator relationship matrix, in sparse 14 | matrix form. 15 | } 16 | \description{ 17 | This returns the additive relationship matrix in sparse matrix format. 18 | } 19 | \details{ 20 | Missing parents (e.g., base population) should be denoted by either 'NA', 21 | '0', or '*'. 22 | 23 | Used as a support function to \code{\link{makeD}}. 24 | 25 | See function \code{\link{makeAinv}} for directly obtaining the inverse of 26 | the additive genetic relationship matrix. 27 | } 28 | \examples{ 29 | 30 | makeA(Mrode2) 31 | 32 | } 33 | \seealso{ 34 | \code{\link{makeD}}, \code{\link{makeS}} 35 | } 36 | \author{ 37 | \email{matthewwolak@gmail.com} 38 | } 39 | -------------------------------------------------------------------------------- /src/cs_malloc.c: -------------------------------------------------------------------------------- 1 | #include "cs.h" 2 | #ifdef MATLAB_MEX_FILE 3 | #define malloc mxMalloc 4 | #define free mxFree 5 | #define realloc mxRealloc 6 | #define calloc mxCalloc 7 | #endif 8 | 9 | /* wrapper for malloc */ 10 | void *cs_malloc (int n, size_t size) 11 | { 12 | return (malloc (CS_MAX (n,1) * size)) ; 13 | } 14 | 15 | /* wrapper for calloc */ 16 | void *cs_calloc (int n, size_t size) 17 | { 18 | return (calloc (CS_MAX (n,1), size)) ; 19 | } 20 | 21 | /* wrapper for free */ 22 | void *cs_free (void *p) 23 | { 24 | if (p) free (p) ; /* free p if it is not already NULL */ 25 | return (NULL) ; /* return NULL to simplify the use of cs_free */ 26 | } 27 | 28 | /* wrapper for realloc */ 29 | void *cs_realloc (void *p, int n, size_t size, int *ok) 30 | { 31 | void *pnew ; 32 | pnew = realloc (p, CS_MAX (n,1) * size) ; /* realloc the block */ 33 | *ok = (pnew != NULL) ; /* realloc fails if pnew is NULL */ 34 | return ((*ok) ? pnew : p) ; /* return original p if failure */ 35 | } 36 | -------------------------------------------------------------------------------- /man/makeM.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeM.R 3 | \name{makeM} 4 | \alias{makeM} 5 | \title{Creates the (additive) mutational effects relationship matrix} 6 | \usage{ 7 | makeM(pedigree) 8 | } 9 | \arguments{ 10 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 11 | } 12 | \value{ 13 | Returns M, or the mutational effects relationship matrix, in sparse 14 | matrix form. 15 | } 16 | \description{ 17 | This returns the (additive) mutational effects relationship matrix in sparse 18 | matrix format. 19 | } 20 | \details{ 21 | Missing parents (e.g., base population) should be denoted by either 'NA', 22 | '0', or '*'. 23 | 24 | See function \code{\link{makeMinv}} for directly obtaining the inverse of 25 | the (additive) mutational effects genetic relationship matrix. 26 | } 27 | \examples{ 28 | 29 | makeM(Mrode2) 30 | 31 | } 32 | \seealso{ 33 | \code{\link{makeA}}, \code{\link{makeS}} 34 | } 35 | \author{ 36 | \email{matthewwolak@gmail.com} 37 | } 38 | -------------------------------------------------------------------------------- /man/nadiv-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv.R 3 | \docType{package} 4 | \name{nadiv-package} 5 | \alias{nadiv-package} 6 | \alias{nadiv} 7 | \title{(Non)Additive Genetic Relatedness Matrices in Animal Model Analyses} 8 | \description{ 9 | Constructs (non)additive genetic relationship matrices, and their inverses, 10 | from a pedigree to be used in linear mixed effect models (A.K.A. the 'animal 11 | model'). Also includes other functions to facilitate the use of animal 12 | models. Some functions have been created to be used in conjunction with the 13 | R package for ASReml software, which can be obtained upon purchase from 14 | VSN international (). 15 | } 16 | \seealso{ 17 | Useful links: 18 | \itemize{ 19 | \item \url{https://github.com/matthewwolak/nadiv} 20 | \item Report bugs at \url{https://github.com/matthewwolak/nadiv/issues} 21 | } 22 | 23 | } 24 | \author{ 25 | Matthew Wolak \email{matthewwolak@gmail.com} 26 | } 27 | -------------------------------------------------------------------------------- /man/FG90.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{FG90} 5 | \alias{FG90} 6 | \title{Pedigree, adapted from Table 1 in Fernando & Grossman (1990)} 7 | \format{ 8 | A \code{data.frame} with 8 observations on the following 4 variables: 9 | \describe{ 10 | \item{id }{a factor with levels \code{1} \code{2} \code{3} \code{4} 11 | \code{5} \code{6} \code{7} \code{8}} 12 | \item{dam }{a factor with levels \code{2} \code{4} \code{6}} 13 | \item{sire }{a factor with levels \code{1} \code{3} \code{5}} 14 | \item{sex }{a factor with levels \code{0} \code{1}} 15 | } 16 | } 17 | \source{ 18 | Fernando, R.L. & M. Grossman. 1990. Genetic evaluation with 19 | autosomal and X-chromosomal inheritance. Theoretical and Applied Genetics 20 | 80:75-80. 21 | } 22 | \usage{ 23 | FG90 24 | } 25 | \description{ 26 | Pedigree, adapted from Table 1 in Fernando & Grossman (1990) 27 | } 28 | \examples{ 29 | data(FG90) 30 | str(FG90) 31 | } 32 | \keyword{datasets} 33 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: nadiv 2 | Type: Package 3 | Title: (Non)Additive Genetic Relatedness Matrices 4 | Version: 2.18.0 5 | Authors@R: person("Matthew", "Wolak", email = "matthewwolak@gmail.com", role = c("cre", "aut")) 6 | URL: https://github.com/matthewwolak/nadiv 7 | BugReports: https://github.com/matthewwolak/nadiv/issues 8 | Depends: R (>= 4.2.0), Matrix 9 | Suggests: parallel 10 | Enhances: MCMCglmm, asreml 11 | Imports: graphics, methods, stats 12 | License: GPL (>=2) 13 | LazyData: yes 14 | NeedsCompilation: yes 15 | Description: Constructs (non)additive genetic relationship matrices, and their 16 | inverses, from a pedigree to be used in linear mixed effect models (A.K.A. 17 | the 'animal model'). Also includes other functions to facilitate the use of 18 | animal models. Some functions have been created to be used in conjunction 19 | with the R package 'asreml' for the 'ASReml' software, which can be 20 | obtained upon purchase from 'VSN' international 21 | (). 22 | Encoding: UTF-8 23 | RoxygenNote: 7.3.1 24 | -------------------------------------------------------------------------------- /src/cs_transpose.c: -------------------------------------------------------------------------------- 1 | #include "cs.h" 2 | /* C = A' */ 3 | cs *cs_transpose (const cs *A, int values) 4 | { 5 | int p, q, j, *Cp, *Ci, n, m, *Ap, *Ai, *w ; 6 | double *Cx, *Ax ; 7 | cs *C ; 8 | if (!CS_CSC (A)) return (NULL) ; /* check inputs */ 9 | m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ; 10 | C = cs_spalloc (n, m, Ap [n], values && Ax, 0) ; /* allocate result */ 11 | w = cs_calloc (m, sizeof (int)) ; /* get workspace */ 12 | if (!C || !w) return (cs_done (C, w, NULL, 0)) ; /* out of memory */ 13 | // if (!C || !w) error("out of memory"); 14 | Cp = C->p ; Ci = C->i ; Cx = C->x ; 15 | for (p = 0 ; p < Ap [n] ; p++) w [Ai [p]]++ ; /* row counts */ 16 | cs_cumsum (Cp, w, m) ; /* row pointers */ 17 | for (j = 0 ; j < n ; j++) 18 | { 19 | for (p = Ap [j] ; p < Ap [j+1] ; p++) 20 | { 21 | Ci [q = w [Ai [p]]++] = j ; /* place A(i,j) as entry C(j,i) */ 22 | if (Cx) Cx [q] = Ax [p] ; 23 | } 24 | } 25 | return (cs_done (C, w, NULL, 1)) ; /* success; free w and return C */ 26 | } 27 | -------------------------------------------------------------------------------- /man/sm2list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sm2list.R 3 | \name{sm2list} 4 | \alias{sm2list} 5 | \title{Converts a sparse matrix into a three column format.} 6 | \usage{ 7 | sm2list(A, rownames = NULL, colnames = c("row", "column", "A")) 8 | } 9 | \arguments{ 10 | \item{A}{a sparse matrix} 11 | 12 | \item{rownames}{a list of rownames from the 'A' matrix.} 13 | 14 | \item{colnames}{the columns will be labeled however they are entered in 15 | this character vector} 16 | } 17 | \value{ 18 | returns the list form of the sparse matrix as a \code{data.frame} 19 | } 20 | \description{ 21 | From a sparse matrix object, the three column, row ordered lower triangle of 22 | non-zero elements is created. Mostly used within other functions (i.e., 23 | \code{makeD}) 24 | } 25 | \details{ 26 | The sparse matrix and three column format must fit CERTAIN assumptions about 27 | row/column sorting and lower/upper triangle matrix. 28 | 29 | Adapted from a function in the \code{MCMCglmm} package 30 | } 31 | \seealso{ 32 | \code{\link[MCMCglmm]{MCMCglmm}} 33 | } 34 | -------------------------------------------------------------------------------- /R/nadiv.R: -------------------------------------------------------------------------------- 1 | #' (Non)Additive Genetic Relatedness Matrices in Animal Model Analyses 2 | #' 3 | #' Constructs (non)additive genetic relationship matrices, and their inverses, 4 | #' from a pedigree to be used in linear mixed effect models (A.K.A. the 'animal 5 | #' model'). Also includes other functions to facilitate the use of animal 6 | #' models. Some functions have been created to be used in conjunction with the 7 | #' R package for ASReml software, which can be obtained upon purchase from 8 | #' VSN international (). 9 | #' 10 | #' @aliases nadiv-package nadiv 11 | #' @useDynLib nadiv, .registration = TRUE 12 | #' @importFrom methods as is new 13 | #' @importFrom graphics abline plot 14 | #' @importFrom stats as.formula deriv na.omit optimize 15 | #' @importFrom stats pchisq qchisq qnorm rnorm sd 16 | #' @import Matrix 17 | #' @author Matthew Wolak \email{matthewwolak@@gmail.com} 18 | "_PACKAGE" 19 | 20 | 21 | 22 | 23 | 24 | # nadiv Cleanup: Unload DLL when library unloaded 25 | .onUnload <- function (libpath) { 26 | library.dynam.unload("nadiv", libpath) 27 | } 28 | 29 | -------------------------------------------------------------------------------- /src/genedrop.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void genedrop(int *da, // Ndalleles 6 | int *sa, // Nsalleles 7 | int *eN, // N 8 | int *en, // n; pedigree size 9 | int *dam, 10 | int *sire 11 | ){ 12 | 13 | int i, j, k, l, mi, si; 14 | 15 | GetRNGstate(); 16 | for(i = 0; i < en[0]; i++){ 17 | mi = dam[i]; 18 | si = sire[i]; 19 | if(mi != -999){ 20 | k = i*eN[0]; 21 | l = mi*eN[0]; 22 | for(j = 0; j < eN[0]; j++){ 23 | if(runif(0.0, 2.0) > 1.0){ 24 | da[k] += da[l]; 25 | } 26 | else { 27 | da[k] += sa[l]; 28 | } 29 | k++; 30 | l++; 31 | } 32 | } 33 | 34 | if(si != -999){ 35 | k = i*eN[0]; 36 | l = si*eN[0]; 37 | for(j = 0; j < eN[0]; j++){ 38 | if(runif(0.0, 2.0) > 1.0){ 39 | sa[k] += da[l]; 40 | } 41 | else { 42 | sa[k] += sa[l]; 43 | } 44 | k++; 45 | l++; 46 | } 47 | } 48 | } 49 | PutRNGstate(); 50 | 51 | } 52 | } 53 | 54 | -------------------------------------------------------------------------------- /man/genAssign.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/genAssign.R 3 | \name{genAssign} 4 | \alias{genAssign} 5 | \alias{genAssign.default} 6 | \alias{genAssign.numPed} 7 | \title{Generation assignment} 8 | \usage{ 9 | genAssign(pedigree, ...) 10 | 11 | \method{genAssign}{default}(pedigree, ...) 12 | 13 | \method{genAssign}{numPed}(pedigree, ...) 14 | } 15 | \arguments{ 16 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 17 | 18 | \item{\dots}{Arguments to be passed to methods} 19 | } 20 | \value{ 21 | A vector of values is returned. This vector is in the same order as 22 | the ID column of the pedigree. 23 | } 24 | \description{ 25 | Given a pedigree, the function assigns the generation number to which each 26 | individual belongs. 27 | } 28 | \details{ 29 | 0 is the base population. 30 | 31 | Migrants, or any individuals where both parents are unknown, are assigned to 32 | generation zero. If parents of an individual are from two different 33 | generations (e.g., dam = 0 and sire = 1), the individual is assigned to the 34 | generation following the greater of the two parents (e.g., 2 in this 35 | example). 36 | } 37 | \author{ 38 | \email{matthewwolak@gmail.com} 39 | } 40 | -------------------------------------------------------------------------------- /R/makeA.R: -------------------------------------------------------------------------------- 1 | #' Creates the additive genetic relationship matrix 2 | #' 3 | #' This returns the additive relationship matrix in sparse matrix format. 4 | #' 5 | #' Missing parents (e.g., base population) should be denoted by either 'NA', 6 | #' '0', or '*'. 7 | #' 8 | #' Used as a support function to \code{\link{makeD}}. 9 | #' 10 | #' See function \code{\link{makeAinv}} for directly obtaining the inverse of 11 | #' the additive genetic relationship matrix. 12 | #' 13 | #' @param pedigree A pedigree where the columns are ordered ID, Dam, Sire 14 | #' 15 | #' @return Returns A, or the numerator relationship matrix, in sparse 16 | #' matrix form. 17 | #' @author \email{matthewwolak@@gmail.com} 18 | #' @seealso \code{\link{makeD}}, \code{\link{makeS}} 19 | #' @examples 20 | #' 21 | #' makeA(Mrode2) 22 | #' 23 | #' @export 24 | makeA <- function(pedigree) 25 | { 26 | nPed <- numPed(pedigree) 27 | # sqrtDinv <- makeDiiF(nPed)$D 28 | # sqrtDinv@x <- sqrt(1 / sqrtDinv@x) 29 | A <- as(tcrossprod(solve(Diagonal(x = sqrt(1 / makeAinv(pedigree)$dii), 30 | n = nrow(nPed)) %*% makeTinv(nPed))), 31 | "symmetricMatrix") 32 | A@Dimnames <- list(as.character(pedigree[, 1]), 33 | as.character(pedigree[, 1])) 34 | A 35 | } 36 | 37 | -------------------------------------------------------------------------------- /man/makeAA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeAA.R 3 | \name{makeAA} 4 | \alias{makeAA} 5 | \title{Creates the additive by additive epistatic genetic relationship matrix} 6 | \usage{ 7 | makeAA(pedigree) 8 | } 9 | \arguments{ 10 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 11 | } 12 | \value{ 13 | a \code{list}: 14 | \describe{ 15 | \item{AA }{the AA matrix in sparse matrix form} 16 | \item{logDet }{the log determinant of the AA matrix} 17 | \item{AAinv }{the inverse of the AA matrix in sparse matrix form} 18 | \item{listAAinv }{the three column form of the non-zero elements for the 19 | inverse of the AA matrix} 20 | } 21 | } 22 | \description{ 23 | Given a pedigree, the matrix of additive by additive genetic relatedness 24 | (AA) among all individuals in the pedigree is returned. 25 | } 26 | \details{ 27 | Missing parents (e.g., base population) should be denoted by either 'NA', 28 | '0', or '*'. 29 | 30 | The function first estimates the A matrix using \code{\link{makeA}}, then it 31 | calculates the Hadamard (element-wise) product of the A matrix with itself 32 | (A # A). 33 | } 34 | \examples{ 35 | 36 | makeAA(Mrode2) 37 | 38 | } 39 | \seealso{ 40 | \code{\link{makeA}} 41 | } 42 | \author{ 43 | \email{matthewwolak@gmail.com} 44 | } 45 | -------------------------------------------------------------------------------- /man/Mrode3.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{Mrode3} 5 | \alias{Mrode3} 6 | \title{Pedigree, from chapter 3 of Mrode (2005) with genetic groups and a trait column} 7 | \format{ 8 | A \code{data.frame} with 10 observations on the following 8 variables: 9 | \describe{ 10 | \item{calf }{a factor with levels indicating the unique genetic groups 11 | and individuals} 12 | \item{dam }{a numeric vector of maternal identities} 13 | \item{sire }{a numeric vector of paternal identities} 14 | \item{damGG }{a factor of maternal identities with genetic groups 15 | inserted instead of \code{NA}} 16 | \item{sireGG }{a factor of paternal identities with genetic groups 17 | inserted instead of \code{NA}} 18 | \item{sex }{a factor with levels \code{female} \code{male}} 19 | \item{WWG }{a numeric vector of pre-weaning weight gain (kg) for five 20 | beef calves} 21 | } 22 | } 23 | \source{ 24 | Mrode, R.A. 2005. Linear Models for the Prediction of Animal 25 | Breeding Values, 2nd ed. Cambridge, MA: CABI Publishing. 26 | } 27 | \usage{ 28 | Mrode3 29 | } 30 | \description{ 31 | Pedigree, from chapter 3 of Mrode (2005) with genetic groups and a trait column 32 | } 33 | \examples{ 34 | data(Mrode3) 35 | str(Mrode3) 36 | } 37 | \keyword{datasets} 38 | -------------------------------------------------------------------------------- /man/constrainFun.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/constrainFun.R 3 | \name{constrainFun} 4 | \alias{constrainFun} 5 | \title{Fix a Model Parameter and Conduct Likelihood Ratio Test} 6 | \usage{ 7 | constrainFun(parameter.val, full, fm2, comp, G, mit = 600) 8 | } 9 | \arguments{ 10 | \item{parameter.val}{a value for which the log-Likelihood of a model is to 11 | be calculated} 12 | 13 | \item{full}{the full model \code{asreml} object} 14 | 15 | \item{fm2}{starting values for the full model} 16 | 17 | \item{comp}{which variance component to constrain} 18 | 19 | \item{G}{logical, indicating if the component is part of the G structure} 20 | 21 | \item{mit}{numeric, indicating maximum number of iterations for the 22 | constrained asreml model} 23 | } 24 | \value{ 25 | A \code{vector} of length 1 returning either a \code{numeric} value 26 | corresponding to the likelihood ratio test statistic or else the missing 27 | value indicator \code{NA}. 28 | } 29 | \description{ 30 | Given a model object from \code{asreml} and a range of estimates of the 31 | parameter, the function will supply the likelihood ratio test statistic for 32 | the comparison of the full model to one where the parameter of interest is 33 | constrained. 34 | } 35 | \seealso{ 36 | See also \code{\link{LRTest}} 37 | } 38 | \author{ 39 | \email{matthewwolak@gmail.com} 40 | } 41 | -------------------------------------------------------------------------------- /R/sm2list.R: -------------------------------------------------------------------------------- 1 | ##################################### 2 | #adapted from code written by 3 | #Jarrod Hadfield in the 4 | #MCMCglmm package 5 | ###################################### 6 | 7 | 8 | #' Converts a sparse matrix into a three column format. 9 | #' 10 | #' From a sparse matrix object, the three column, row ordered lower triangle of 11 | #' non-zero elements is created. Mostly used within other functions (i.e., 12 | #' \code{makeD}) 13 | #' 14 | #' The sparse matrix and three column format must fit CERTAIN assumptions about 15 | #' row/column sorting and lower/upper triangle matrix. 16 | #' 17 | #' Adapted from a function in the \code{MCMCglmm} package 18 | #' 19 | #' @param A a sparse matrix 20 | #' @param rownames a list of rownames from the 'A' matrix. 21 | #' @param colnames the columns will be labeled however they are entered in 22 | #' this character vector 23 | #' @return returns the list form of the sparse matrix as a \code{data.frame} 24 | #' @seealso \code{\link[MCMCglmm]{MCMCglmm}} 25 | #' @export 26 | sm2list<-function(A, rownames = NULL, colnames=c("row", "column", "A")) 27 | { 28 | ginv <- data.frame(Row = rep(1:length(A@p[-1]), 29 | diff(A@p)), Column = A@i + 1, Ainverse = A@x) 30 | ginv <- ginv[order(ginv$Row), ] 31 | ginv <- ginv[which(ginv$Row >= ginv$Column), ] 32 | attr(ginv, "rowNames") <- rownames 33 | names(ginv)<-colnames 34 | return(ginv) 35 | } 36 | 37 | -------------------------------------------------------------------------------- /man/simPedHS.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simPed.R 3 | \name{simPedHS} 4 | \alias{simPedHS} 5 | \title{Half-sib pedigree construction} 6 | \usage{ 7 | simPedHS(s, d, n, uniqueDname = TRUE, prefix = NULL) 8 | } 9 | \arguments{ 10 | \item{s}{Number of sires} 11 | 12 | \item{d}{Number of dams per sire} 13 | 14 | \item{n}{Number of offspring per mating (must be > or = 2)} 15 | 16 | \item{uniqueDname}{Logical indicating if dams should have unique names 17 | within sire families or throughout the entire pedigree} 18 | 19 | \item{prefix}{Optional prefix to add to every identity} 20 | } 21 | \value{ 22 | A \code{data.frame} with columns corresponding to: id, dam, sire, 23 | and sex. Sex is "M" for males and "F" for females. 24 | } 25 | \description{ 26 | Simulates a pedigree for a half-sib mating design (sometimes also called the 27 | North Carolina Design 1). 28 | } 29 | \details{ 30 | \code{n} must be greater than or equal to 2, because one male and one female 31 | offspring are produced from each mating 32 | 33 | Some functions/calculations get bogged down if no two dams have the same ID 34 | in the entire pedigree (e.g., \code{aov}). However, other functions must 35 | have unique identifiers for every individual. 36 | } 37 | \examples{ 38 | 39 | simPedHS(s = 1, d = 3, n = 2) 40 | 41 | } 42 | \seealso{ 43 | \code{\link{simPedDFC}} 44 | } 45 | \author{ 46 | \email{matthewwolak@gmail.com} 47 | } 48 | -------------------------------------------------------------------------------- /man/varTrans.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/varTrans.R 3 | \name{varTrans} 4 | \alias{varTrans} 5 | \title{Transforms ASReml-R gamma sampling variances to component scale} 6 | \usage{ 7 | varTrans(asr.object) 8 | } 9 | \arguments{ 10 | \item{asr.object}{Object from a call to \code{asreml}} 11 | } 12 | \value{ 13 | Returns a numeric vector of variances for each variance component in 14 | an ASReml-R model. 15 | } 16 | \description{ 17 | The inverse of the Average Information matrix in an ASReml-R object produces 18 | the sampling variances of the (co)variance components on the gamma scale. 19 | This function scales these variances to the original component scale. This 20 | allows for Confidence Intervals to be constructed about the variance 21 | component estimates. 22 | } 23 | \examples{ 24 | 25 | \dontrun{ 26 | library(asreml) 27 | ginvA <- ainverse(warcolak) 28 | ginvD <- makeD(warcolak[, 1:3])$listDinv 29 | attr(ginvD, "rowNames") <- as.character(warcolak[, 1]) 30 | attr(ginvD, "INVERSE") <- TRUE 31 | warcolak$IDD <- warcolak$ID 32 | warcolak.mod <- asreml(trait1 ~ sex, 33 | random = ~ vm(ID, ginvA) + vm(IDD, ginvD), 34 | data = warcolak) 35 | summary(warcolak.mod)$varcomp 36 | sqrt(varTrans(warcolak.mod)) # sqrt() so can compare with standard errors from summary 37 | } 38 | 39 | } 40 | \author{ 41 | \email{matthewwolak@gmail.com} 42 | } 43 | -------------------------------------------------------------------------------- /R/makeM.R: -------------------------------------------------------------------------------- 1 | #' Creates the (additive) mutational effects relationship matrix 2 | #' 3 | #' This returns the (additive) mutational effects relationship matrix in sparse 4 | #' matrix format. 5 | #' 6 | #' Missing parents (e.g., base population) should be denoted by either 'NA', 7 | #' '0', or '*'. 8 | #' 9 | #' See function \code{\link{makeMinv}} for directly obtaining the inverse of 10 | #' the (additive) mutational effects genetic relationship matrix. 11 | #' 12 | #' @param pedigree A pedigree where the columns are ordered ID, Dam, Sire 13 | #' 14 | #' @return Returns M, or the mutational effects relationship matrix, in sparse 15 | #' matrix form. 16 | #' @author \email{matthewwolak@@gmail.com} 17 | #' @seealso \code{\link{makeA}}, \code{\link{makeS}} 18 | #' @examples 19 | #' 20 | #' makeM(Mrode2) 21 | #' 22 | #' @export 23 | makeM <- function(pedigree){ 24 | 25 | nPed <- numPed(pedigree) 26 | N <- nrow(nPed) 27 | Tinv <- makeTinv(nPed) 28 | nPed[nPed == -998] <- N + 1 29 | Cout <- .C("mdiif", PACKAGE = "nadiv", 30 | as.integer(nPed[, 2] - 1), #dam 31 | as.integer(nPed[, 3] - 1), #sire 32 | as.double(rep(0, N)), #h 33 | as.double(rep(0, N)), #dii 34 | as.integer(N)) #n 35 | 36 | M <- as(tcrossprod(solve(Diagonal(x = sqrt(1 / Cout[[4]]), n = N) %*% Tinv)), 37 | "symmetricMatrix") 38 | 39 | M@Dimnames <- list(as.character(pedigree[, 1]), 40 | as.character(pedigree[, 1])) 41 | M 42 | } 43 | 44 | -------------------------------------------------------------------------------- /src/reT.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void reT( 6 | int *dam, 7 | int *sire, 8 | int *i, 9 | int *p, 10 | double *x, 11 | int *maxcnt, 12 | int *n, 13 | double *tx 14 | 15 | ){ 16 | 17 | int k, kdam, ksire, cnt; 18 | 19 | cnt = 0; 20 | for(k = 0; k < n[0]; k++){ 21 | p[k] = cnt; 22 | kdam = dam[k]; 23 | ksire = sire[k]; 24 | if(kdam == ksire){ 25 | if(kdam != -999){ 26 | i[cnt] += kdam; 27 | x[cnt] -= tx[2]; 28 | cnt++; 29 | } 30 | } 31 | else{ 32 | if(kdam < ksire){ 33 | if(kdam != -999){ 34 | i[cnt] += kdam; 35 | x[cnt] -= tx[0]; 36 | cnt++; 37 | } 38 | if(ksire != -999){ 39 | i[cnt] += ksire; 40 | x[cnt] -= tx[1]; 41 | cnt++; 42 | } 43 | } 44 | else{ 45 | if(ksire != -999){ 46 | i[cnt] += ksire; 47 | x[cnt] -= tx[1]; 48 | cnt++; 49 | } 50 | if(kdam != -999){ 51 | i[cnt] += kdam; 52 | x[cnt] -= tx[0]; 53 | cnt++; 54 | } 55 | } 56 | } 57 | i[cnt] += k; 58 | x[cnt] += tx[3]; 59 | cnt++; 60 | } 61 | p[n[0]] += cnt; 62 | maxcnt[0] = cnt; 63 | 64 | } 65 | } 66 | -------------------------------------------------------------------------------- /man/Q1988.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{Q1988} 5 | \alias{Q1988} 6 | \title{Pedigree with genetic groups adapted from Quaas (1988) equation [5]} 7 | \format{ 8 | A \code{data.frame} with 11 observations on the following 8 variables: 9 | \describe{ 10 | \item{id }{a factor with levels indicating the unique individuals 11 | (including phantom parents) and genetic groups} 12 | \item{dam }{a factor of observed maternal identities} 13 | \item{sire }{a factor vector of observed paternal identities} 14 | \item{damGG }{a factor of maternal identities with genetic groups 15 | inserted instead of \code{NA}} 16 | \item{sireGG }{a factor of paternal identities with genetic groups 17 | inserted instead of \code{NA}} 18 | \item{phantomDam }{a factor of maternal identities with phantom parents 19 | inserted instead of \code{NA}} 20 | \item{phantomSire }{a factor of paternal identities with phantom parents 21 | inserted instead of \code{NA}} 22 | \item{group }{a factor of genetic groups to which each phantom parent 23 | belongs} 24 | } 25 | } 26 | \source{ 27 | Quaas, R.L. 1988. Additive genetic model with groups and 28 | relationships. Journal of Dairy Science 71:1338-1345. 29 | } 30 | \usage{ 31 | Q1988 32 | } 33 | \description{ 34 | Pedigree with genetic groups adapted from Quaas (1988) equation [5] 35 | } 36 | \examples{ 37 | data(Q1988) 38 | str(Q1988) 39 | } 40 | \keyword{datasets} 41 | -------------------------------------------------------------------------------- /man/aic.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aic.R 3 | \name{aic} 4 | \alias{aic} 5 | \title{Akaike Information Criterion} 6 | \usage{ 7 | aic(logLik, fp, n = NULL) 8 | } 9 | \arguments{ 10 | \item{logLik}{A vector of model log-Likelihoods} 11 | 12 | \item{fp}{A vector containing the numbers of free parameters of each model 13 | included in the logLik vector} 14 | 15 | \item{n}{An optional vector of sample sizes for each model. Used to 16 | calculate AICc (small sample unbiased AIC).} 17 | } 18 | \value{ 19 | a \code{list}: 20 | \describe{ 21 | \item{AIC }{vector containing AIC/AICc (depending on value of \code{n})} 22 | \item{delta_AIC }{vector containing AIC differences from the minimum 23 | AIC(c)} 24 | \item{AIClik }{vector containing likelihoods for each model, given the 25 | data. Represents the relative strength of evidence for each model.} 26 | \item{w }{Akaike weights.} 27 | } 28 | } 29 | \description{ 30 | Calculates AIC/AICc values, AIC differences, Likelihood of models, and model 31 | probabilities. 32 | } 33 | \details{ 34 | Calculations and notation follows chapter 2 of Burnham and Anderson (2002). 35 | } 36 | \examples{ 37 | 38 | aic(c(-3139.076, -3136.784, -3140.879, -3152.432), c(8, 7, 8, 5)) 39 | 40 | } 41 | \references{ 42 | Burnham, K.P. and D.R. Anderson. 2002. Model Selection and 43 | Multimodel Inference. A Practical Information-Theoretic Approach, 2nd edn. 44 | Springer, New York. 45 | } 46 | \author{ 47 | \email{matthewwolak@gmail.com} 48 | } 49 | -------------------------------------------------------------------------------- /R/makeAA.R: -------------------------------------------------------------------------------- 1 | #' Creates the additive by additive epistatic genetic relationship matrix 2 | #' 3 | #' Given a pedigree, the matrix of additive by additive genetic relatedness 4 | #' (AA) among all individuals in the pedigree is returned. 5 | #' 6 | #' Missing parents (e.g., base population) should be denoted by either 'NA', 7 | #' '0', or '*'. 8 | #' 9 | #' The function first estimates the A matrix using \code{\link{makeA}}, then it 10 | #' calculates the Hadamard (element-wise) product of the A matrix with itself 11 | #' (A # A). 12 | #' 13 | #' @param pedigree A pedigree where the columns are ordered ID, Dam, Sire 14 | #' 15 | #' @return a \code{list}: 16 | #' \describe{ 17 | #' \item{AA }{the AA matrix in sparse matrix form} 18 | #' \item{logDet }{the log determinant of the AA matrix} 19 | #' \item{AAinv }{the inverse of the AA matrix in sparse matrix form} 20 | #' \item{listAAinv }{the three column form of the non-zero elements for the 21 | #' inverse of the AA matrix} 22 | #' } 23 | #' @author \email{matthewwolak@@gmail.com} 24 | #' @seealso \code{\link{makeA}} 25 | #' @examples 26 | #' 27 | #' makeAA(Mrode2) 28 | #' 29 | #' @export 30 | makeAA <- function(pedigree) 31 | { 32 | A <- makeA(pedigree) 33 | AA <- A*A 34 | logDet <- determinant(AA, logarithm = TRUE)$modulus[1] 35 | AAinv <- solve(AA) 36 | AAinv@Dimnames <- list(as.character(pedigree[, 1]), NULL) 37 | listAAinv <- sm2list(AAinv, rownames=pedigree[,1], colnames=c("row", "column", "AAinverse")) 38 | return(list(AA = AA, logDet = logDet, AAinv = AAinv, listAAinv = listAAinv)) 39 | } 40 | 41 | -------------------------------------------------------------------------------- /src/cs_multiply.c: -------------------------------------------------------------------------------- 1 | #include "cs.h" 2 | /* C = A*B */ 3 | cs *cs_multiply (const cs *A, const cs *B) 4 | { 5 | int p, j, nz = 0, anz, *Cp, *Ci, *Bp, m, n, bnz, *w, values, *Bi ; 6 | double *x, *Bx, *Cx ; 7 | cs *C ; 8 | if (!CS_CSC (A) || !CS_CSC (B)) return (NULL) ; /* check inputs */ 9 | if (A->n != B->m) return (NULL) ; 10 | m = A->m ; anz = A->p [A->n] ; 11 | n = B->n ; Bp = B->p ; Bi = B->i ; Bx = B->x ; bnz = Bp [n] ; 12 | w = cs_calloc (m, sizeof (int)) ; /* get workspace */ 13 | values = (A->x != NULL) && (Bx != NULL) ; 14 | x = values ? cs_malloc (m, sizeof (double)) : NULL ; /* get workspace */ 15 | C = cs_spalloc (m, n, anz + bnz, values, 0) ; /* allocate result */ 16 | if (!C || !w || (values && !x)) return (cs_done (C, w, x, 0)) ; 17 | // if (!C || !w || (values && !x)) error("cs_multiply out of memory"); 18 | 19 | Cp = C->p ; 20 | for (j = 0 ; j < n ; j++) 21 | { 22 | if (nz + m > C->nzmax && !cs_sprealloc (C, 2*(C->nzmax)+m)) 23 | { 24 | return (cs_done (C, w, x, 0)) ; /* out of memory */ 25 | } 26 | Ci = C->i ; Cx = C->x ; /* C->i and C->x may be reallocated */ 27 | Cp [j] = nz ; /* column j of C starts here */ 28 | for (p = Bp [j] ; p < Bp [j+1] ; p++) 29 | { 30 | nz = cs_scatter (A, Bi [p], Bx ? Bx [p] : 1, w, x, j+1, C, nz) ; 31 | } 32 | if (values) for (p = Cp [j] ; p < nz ; p++) Cx [p] = x [Ci [p]] ; 33 | } 34 | Cp [n] = nz ; /* finalize the last column of C */ 35 | cs_sprealloc (C, 0) ; /* remove extra space from C */ 36 | return (cs_done (C, w, x, 1)) ; /* success; free workspace, return C */ 37 | } 38 | -------------------------------------------------------------------------------- /man/drfx.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/drfx.R 3 | \name{drfx} 4 | \alias{drfx} 5 | \title{Simulated design random effects} 6 | \usage{ 7 | drfx(G, fac, dataf, ...) 8 | } 9 | \arguments{ 10 | \item{G}{The variance-covariance matrix to model the effects after} 11 | 12 | \item{fac}{A character indicating the factor in \code{dataf} with which to 13 | construct the design matrix} 14 | 15 | \item{dataf}{A dataframe with \code{fac} in it} 16 | 17 | \item{...}{Arguments to be passed to the internal use of \code{\link{grfx}}} 18 | } 19 | \value{ 20 | \item{fx }{A matrix with 'd' columns of random effects} \item{Z }{A 21 | design matrix (of the format 'Matrix') from which the random effects in 22 | \code{fx} were assigned } 23 | } 24 | \description{ 25 | This function simulates effects for random terms in a linear mixed model 26 | based on design matrices. The intended purpose is for simulating 27 | environmental effects from a pedigree. 28 | } 29 | \details{ 30 | If G = x, where 'x' is a single number, then 'x' should still be specified 31 | as a 1-by-1 matrix (e.g., \code{matrix(x)}). Note, the G-matrix should 32 | never have a structure which produces a correlation exactly equal to 1 or 33 | -1. Instead, covariances should be specified so as to create a correlation 34 | of slightly less than (greater than) 1 (-1). For example: 0.9999 or 35 | -0.9999. 36 | } 37 | \examples{ 38 | 39 | # Create maternal common environment effects for 2 traits 40 | # with perfectly correlated effects 41 | Gmat <- matrix(c(10, 7.071, 7.071, 5), 2, 2) 42 | cfx <- drfx(G = Gmat, fac = "Dam", dataf = warcolak[1:200, ]) 43 | 44 | 45 | } 46 | \seealso{ 47 | \code{\link{grfx}} 48 | } 49 | \author{ 50 | \email{matthewwolak@gmail.com} 51 | } 52 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(genAssign,default) 4 | S3method(genAssign,numPed) 5 | S3method(geneDrop,default) 6 | S3method(geneDrop,numPed) 7 | S3method(makeAinv,default) 8 | S3method(makeAinv,fuzzy) 9 | S3method(makeDiiF,default) 10 | S3method(makeDiiF,numPed) 11 | S3method(makeT,default) 12 | S3method(makeTinv,default) 13 | S3method(makeTinv,numPed) 14 | S3method(prunePed,default) 15 | S3method(prunePed,numPed) 16 | export(LRTest) 17 | export(aiCI) 18 | export(aiFun) 19 | export(aic) 20 | export(constrainFun) 21 | export(drfx) 22 | export(findDFC) 23 | export(founderLine) 24 | export(genAssign) 25 | export(geneDrop) 26 | export(ggcontrib) 27 | export(grfx) 28 | export(makeA) 29 | export(makeAA) 30 | export(makeAinv) 31 | export(makeAstarMult) 32 | export(makeD) 33 | export(makeDiiF) 34 | export(makeDomEpi) 35 | export(makeDsim) 36 | export(makeGGAinv) 37 | export(makeM) 38 | export(makeMinv) 39 | export(makeMinvML) 40 | export(makeS) 41 | export(makeSd) 42 | export(makeSdsim) 43 | export(makeT) 44 | export(makeTinv) 45 | export(numPed) 46 | export(pcc) 47 | export(pin) 48 | export(prepPed) 49 | export(prunePed) 50 | export(ronPed) 51 | export(simGG) 52 | export(simPedDFC) 53 | export(simPedHS) 54 | export(simPedMCN) 55 | export(sm2list) 56 | export(varTrans) 57 | import(Matrix) 58 | importFrom(graphics,abline) 59 | importFrom(graphics,plot) 60 | importFrom(methods,as) 61 | importFrom(methods,is) 62 | importFrom(methods,new) 63 | importFrom(stats,as.formula) 64 | importFrom(stats,deriv) 65 | importFrom(stats,na.omit) 66 | importFrom(stats,optimize) 67 | importFrom(stats,pchisq) 68 | importFrom(stats,qchisq) 69 | importFrom(stats,qnorm) 70 | importFrom(stats,rnorm) 71 | importFrom(stats,sd) 72 | useDynLib(nadiv, .registration = TRUE) 73 | -------------------------------------------------------------------------------- /R/varTrans.R: -------------------------------------------------------------------------------- 1 | #' Transforms ASReml-R gamma sampling variances to component scale 2 | #' 3 | #' The inverse of the Average Information matrix in an ASReml-R object produces 4 | #' the sampling variances of the (co)variance components on the gamma scale. 5 | #' This function scales these variances to the original component scale. This 6 | #' allows for Confidence Intervals to be constructed about the variance 7 | #' component estimates. 8 | #' 9 | #' 10 | #' @param asr.object Object from a call to \code{asreml} 11 | #' @return Returns a numeric vector of variances for each variance component in 12 | #' an ASReml-R model. 13 | #' @author \email{matthewwolak@@gmail.com} 14 | #' @examples 15 | #' 16 | #' \dontrun{ 17 | #' library(asreml) 18 | #' ginvA <- ainverse(warcolak) 19 | #' ginvD <- makeD(warcolak[, 1:3])$listDinv 20 | #' attr(ginvD, "rowNames") <- as.character(warcolak[, 1]) 21 | #' attr(ginvD, "INVERSE") <- TRUE 22 | #' warcolak$IDD <- warcolak$ID 23 | #' warcolak.mod <- asreml(trait1 ~ sex, 24 | #' random = ~ vm(ID, ginvA) + vm(IDD, ginvD), 25 | #' data = warcolak) 26 | #' summary(warcolak.mod)$varcomp 27 | #' sqrt(varTrans(warcolak.mod)) # sqrt() so can compare with standard errors from summary 28 | #' } 29 | #' 30 | #' @export 31 | varTrans <- function(asr.object){ 32 | if(asr.object$sigma2 == 1){ 33 | vars <- diag(aiFun(asr.object)) 34 | } else{ 35 | Rcomp <- which(asr.object$gammas == 1.00) 36 | AI <- aiFun(asr.object) 37 | comps <- asr.object$gammas * asr.object$sigma2 38 | vars <- c(((asr.object$gammas[-Rcomp]^2) * diag(AI)[Rcomp] + comps[Rcomp]^2 * diag(AI)[-Rcomp] + 2*asr.object$gammas[-Rcomp]*comps[Rcomp]*AI[Rcomp, -Rcomp]), diag(AI)[Rcomp]) 39 | } 40 | vars 41 | } 42 | 43 | -------------------------------------------------------------------------------- /inst/WORDLIST: -------------------------------------------------------------------------------- 1 | AICc 2 | ASReml 3 | ASReml's 4 | Acad 5 | Ainv 6 | Astar 7 | BLUP 8 | Biometrics 9 | Burnham 10 | CABI 11 | Cano 12 | Casellas 13 | Charmantier 14 | Colleau 15 | Cullis 16 | DMU's 17 | DOI 18 | Dinv 19 | Dinverse 20 | Dominicus 21 | Drosophila 22 | Epigenetic 23 | Evol 24 | Fairbairn 25 | Fikse 26 | Foulley 27 | Fx 28 | Garant 29 | Gilmour 30 | Gjessing 31 | Gogel 32 | Grossman 33 | Hadamard 34 | Hadfield 35 | Hadfield's 36 | Hemel 37 | Hempstead 38 | Jagan 39 | Kondrashov 40 | Kruuk 41 | Liang 42 | Luo 43 | Luo's 44 | MCMCglmm 45 | Medrano 46 | Medrano's 47 | Merila 48 | Meuwissen 49 | Mikael 50 | Mincidence 51 | Mrode 52 | Multimodel 53 | Nemophila 54 | Ovaskainen 55 | Palmgren 56 | Pedersen 57 | Ph 58 | Phenotypes 59 | Proc 60 | Quaas 61 | Roff 62 | Roff's 63 | Sd 64 | Sdinv 65 | Sdsim 66 | Sdsiminv 67 | Sel 68 | Shabalina 69 | Sinauer 70 | Skrondal 71 | Springer 72 | Sunderland 73 | TDT 74 | TVT 75 | Tinv 76 | VSN 77 | VanRaden 78 | Verrier 79 | Warcolaks 80 | Wray 81 | Yampolsky 82 | al 83 | allelic 84 | asreml 85 | autosomes 86 | cholesky 87 | coancestry 88 | cpu 89 | cpus 90 | det 91 | dgCMatrix 92 | dimorphism 93 | doi 94 | dsCMatrix 95 | dtCMatrix 96 | dtpMatrix 97 | dtrMatrix 98 | eb 99 | edn 100 | epistatic 101 | et 102 | grandparental 103 | grfx 104 | hedo 105 | heritability 106 | heterogametic 107 | hoha 108 | homogametic 109 | hopi 110 | hori 111 | https 112 | i's 113 | invertD 114 | iteratively 115 | j's 116 | kronecker 117 | logLik 118 | makeA 119 | makeD 120 | matriline 121 | melanogaster 122 | menziesii 123 | microevolutionary 124 | nd 125 | ngdc 126 | numPed 127 | panmictic 128 | parallelization 129 | patriline 130 | pcc 131 | phenotyped 132 | phenotypes 133 | pre 134 | prev 135 | proLik 136 | selfing 137 | stdnorms 138 | subclasses 139 | uk 140 | vsni 141 | www 142 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # nadiv 2 | [![](https://www.r-pkg.org/badges/version/nadiv)](https://cran.r-project.org/package=nadiv) 3 | [![](https://cranlogs.r-pkg.org/badges/grand-total/nadiv)](https://cranlogs.r-pkg.org/badges/grand-total/nadiv) 4 | [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.11371698.svg)](https://doi.org/10.5281/zenodo.11371698) 5 | 6 | 7 | R package that constructs (non)additive genetic relationship matrices, and their inverses, from a pedigree to be used in linear mixed effect models (A.K.A. the 'animal model'). Also includes other functions to facilitate the use of animal models. Some functions have been created to be used in conjunction with the R package for ASReml software. 8 | 9 | ## See the latest developments: 10 | - nadiv [NEWS page](https://github.com/matthewwolak/nadiv/blob/master/NEWS.md) 11 | 12 | ## Overview of main branches: 13 | - `master` branch is the most recent production version (typically the same as what is available from the [R CRAN mirrors](https://cran.r-project.org/)) 14 | 15 | - `devel` branch is a preview of the next release which _should_ be functional and error/bug free, but proceed with caution 16 | 17 | 18 | ## To obtain nadiv: 19 | - From [R](https://CRAN.R-project.org/): 20 | - see the package page for the latest release of [nadiv on CRAN](https://CRAN.R-project.org/package=nadiv) where you can download the source. 21 | - install the latest release of the package directly in R: 22 | ```R 23 | install.packages("nadiv") 24 | ``` 25 | - then select your favorite [CRAN mirror](https://CRAN.R-project.org/) 26 | 27 | - From GitHub: 28 | - clone or download the latest development version here 29 | - install the latest development version directly in R using the `remotes` package [https://github.com/r-lib/remotes](https://github.com/r-lib/remotes): 30 | ```R 31 | library(remotes); install_github("matthewwolak/nadiv", ref = "devel") 32 | ``` 33 | 34 | -------------------------------------------------------------------------------- /man/F2009.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{F2009} 5 | \alias{F2009} 6 | \title{Pedigree adapted from Fikse 2009 with genetic groups and fuzzy classification} 7 | \format{ 8 | A \code{data.frame} with 16 observations on the following 11 variables: 9 | \describe{ 10 | \item{id }{a factor with levels indicating the unique individuals 11 | (including phantom parents) and genetic groups} 12 | \item{dam }{a factor of observed maternal identities} 13 | \item{sire }{a factor vector of observed paternal identities} 14 | \item{damGG }{a factor of maternal identities with genetic groups 15 | inserted instead of \code{NA}} 16 | \item{sireGG }{a factor of paternal identities with genetic groups 17 | inserted instead of \code{NA}} 18 | \item{phantomDam }{a factor of maternal identities with phantom parents 19 | inserted instead of \code{NA}} 20 | \item{phantomSire }{a factor of paternal identities with phantom parents 21 | inserted instead of \code{NA}} 22 | \item{group }{a factor of genetic groups to which each phantom parent 23 | belongs} 24 | \item{g1 }{a numeric vector with probabilities of group \code{g1} 25 | membership for each phantom parent} 26 | \item{g2 }{a numeric vector with probabilities of group \code{g2} 27 | membership for each phantom parent} 28 | \item{g3 }{a numeric vector with probabilities of group \code{g3} 29 | membership for each phantom parent} 30 | } 31 | } 32 | \source{ 33 | Fikse, F. 2009. Fuzzy classification of phantom parent groups in an 34 | animal model. Genetics Selection Evolution 41:42. 35 | } 36 | \usage{ 37 | F2009 38 | } 39 | \description{ 40 | Pedigree adapted from Fikse 2009 with genetic groups and fuzzy classification 41 | } 42 | \examples{ 43 | data(F2009) 44 | str(F2009) 45 | } 46 | \keyword{datasets} 47 | -------------------------------------------------------------------------------- /src/dsim.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void dsim(int *da, 6 | int *sa, 7 | int *eN, 8 | int *en, 9 | int *dam, 10 | int *sire, 11 | int *Di, 12 | int *Dp, 13 | int *sdij 14 | ){ 15 | 16 | int i, j, k, m, p, l; 17 | int mi, si, cdama, csirea, rdama, rsirea; 18 | int adij = 0; 19 | GetRNGstate(); 20 | 21 | for(i = 0; i < en[0]; i++){ 22 | mi = dam[i]; 23 | si = sire[i]; 24 | if(mi != -999){ 25 | k = i*eN[0]; 26 | for(j = 0; j < eN[0]; j++){ 27 | if(runif(0.0, 2.0) > 1.0){ 28 | da[k] = da[(mi*eN[0]) + j]; 29 | } 30 | else { 31 | da[k] = sa[(mi*eN[0]) + j]; 32 | } 33 | k++; 34 | } 35 | } 36 | 37 | if(si != -999){ 38 | k = i*eN[0]; 39 | for(j = 0; j < eN[0]; j++){ 40 | if(runif(0.0, 2.0) > 1.0){ 41 | sa[k] = da[(si*eN[0]) + j]; 42 | } 43 | else { 44 | sa[k] = sa[(si*eN[0]) + j]; 45 | } 46 | k++; 47 | } 48 | } 49 | } 50 | 51 | PutRNGstate(); 52 | 53 | 54 | for(m = 0; m < en[0]; m++){ 55 | for(p = Dp[m]; p < Dp[m+1]; p++){ 56 | sdij[p] = 0; 57 | adij = 0; 58 | for(l = 0; l < eN[0]; l++){ 59 | cdama = da[m*eN[0]+l]; 60 | csirea = sa[m*eN[0]+l]; 61 | rdama = da[Di[p]*eN[0]+l]; 62 | rsirea = sa[Di[p]*eN[0]+l]; 63 | 64 | if(cdama == rdama){ 65 | if(csirea == rsirea){ 66 | adij += 1; 67 | } 68 | } 69 | else{ 70 | if(cdama == rsirea){ 71 | if(csirea == rdama){ 72 | adij += 1; 73 | } 74 | } 75 | } 76 | 77 | 78 | } 79 | 80 | sdij[p] += adij; 81 | 82 | } 83 | } 84 | 85 | } 86 | } 87 | -------------------------------------------------------------------------------- /R/aic.R: -------------------------------------------------------------------------------- 1 | #' Akaike Information Criterion 2 | #' 3 | #' Calculates AIC/AICc values, AIC differences, Likelihood of models, and model 4 | #' probabilities. 5 | #' 6 | #' Calculations and notation follows chapter 2 of Burnham and Anderson (2002). 7 | #' 8 | #' @param logLik A vector of model log-Likelihoods 9 | #' @param fp A vector containing the numbers of free parameters of each model 10 | #' included in the logLik vector 11 | #' @param n An optional vector of sample sizes for each model. Used to 12 | #' calculate AICc (small sample unbiased AIC). 13 | #' 14 | #' @return a \code{list}: 15 | #' \describe{ 16 | #' \item{AIC }{vector containing AIC/AICc (depending on value of \code{n})} 17 | #' \item{delta_AIC }{vector containing AIC differences from the minimum 18 | #' AIC(c)} 19 | #' \item{AIClik }{vector containing likelihoods for each model, given the 20 | #' data. Represents the relative strength of evidence for each model.} 21 | #' \item{w }{Akaike weights.} 22 | #' } 23 | #' @author \email{matthewwolak@@gmail.com} 24 | #' @references Burnham, K.P. and D.R. Anderson. 2002. Model Selection and 25 | #' Multimodel Inference. A Practical Information-Theoretic Approach, 2nd edn. 26 | #' Springer, New York. 27 | #' @examples 28 | #' 29 | #' aic(c(-3139.076, -3136.784, -3140.879, -3152.432), c(8, 7, 8, 5)) 30 | #' 31 | #' @export 32 | aic <- function(logLik, fp, n = NULL){ 33 | if(is.numeric(n)){ 34 | AICc <- -2*(logLik - fp * (n / (n - fp - 1))) 35 | delta_AIC <- AICc - min(AICc) 36 | } else{ 37 | AIC <- -2*(logLik - fp) 38 | delta_AIC <- AIC - min(AIC) 39 | } 40 | AIClik <- exp(-0.5*delta_AIC) 41 | w <- AIClik / sum(AIClik) 42 | 43 | if(is.numeric(n)){ 44 | return(list(AICc = AICc, delta_AIC = delta_AIC, AIClik = AIClik, w = w)) 45 | } else{ 46 | return(list(AIC = AIC, delta_AIC = delta_AIC, AIClik = AIClik, w = w)) 47 | } 48 | } 49 | 50 | -------------------------------------------------------------------------------- /man/aiCI.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aiCI.R 3 | \name{aiCI} 4 | \alias{aiCI} 5 | \title{Confidence Intervals for Variance Components} 6 | \usage{ 7 | aiCI(asr.model, Dimnames = NULL, alpha = 0.05) 8 | } 9 | \arguments{ 10 | \item{asr.model}{Object from a call to \code{asreml}} 11 | 12 | \item{Dimnames}{A vector of characters if names are desired for the output. 13 | If not specified, the default labels from the \code{asreml} object will be 14 | used.} 15 | 16 | \item{alpha}{A numeric value indicating the level of Type I error for 17 | constructing the Confidence Intervals.} 18 | } 19 | \value{ 20 | A \code{matrix} is returned with a row for each variance component. 21 | The three columns correspond to the Lower Confidence Limit, estimate from 22 | the \code{asreml} model, and Upper Confidence Limit for each variance 23 | component. 24 | } 25 | \description{ 26 | Produces the 1-alpha Upper and Lower Confidence Limits for the variance 27 | components in an ASReml-R model. 28 | } 29 | \details{ 30 | Variances from the inverse of the Average Information matrix of an ASReml 31 | model are translated according to the \code{\link{varTrans}} function and 32 | used in constructing the 1-alpha Confidence Interval. 33 | } 34 | \note{ 35 | The vector of \code{Dimnames} should match the same order of variance 36 | components specified in the model. 37 | } 38 | \examples{ 39 | 40 | \dontrun{ 41 | library(asreml) 42 | ginvA <- ainverse(warcolak) 43 | ginvD <- makeD(warcolak[, 1:3])$listDinv 44 | attr(ginvD, "rowNames") <- as.character(warcolak[, 1]) 45 | attr(ginvD, "INVERSE") <- TRUE 46 | warcolak$IDD <- warcolak$ID 47 | warcolak.mod <- asreml(trait1 ~ sex, 48 | random = ~ vm(ID, ginvA) + vm(IDD, ginvD), 49 | data = warcolak) 50 | summary(warcolak.mod)$varcomp 51 | aiCI(warcolak.mod) 52 | } 53 | 54 | } 55 | \seealso{ 56 | \code{\link{aiFun}} 57 | } 58 | \author{ 59 | \email{matthewwolak@gmail.com} 60 | } 61 | -------------------------------------------------------------------------------- /R/constrainFun.R: -------------------------------------------------------------------------------- 1 | #' Fix a Model Parameter and Conduct Likelihood Ratio Test 2 | #' 3 | #' Given a model object from \code{asreml} and a range of estimates of the 4 | #' parameter, the function will supply the likelihood ratio test statistic for 5 | #' the comparison of the full model to one where the parameter of interest is 6 | #' constrained. 7 | #' 8 | #' @param parameter.val a value for which the log-Likelihood of a model is to 9 | #' be calculated 10 | #' @param full the full model \code{asreml} object 11 | #' @param fm2 starting values for the full model 12 | #' @param comp which variance component to constrain 13 | #' @param G logical, indicating if the component is part of the G structure 14 | #' @param mit numeric, indicating maximum number of iterations for the 15 | #' constrained asreml model 16 | #' 17 | #' @return A \code{vector} of length 1 returning either a \code{numeric} value 18 | #' corresponding to the likelihood ratio test statistic or else the missing 19 | #' value indicator \code{NA}. 20 | #' @author \email{matthewwolak@@gmail.com} 21 | #' @seealso See also \code{\link{LRTest}} 22 | #' @export 23 | constrainFun <- function(parameter.val, full, fm2, comp, G, mit = 600){ 24 | row <- which(fm2$Gamma == comp) 25 | fm2[row, 2:3] <- c(parameter.val, "F") 26 | if(G) full$G.param <- fm2 else full$R.param <- fm2 27 | con.mod <- asreml::update.asreml(object = full, maxiter = mit, trace = FALSE) 28 | cnt <- 0 29 | while(!con.mod$converge & cnt <= 5){ 30 | con.mod <- asreml::update.asreml(con.mod) 31 | cnt <- cnt + 1 32 | } 33 | cnt <- 0 34 | if(con.mod$converge){ 35 | pcc.out <- pcc(con.mod, silent = TRUE) 36 | while(!pcc.out & cnt <= 5){ 37 | con.mod <- asreml::update.asreml(con.mod, maxiter = mit) 38 | if(con.mod$converge) pcc.out <- pcc(con.mod, silent = TRUE) 39 | cnt <- cnt + 1 40 | } 41 | con.mod$converge <- pcc.out 42 | } 43 | if(con.mod$converge) return(LRTest(full$loglik, con.mod$loglik)$lambda) else return(NA) 44 | } 45 | 46 | -------------------------------------------------------------------------------- /man/pin-deprecated.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/remlSupport.R 3 | \name{pin-deprecated} 4 | \alias{pin-deprecated} 5 | \title{Approximate standard errors for linear functions of variance components} 6 | \usage{ 7 | pin(object, transform) 8 | } 9 | \arguments{ 10 | \item{object}{A list with at least the following elements: \code{gammas}, 11 | \code{gammas.type}, and \code{ai} from a REML mixed model} 12 | 13 | \item{transform}{A formula specifying the linear transformation of variance 14 | components to conduct} 15 | } 16 | \value{ 17 | A \code{data.frame} with row names corresponding to the operator on 18 | the left hand side of the \code{transform} formula and the entries 19 | corresponding to the \code{Estimate} and approximate \code{SE} of the 20 | linear transformation. 21 | } 22 | \description{ 23 | This function is Deprecated and will be removed in a future version. The pin 24 | function works with an asreml-R version 3 model object. Since ASReml has 25 | updated to version 4, they have changed their model output. ASReml has also 26 | provided their own \code{vpredict} function that does (for asreml v4 model 27 | objects) what \code{pin} did for asreml v3 model objects. 28 | } 29 | \details{ 30 | This function is similar to the pin calculations performed by the standalone 31 | ASReml. This function, written by Ian White, applies the delta method for 32 | the estimation of approximate standard errors on linear functions of 33 | variance components from a REML mixed model 34 | 35 | Object is intended to be an asreml-R model output. 36 | 37 | The formula can use \code{V1,..., Vn} to specify any one of the \code{n} 38 | variance components. These should be in the same order as they are in the 39 | object (e.g., see the row order of \code{summary(object)$varcomp} for 40 | asreml-R models. 41 | } 42 | \seealso{ 43 | See Also \code{\link{nadiv-deprecated}}, \code{\link{aiCI}}, 44 | \code{\link{aiFun}} 45 | } 46 | \author{ 47 | Ian White 48 | } 49 | \keyword{internal} 50 | -------------------------------------------------------------------------------- /man/numPed.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/numPed.R 3 | \name{numPed} 4 | \alias{numPed} 5 | \alias{ronPed} 6 | \title{Integer Format Pedigree} 7 | \usage{ 8 | numPed(pedigree, check = TRUE) 9 | 10 | ronPed(x, i, ...) 11 | } 12 | \arguments{ 13 | \item{pedigree}{A three column pedigree object, where the columns correspond 14 | to: ID, Dam, & Sire} 15 | 16 | \item{check}{A logical argument indicating if checks on the validity of the 17 | pedigree structure should be made, but see Details} 18 | 19 | \item{x}{A pedigree of class \sQuote{\code{numPed}}} 20 | 21 | \item{i, \dots}{Index specifying elements to extract or replace: see 22 | \code{\link[base]{[}}} 23 | } 24 | \value{ 25 | An S3 object of class \dQuote{numPed} representing the pedigree, 26 | where individuals are now numbered from 1 to \code{n} and unknown parents 27 | are assigned a value of \sQuote{-998}. 28 | } 29 | \description{ 30 | Conversion, checking, and row re-ordering of a pedigree in integer form of 31 | class \sQuote{numPed}. 32 | } 33 | \details{ 34 | Missing parents (e.g., base population) should be denoted by either 'NA', 35 | '0', '-998', or '*'. 36 | 37 | Individuals must appear in the ID column in rows preceding where they 38 | appear in either the Dam or Sire column. See the 39 | \code{\link[nadiv]{prepPed}} function if this is not the case. 40 | 41 | If pedigree inherits the class "numPed" (from a previous call to 42 | \code{numPed()}) and \code{check = TRUE}, the checks are skipped. If 43 | \code{check = FALSE} any pedigree will be transformed into a pedigree 44 | consisting of integers and missing values denoted by '-998'. 45 | 46 | Based on code from the \code{MCMCglmm} package 47 | } 48 | \examples{ 49 | 50 | (nPed <- numPed(Mrode2)) 51 | class(nPed) 52 | 53 | # re-order and retain class 'numPed' 54 | ronPed(nPed, order(nPed[, 2], nPed[, 3])) 55 | class(nPed) 56 | 57 | } 58 | \seealso{ 59 | \code{\link[nadiv]{prepPed}}, \code{\link[MCMCglmm]{MCMCglmm}}, 60 | \code{\link[base]{[}} 61 | } 62 | \author{ 63 | \email{matthewwolak@gmail.com} 64 | } 65 | -------------------------------------------------------------------------------- /R/drfx.R: -------------------------------------------------------------------------------- 1 | #' Simulated design random effects 2 | #' 3 | #' This function simulates effects for random terms in a linear mixed model 4 | #' based on design matrices. The intended purpose is for simulating 5 | #' environmental effects from a pedigree. 6 | #' 7 | #' If G = x, where 'x' is a single number, then 'x' should still be specified 8 | #' as a 1-by-1 matrix (e.g., \code{matrix(x)}). Note, the G-matrix should 9 | #' never have a structure which produces a correlation exactly equal to 1 or 10 | #' -1. Instead, covariances should be specified so as to create a correlation 11 | #' of slightly less than (greater than) 1 (-1). For example: 0.9999 or 12 | #' -0.9999. 13 | #' 14 | #' @param G The variance-covariance matrix to model the effects after 15 | #' @param fac A character indicating the factor in \code{dataf} with which to 16 | #' construct the design matrix 17 | #' @param dataf A dataframe with \code{fac} in it 18 | #' @param ... Arguments to be passed to the internal use of \code{\link{grfx}} 19 | #' 20 | #' @return \item{fx }{A matrix with 'd' columns of random effects} \item{Z }{A 21 | #' design matrix (of the format 'Matrix') from which the random effects in 22 | #' \code{fx} were assigned } 23 | #' @author \email{matthewwolak@@gmail.com} 24 | #' @seealso \code{\link{grfx}} 25 | #' @examples 26 | #' 27 | #' # Create maternal common environment effects for 2 traits 28 | #' # with perfectly correlated effects 29 | #' Gmat <- matrix(c(10, 7.071, 7.071, 5), 2, 2) 30 | #' cfx <- drfx(G = Gmat, fac = "Dam", dataf = warcolak[1:200, ]) 31 | #' 32 | #' 33 | #' @export 34 | drfx <- function(G, fac, dataf, ...){ 35 | dataf[, fac] <- as.factor(dataf[, fac]) 36 | d <- nrow(G) 37 | if(all(G == G[1,1]) & d > 1){ 38 | warning("variance-covariance matrix 'G' may have caused 'chol.default(G)' error. If so, consider subtracting 0.0001 from the covariances to make correlations < 1 or >-1") 39 | } 40 | Z <- sparse.model.matrix(as.formula(paste0("~", fac, " - 1")), dataf) 41 | M <- grfx(n = ncol(Z), G = G, incidence = Diagonal(ncol(Z)), ...) 42 | fx <- sapply(seq.int(d), FUN = function(c){ (Z %*% M[, c])@x}) 43 | return(list(fx = fx, Z = Z)) 44 | } 45 | 46 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | # Resubmission 2 | - This resubmission addresses the comment/request from Uwe Ligges on 22 May 2024 noting that in the inst/CITATION file angle brackets are not needed in the "url" field. 3 | - Accordingly, a change was made which is the only change since the original submission 4 | 5 | # Test environments 6 | - Ubuntu 20.04.6 LTS 7 | - R version 4.4.0 (2024-04-24 r86474) x86_64-pc-linux-gnu 8 | 9 | - [win-builder](https://win-builder.r-project.org/) 10 | - R version 4.3.3 (2024-02-29 ucrt) x86_64-w64-mingw32 (64-bit) 11 | - R Under development (unstable) (2024-05-16 r86559 ucrt) x86_64-w64-mingw32 12 | - R version 4.4.0 (2024-04-24 ucrt) x86_64-w64-mingw32 13 | 14 | # R CMD check results 15 | There were no ERRORs or WARNINGs. 16 | 17 | - There were 2 NOTEs when checking `nadiv`: 18 | 19 | - checking CRAN incoming feasibility ... [18s] NOTE 20 | - Maintainer: 'Matthew Wolak ' 21 | - New submission 22 | - Package was archived on CRAN 23 | - CRAN repository db overrides: X-CRAN-Comment: Archived on 2023-12-06 as issues were not corrected in time. 24 | - Suggests or Enhances not in mainstream repositories: 25 | asreml 26 | - checking package dependencies ... NOTE 27 | - Package which this enhances but not available for checking: 'asreml' 28 | 29 | - No public repository is available for package 'asreml', however, availability (with web address) is noted in DESCRIPTION. 30 | 31 | - All ERRORs, WARNINGs, and NOTEs from the archived version under CRAN Package Check Results have been addressed with this update. All further correspondence with CRAN personnel regarding changes required after a code review have been addressed with this update. 32 | 33 | 34 | # Downstream dependencies 35 | I have also run R CMD check (`tools::check_packages_in_dir(..., Ncpus = 2, check_args = c("--as-cran", ""), reverse = NULL, clean = FALSE)`) on the reverse dependencies and imports of nadiv: 36 | 37 | - the latest versions archived on CRAN that depend on `nadiv` are `dmm` (2.1-8), `optiSel` (2.0.7) 38 | 39 | Both packages installed and passed all checks. 40 | 41 | 42 | -------------------------------------------------------------------------------- /R/aiCI.R: -------------------------------------------------------------------------------- 1 | #' Confidence Intervals for Variance Components 2 | #' 3 | #' Produces the 1-alpha Upper and Lower Confidence Limits for the variance 4 | #' components in an ASReml-R model. 5 | #' 6 | #' Variances from the inverse of the Average Information matrix of an ASReml 7 | #' model are translated according to the \code{\link{varTrans}} function and 8 | #' used in constructing the 1-alpha Confidence Interval. 9 | #' 10 | #' @param asr.model Object from a call to \code{asreml} 11 | #' @param Dimnames A vector of characters if names are desired for the output. 12 | #' If not specified, the default labels from the \code{asreml} object will be 13 | #' used. 14 | #' @param alpha A numeric value indicating the level of Type I error for 15 | #' constructing the Confidence Intervals. 16 | #' 17 | #' @return A \code{matrix} is returned with a row for each variance component. 18 | #' The three columns correspond to the Lower Confidence Limit, estimate from 19 | #' the \code{asreml} model, and Upper Confidence Limit for each variance 20 | #' component. 21 | #' @note The vector of \code{Dimnames} should match the same order of variance 22 | #' components specified in the model. 23 | #' @author \email{matthewwolak@@gmail.com} 24 | #' @seealso \code{\link{aiFun}} 25 | #' @examples 26 | #' 27 | #' \dontrun{ 28 | #' library(asreml) 29 | #' ginvA <- ainverse(warcolak) 30 | #' ginvD <- makeD(warcolak[, 1:3])$listDinv 31 | #' attr(ginvD, "rowNames") <- as.character(warcolak[, 1]) 32 | #' attr(ginvD, "INVERSE") <- TRUE 33 | #' warcolak$IDD <- warcolak$ID 34 | #' warcolak.mod <- asreml(trait1 ~ sex, 35 | #' random = ~ vm(ID, ginvA) + vm(IDD, ginvD), 36 | #' data = warcolak) 37 | #' summary(warcolak.mod)$varcomp 38 | #' aiCI(warcolak.mod) 39 | #' } 40 | #' 41 | #' @export 42 | aiCI <- function(asr.model, Dimnames = NULL, alpha = 0.05) 43 | { 44 | za2 <- qnorm(alpha/2, mean = 0, sd = 1) 45 | hii.vec <- varTrans(asr.model) 46 | theta.vec <- asr.model$gammas * asr.model$sigma2 47 | UCL <- theta.vec - za2*sqrt(hii.vec) 48 | LCL <- theta.vec + za2*sqrt(hii.vec) 49 | CIframe <- cbind(LCL, theta.vec, UCL) 50 | if(!is.null(Dimnames)) dimnames(CIframe)[[1]] <- Dimnames 51 | dimnames(CIframe)[[2]] <- c("LCL", "estimate", "UCL") 52 | return(CIframe) 53 | } 54 | 55 | -------------------------------------------------------------------------------- /src/Trow.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void Trow( 6 | int *dam, 7 | int *sire, 8 | double *x, 9 | int *i, 10 | int *p, 11 | int *n 12 | 13 | ){ 14 | 15 | int ncol, n0, nend, c, pc, cnt, cdam, csire, r, cnt2, used, o; 16 | ncol = n[0]; 17 | n0 = n[1]; 18 | nend = n[2]; 19 | 20 | for(c = n0; c < nend; c++){ 21 | pc = p[c]; 22 | cdam = dam[c]; 23 | csire = sire[c]; 24 | cnt = 0; 25 | if(dam[c-1] == cdam && sire[c-1] == csire){ 26 | // don't include diagonal if c-1 has a 1.0 there (stop before cnt2) 27 | if(c-1 < ncol) cnt2 = pc - 1; else cnt2 = pc; 28 | for(r = p[c-1]; r < cnt2; r++){ 29 | i[pc + cnt] = i[r]; 30 | x[pc + cnt] += x[r]; 31 | cnt++; 32 | } // end for r 33 | cnt2 = 0; // reset 34 | } else{ 35 | 36 | cnt = 0; 37 | if(cdam != -999){ 38 | for(r = p[cdam]; r < p[cdam + 1]; r++){ 39 | i[pc + cnt] = i[r]; 40 | x[pc + cnt] += 0.5 * x[r]; 41 | cnt++; 42 | } 43 | } 44 | 45 | cnt2 = 0; 46 | if(csire != -999){ 47 | for(r = p[csire]; r < p[csire + 1]; r++){ 48 | // see if this row has been used (i.e., dam had non-zero ancestry too) 49 | used = 0; 50 | for(o = 0; o < cnt; o++){ 51 | if(i[pc + o] == i[r]){ 52 | used++; 53 | x[pc + o] += 0.5 * x[r]; 54 | break; 55 | } // end if 56 | } // end for o 57 | if(used == 0){ 58 | i[pc + cnt + cnt2] = i[r]; 59 | x[pc + cnt + cnt2] += 0.5 * x[r]; 60 | cnt2++; 61 | } // end if 62 | } // end for r 63 | } // end if csire 64 | } // end if/else same dam and sire as previous c 65 | 66 | // if diagonal of entire T is in subset, add a 1 to location of the diagonal 67 | if(c < ncol){ 68 | i[pc + cnt + cnt2] = c; 69 | x[pc + cnt + cnt2] += 1.0; 70 | p[c + 1] = pc + cnt + cnt2 + 1; 71 | } else{ 72 | // otherwise "c" individual does not get a 1 on the diagonal 73 | //// diagonal is not part of Trow subset 74 | p[c + 1] = pc + cnt + cnt2; 75 | } // end if/else 76 | } // end for c 77 | 78 | } 79 | } 80 | 81 | -------------------------------------------------------------------------------- /man/findDFC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/findDFC.R 3 | \name{findDFC} 4 | \alias{findDFC} 5 | \title{Finds the double first cousins in a pedigree} 6 | \usage{ 7 | findDFC( 8 | pedigree, 9 | exact = FALSE, 10 | parallel = FALSE, 11 | ncores = getOption("mc.cores", 2L) 12 | ) 13 | } 14 | \arguments{ 15 | \item{pedigree}{A pedigree with columns organized: ID, Dam, Sire} 16 | 17 | \item{exact}{A logical statement indicating if individuals who are exactly 18 | double first cousins are to be identified} 19 | 20 | \item{parallel}{A logical statement indicating if parallelization should be 21 | attempted. Note, only reliable for Mac and Linux operating systems.} 22 | 23 | \item{ncores}{Number of cpus to use, default is maximum available} 24 | } 25 | \value{ 26 | a \code{list}: 27 | \describe{ 28 | \item{PedPositionList }{gives the list of row numbers for all the 29 | pairs of individuals that are related as double first cousins.} 30 | \item{DFC }{gives the list of IDs, as characters, for all the pairs of 31 | individuals that are related as double first cousins.} 32 | \item{FamilyCnt }{If two individuals, i and j, are double first cousins, 33 | then i's siblings will also be double first cousins with j's siblings. 34 | Therefore, this is the total number of family pairs where offspring 35 | are related as double first cousins.} 36 | } 37 | } 38 | \description{ 39 | Given a pedigree, all pairs of individuals that are double first cousins are 40 | returned. 41 | } 42 | \details{ 43 | When exact = TRUE, only those individuals whose grandparents are completely 44 | unrelated will be identified as double first cousins. When exact = FALSE, 45 | as long as the parents of individuals i and j are two sets of siblings 46 | (i.e., either sires full brothers/dams full sisters or two pairs of opposite 47 | sex full sibs) then i and j will be considered double first cousins. In the 48 | event where the grandparents of i and j are also related, exact = FALSE will 49 | still consider i and j full sibs, even though genetically they will be more 50 | related than exact = TRUE double first cousins. 51 | 52 | \code{parallel} = TRUE should only be used on Linux or Mac OSes (i.e., not 53 | Windows). 54 | } 55 | \author{ 56 | \email{matthewwolak@gmail.com} 57 | } 58 | -------------------------------------------------------------------------------- /R/genAssign.R: -------------------------------------------------------------------------------- 1 | # Generic 2 | 3 | 4 | #' Generation assignment 5 | #' 6 | #' Given a pedigree, the function assigns the generation number to which each 7 | #' individual belongs. 8 | #' 9 | #' 0 is the base population. 10 | #' 11 | #' Migrants, or any individuals where both parents are unknown, are assigned to 12 | #' generation zero. If parents of an individual are from two different 13 | #' generations (e.g., dam = 0 and sire = 1), the individual is assigned to the 14 | #' generation following the greater of the two parents (e.g., 2 in this 15 | #' example). 16 | #' 17 | #' @aliases genAssign genAssign.default genAssign.numPed 18 | #' @param pedigree A pedigree where the columns are ordered ID, Dam, Sire 19 | #' @param \dots Arguments to be passed to methods 20 | #' 21 | #' @return A vector of values is returned. This vector is in the same order as 22 | #' the ID column of the pedigree. 23 | #' @author \email{matthewwolak@@gmail.com} 24 | #' @export 25 | genAssign <- function(pedigree, ...){ 26 | UseMethod("genAssign", pedigree) 27 | } 28 | 29 | ############################################################################### 30 | # Methods: 31 | #' @rdname genAssign 32 | #' @method genAssign default 33 | #' @export 34 | genAssign.default <- function(pedigree, ...) 35 | { 36 | n <- nrow(pedigree) 37 | numbCols <- which(apply(pedigree[, 1:3], MARGIN = 2, FUN = is.integer) | 38 | apply(pedigree[, 1:3], MARGIN = 2, FUN = is.numeric)) 39 | if(length(numbCols) > 0 && any(apply(pedigree[, numbCols], MARGIN = 2, FUN = function(x){min(x, na.rm = TRUE) < 0}))){ 40 | warning("Negative values in pedigree interpreted as missing values") 41 | pedigree[pedigree < 0] <- -998 42 | } 43 | if(!all(apply(pedigree[, 1:3], MARGIN = 2, FUN = is.numeric)) | any(apply(pedigree[, 1:3], MARGIN = 2, FUN = is.na))){ 44 | pedigree[, 1:3] <- numPed(pedigree[, 1:3]) 45 | } 46 | 47 | Cout <- .C("ga", PACKAGE = "nadiv", 48 | as.integer(pedigree[, 2] - 1), 49 | as.integer(pedigree[, 3] - 1), 50 | vector("integer", length = n), 51 | as.integer(n)) 52 | Cout[[3]] 53 | } 54 | 55 | ###################################### 56 | 57 | #' @rdname genAssign 58 | #' @method genAssign numPed 59 | #' @export 60 | genAssign.numPed <- function(pedigree, ...) 61 | { 62 | n <- nrow(pedigree) 63 | Cout <- .C("ga", PACKAGE = "nadiv", 64 | as.integer(pedigree[, 2] - 1), 65 | as.integer(pedigree[, 3] - 1), 66 | vector("integer", length = n), 67 | as.integer(n)) 68 | Cout[[3]] 69 | } 70 | 71 | -------------------------------------------------------------------------------- /src/ga.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void ga( 6 | int *dam, 7 | int *sire, 8 | int *generation, 9 | int *n 10 | ){ 11 | 12 | int k, kdam, ksire, nmiss, cnt; 13 | 14 | nmiss = 1; // initialize so starts while 15 | cnt = 0; 16 | while((nmiss > 0) && (cnt < n[0])){ 17 | nmiss = 0; // set fresh each time through 18 | for(k = 0; k < n[0]; k++){ 19 | kdam = dam[k]; 20 | ksire = sire[k]; 21 | if((kdam != -999) && (ksire != -999)){ 22 | if((generation[kdam] != -1) && (generation[ksire] != -1)){ 23 | generation[k] = max(generation[kdam], generation[ksire]) + 1; 24 | } else nmiss++; 25 | } 26 | else{ 27 | if((kdam != -999)){ 28 | if((generation[kdam] != -1)){ 29 | generation[k] = generation[kdam] + 1; 30 | } else nmiss++; 31 | } 32 | if((ksire != -999)){ 33 | if((generation[ksire] != -1)){ 34 | generation[k] = generation[ksire] + 1; 35 | } else nmiss++; 36 | } 37 | } // end if/else 38 | } // end for k 39 | cnt++; 40 | //Rprintf("\nnmiss=%i cnt=%i", nmiss, cnt); 41 | } // end while 42 | 43 | } 44 | } 45 | 46 | 47 | ////////////////////////////////////// 48 | 49 | extern "C"{ 50 | 51 | void gaUnsort( 52 | int *dam, 53 | int *sire, 54 | int *dgen, 55 | int *sgen, 56 | int *n 57 | ){ 58 | 59 | int en, k, dk, sk; 60 | 61 | en = n[0]; // initialize flag value for infinite loops 62 | for(k = 0; k < n[0]; k++){ 63 | dk = k; 64 | sk = k; 65 | while(dam[dk] != -999){ 66 | dk = dam[dk]; 67 | dgen[k] += 1; 68 | if(dgen[k] > n[0]){ // catch any infinite loops 69 | en = k; // stick ID involved in ped loop into this spot to return to R 70 | dgen[0] = -999; // flag that ped loop occurred through dam ancestors 71 | break; // end while early 72 | } 73 | } 74 | if(en < n[0]) break; // should end for loop early 75 | 76 | while(sire[sk] != -999){ 77 | sk = sire[sk]; 78 | sgen[k] += 1; 79 | if(sgen[k] > n[0]){ // catch any infinite loops 80 | en = k; // stick ID involved in ped loop into this spot to return to R 81 | sgen[0] = -999; // flag that ped loop occurred through sire ancestors 82 | break; // end while early 83 | } 84 | } 85 | if(en < n[0]) break; // should end for loop early 86 | 87 | } // end for k 88 | 89 | n[0] = en; 90 | 91 | } 92 | } 93 | -------------------------------------------------------------------------------- /man/geneDrop.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/geneDrop.R 3 | \name{geneDrop} 4 | \alias{geneDrop} 5 | \alias{geneDrop.default} 6 | \alias{geneDrop.numPed} 7 | \title{Functions to conduct gene dropping through a pedigree} 8 | \usage{ 9 | geneDrop( 10 | pedigree, 11 | N, 12 | parallel = FALSE, 13 | ncores = getOption("mc.cores", 2L), 14 | ... 15 | ) 16 | 17 | \method{geneDrop}{default}( 18 | pedigree, 19 | N, 20 | parallel = FALSE, 21 | ncores = getOption("mc.cores", 2L), 22 | ... 23 | ) 24 | 25 | \method{geneDrop}{numPed}( 26 | pedigree, 27 | N, 28 | parallel = FALSE, 29 | ncores = getOption("mc.cores", 2L), 30 | ... 31 | ) 32 | } 33 | \arguments{ 34 | \item{pedigree}{A pedigree with columns organized: ID, Dam, Sire.} 35 | 36 | \item{N}{The number of times to iteratively trace alleles through the 37 | pedigree} 38 | 39 | \item{parallel}{A logical indicating whether or not to use parallel 40 | processing. Note, this may only be available for Mac and Linux operating 41 | systems.} 42 | 43 | \item{ncores}{The number of cpus to use when constructing the dominance 44 | relatedness matrix. Default is all available.} 45 | 46 | \item{\dots}{Other arguments that can be supplied to alter what summaries are 47 | reported.} 48 | } 49 | \value{ 50 | a \code{list}: 51 | \describe{ 52 | \item{IDs }{Original identities in the pedigree} 53 | \item{maternal }{Simulated maternal haplotypes} 54 | \item{paternal }{Simulated paternal haplotypes} 55 | \item{numericPedigree }{Pedigree in class \code{numPed} for convenient 56 | post-processing of haplotypes} 57 | } 58 | } 59 | \description{ 60 | Functions that perform and summarize gene dropping conducted on supplied pedigrees 61 | } 62 | \details{ 63 | Missing parents (e.g., base population) should be denoted by either 'NA', '0' 64 | , or '*'. 65 | 66 | \code{parallel} = TRUE should only be used on Linux or Mac operating systems 67 | (i.e., not Windows). 68 | 69 | Founder allelic values (the alleles assigned to an individual's maternal, 70 | paternal, or both haplotypes when the maternal, paternal, or both parents are 71 | missing) are equivalent positive and negative integer values corresponding to 72 | the maternal and paternal haplotypes, respectively. For example, if the first 73 | individual in the pedigree has two unknown parents it will have the following 74 | two allelic values: 1=maternal haplotype and -1=paternal haplotype. 75 | } 76 | \examples{ 77 | geneDrop(Mrode2, N = 10) 78 | 79 | } 80 | \seealso{ 81 | \code{\link{makeDsim}} 82 | } 83 | \author{ 84 | \email{matthewwolak@gmail.com} 85 | } 86 | -------------------------------------------------------------------------------- /man/pcc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/remlSupport.R 3 | \name{pcc} 4 | \alias{pcc} 5 | \title{REML convergence checks} 6 | \usage{ 7 | pcc(object, traces = NULL, tol = 0.01, silent = FALSE) 8 | } 9 | \arguments{ 10 | \item{object}{A list with at least one element named: \code{monitor} (see 11 | Details)} 12 | 13 | \item{traces}{Optionally, a matrix to substitute instead of the monitor 14 | element to \code{object}. Each row corresponds to a different variance 15 | component in the model and each column is a different iteration of the 16 | likelihood calculation (column 1 is the first iterate).} 17 | 18 | \item{tol}{The tolerance level for which to check against all of the changes 19 | in variance component parameter estimates} 20 | 21 | \item{silent}{Optional argument to silence the output of helpful (indicating 22 | default underlying behavior) messages} 23 | } 24 | \value{ 25 | Returns \code{TRUE} if all variance parameters change less than the 26 | value specified by \code{tol}, otherwise returns \code{FALSE}. Also see the 27 | \code{details} section for other circumstances when \code{FALSE} might be 28 | returned. 29 | } 30 | \description{ 31 | Mainly checks to ensure the variance components in a REML mixed model do not 32 | change between the last two iterations more than what is allowed by the 33 | tolerance value. See details for extra check on asreml-R models. 34 | } 35 | \details{ 36 | Object is intended to be an asreml-R model output. NOTE, The first 3 rows 37 | are ignored and thus should not be variance components from the model (e.g., 38 | they should be the loglikelihood or degrees of freedom, etc.). Also, the 39 | last column is ignored and should not be an iteration of the model (e.g., it 40 | indicates the constraint). 41 | 42 | The function also checks \code{object} to ensure that the output from the 43 | asreml-R model does not contain a log-likelihood value of exactly 0.00. An 44 | ASReml model can sometimes fail while still returning a \code{monitor} 45 | object and \code{TRUE} value in the \code{converge} element of the output. 46 | This function will return \code{FALSE} if this is the case. 47 | } 48 | \examples{ 49 | 50 | # Below is the last 3 iterations from the trace from an animal model of 51 | # tait1 of the warcolak dataset. 52 | # Re-create the output from a basic, univariate animal model in asreml-R 53 | tracein <- matrix(c(0.6387006, 1, 0.6383099, 1, 0.6383294, 1, 0.6383285, 1), 54 | nrow = 2, ncol = 4, byrow = FALSE) 55 | dimnames(tracein) <- list(c("ped(ID)!ped", "R!variance"), c(6, 7, 8, 9)) 56 | 57 | pcc(object = NULL, trace = tracein) 58 | 59 | 60 | } 61 | \author{ 62 | \email{matthewwolak@gmail.com} 63 | } 64 | -------------------------------------------------------------------------------- /man/founderLine.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/founderLine.R 3 | \name{founderLine} 4 | \alias{founderLine} 5 | \title{Identifies the matriline or patriline to which each individual in a pedigree 6 | belongs} 7 | \usage{ 8 | founderLine(pedigree, sex) 9 | } 10 | \arguments{ 11 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire, Sex} 12 | 13 | \item{sex}{Character indicating the column name in pedigree identifying 14 | either the dam (for matriline) or sire (for patriline) identities} 15 | } 16 | \value{ 17 | A vector of length equal to the number of rows in the pedigree 18 | } 19 | \description{ 20 | For every individual in a pedigree, the function identifies either the one 21 | female or male ancestor that is a founder (defined here as an individual 22 | identity in the pedigree for which both dam and sire information are 23 | missing). 24 | } 25 | \details{ 26 | Missing parents (e.g., base population) should be denoted by either 'NA', 27 | '0', or '*'. 28 | 29 | Individuals with a missing parent for the column identified by the 'sex' 30 | argument are assigned themselves as their founder line. Thus, the definition 31 | of the founder population from a given pedigree is simply all individuals 32 | with missing parents (and in this case just a single missing parent 33 | classifies an individual as a founder). 34 | } 35 | \examples{ 36 | 37 | founderLine(FG90, sex = "dam") # matriline from this example pedigree 38 | 39 | #Create random pedigree, tracking the matrilines 40 | ## Then compare with founderLine() output 41 | K <- 8 # No. individuals per generation (KEEP and even number) 42 | gen <- 10 # No. of generations 43 | datArr <- array(NA, dim = c(K, 5, gen)) 44 | dimnames(datArr) <- list(NULL, 45 | c("id", "dam", "sire", "sex", "matriline"), NULL) 46 | # initialize the data array 47 | datArr[, "id", ] <- seq(K*gen) 48 | datArr[, "sex", ] <- c(1, 2) 49 | femRow <- which(datArr[, "sex", 1] == 2) # assume this is same each generation 50 | # (Why K should always be an even number) 51 | datArr[femRow, "matriline", 1] <- femRow 52 | # males have overlapping generations, BUT females DO NOT 53 | for(g in 2:gen){ 54 | datArr[, "sire", g] <- sample(c(datArr[femRow-1, "id", 1:(g-1)]), 55 | size = K, replace = TRUE) 56 | gdams <- sample(femRow, size = K, replace = TRUE) 57 | datArr[, c("dam", "matriline"), g] <- datArr[gdams, c("id", "matriline"), g-1] 58 | } 59 | ped <- data.frame(apply(datArr, MARGIN = 2, FUN = function(x){x})) 60 | nrow(ped) 61 | #Now run founderLine() and compare 62 | ped$line <- founderLine(ped, sex = "dam") 63 | stopifnot(identical(ped$matriline, ped$line), 64 | sum(ped$matriline-ped$line, na.rm = TRUE) == 0, 65 | range(ped$matriline-ped$line, na.rm = TRUE) == 0) 66 | 67 | 68 | } 69 | \author{ 70 | \email{matthewwolak@gmail.com} 71 | } 72 | -------------------------------------------------------------------------------- /src/sdsim.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void sdsim(int *da, // N dam alleles 6 | int *sa, // N sire alleles 7 | int *eN, // N (number of replications) 8 | int *en, // n pedigree size 9 | int *dam, // dam number IDs 10 | int *sire, // sire number IDs 11 | int *sex, // sex or really number of homogametic sex chromosomes 12 | int *Sdi, // i slot of sex-chromosome dominance relatedness matrix 13 | int *Sdp, // p slot of matrix 14 | int *sdij // x slot of matrix 15 | ){ 16 | 17 | int i, j, k, l, m, n, r; 18 | int mi, si, adij, cdama, csirea, rdama, rsirea; 19 | int p = 0; 20 | int c = 0; 21 | GetRNGstate(); 22 | 23 | for(i = 0; i < en[0]; i++){ 24 | mi = dam[i]; 25 | si = sire[i]; 26 | if(mi != -999){ 27 | k = i*eN[0]; 28 | l = mi*eN[0]; 29 | for(j = 0; j < eN[0]; j++){ 30 | if(runif(0.0, 2.0) > 1.0){ 31 | da[k] += da[l]; 32 | } 33 | else { 34 | da[k] += sa[l]; 35 | } 36 | k++; 37 | l++; 38 | } // end for j 39 | } 40 | 41 | if(sex[i] == 1){ 42 | if(si != -999){ 43 | k = i*eN[0]; 44 | l = si*eN[0]; 45 | for(j = 0; j < eN[0]; j++){ 46 | sa[k] += da[l]; 47 | k++; 48 | l++; 49 | } // end for j 50 | } 51 | } // end if sex for sire alleles of females (XX)/homogametic sex 52 | } // end for i 53 | PutRNGstate(); 54 | 55 | 56 | // ************* // 57 | for(m = 0; m < en[0]; m++){ 58 | if(sex[m] == 1){ 59 | Sdp[c] += p; 60 | c++; 61 | r = 0; // Need a row number of just sex==1 62 | for(n = 0; n < m+1; n++){ 63 | if(sex[n] == 1){ 64 | adij = 0; 65 | k = m*eN[0]; 66 | l = n*eN[0]; 67 | for(j = 0; j < eN[0]; j++){ 68 | cdama = da[k]; // 'column' individual's dam allele 69 | csirea = sa[k]; 70 | rdama = da[l]; // 'row' individual's dam allele 71 | rsirea = sa[l]; 72 | 73 | if(cdama == rdama){ 74 | if(csirea == rsirea){ 75 | adij += 1; 76 | } 77 | } 78 | else{ 79 | if(cdama == rsirea){ 80 | if(csirea == rdama){ 81 | adij += 1; 82 | } 83 | } 84 | } // end else 85 | 86 | k++; 87 | l++; 88 | } // end for j 89 | 90 | 91 | 92 | if(adij > 0){ 93 | Sdi[p] += r; 94 | sdij[p] += adij; 95 | p++; 96 | } // end if adij > 0 97 | r++; 98 | } // end if sex[n]==1 99 | } // end for n 100 | } // end if sex[m]==1 101 | } // end for m 102 | Sdp[c] += p; 103 | } 104 | } 105 | -------------------------------------------------------------------------------- /man/prunePed.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prunePed.R 3 | \name{prunePed} 4 | \alias{prunePed} 5 | \alias{prunePed.default} 6 | \alias{prunePed.numPed} 7 | \title{Prunes a pedigree based on individuals with phenotypes} 8 | \usage{ 9 | prunePed(pedigree, phenotyped, ...) 10 | 11 | \method{prunePed}{default}(pedigree, phenotyped, ...) 12 | 13 | \method{prunePed}{numPed}(pedigree, phenotyped, ...) 14 | } 15 | \arguments{ 16 | \item{pedigree}{An object, where the first 3 columns correspond to: ID, Dam, 17 | & Sire. See details.} 18 | 19 | \item{phenotyped}{A vector indicating which individuals in the pedigree have 20 | phenotypic information available.} 21 | 22 | \item{\dots}{Arguments to be passed to methods} 23 | } 24 | \value{ 25 | The pedigree object (can have more columns than just ID, Dam, and 26 | Sire), where the ID column contains an ID for all individuals who are 27 | actually phenotyped or are an ancestor to an individual with a phenotype 28 | (and are thus informative for estimating parameters in the base 29 | population). 30 | } 31 | \description{ 32 | This function removes individuals who are either not themselves or not 33 | ancestors to phenotyped individuals 34 | } 35 | \details{ 36 | Often mixed effect models run much faster when extraneous information is 37 | removed before running the model. This is particularly so when reducing the 38 | number of random effects associated with a relationship matrix constructed 39 | from a pedigree. 40 | 41 | NOTE: more columns than just a pedigree can be passed in the \code{pedigree} 42 | argument. 43 | 44 | Missing parents (e.g., base population) should be denoted by either 'NA', 45 | '0', or '*'. 46 | 47 | This function is very similar to (and the code is heavily borrowed from) a 48 | function of the same name in the \code{MCMCglmm} package by Jarrod Hadfield. 49 | } 50 | \examples{ 51 | 52 | 53 | # Make a pedigree (with sex) from the warcolak dataset 54 | warcolak_ped <- warcolak[, 1:4] 55 | 56 | # Reduce the number of individuals that have a phenotype for "trait1" in 57 | #the warcolak dataset 58 | t1phenotyped <- warcolak 59 | t1phenotyped[sample(seq.int(nrow(warcolak)), 1500, replace = FALSE), "trait1"] <- NA 60 | t1phenotyped <- t1phenotyped[which(!is.na(t1phenotyped$trait1)), ] 61 | 62 | # The following will give a pedigree with only individuals that have a 63 | # phenotype for "trait1" OR are an ancestor to a phenotyped individual. 64 | pruned_warcolak_ped <- prunePed(warcolak_ped, phenotyped = t1phenotyped$ID) 65 | 66 | # Now compare the sizes (note, pruned_warcolak_ped retained its column indicating sex. 67 | dim(warcolak_ped) 68 | dim(pruned_warcolak_ped) 69 | # We could have kept all of the data associated with individuals who had phenotypic 70 | # information on "trait1" by instead specifying 71 | pruned_fullt1_warcolak_ped <- prunePed(warcolak, phenotyped = t1phenotyped$ID) 72 | dim(pruned_fullt1_warcolak_ped) #<-- compare number of columns with above 73 | 74 | } 75 | \seealso{ 76 | \code{\link[nadiv]{prepPed}} 77 | } 78 | -------------------------------------------------------------------------------- /man/simPedMCN.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simPed.R 3 | \name{simPedMCN} 4 | \alias{simPedMCN} 5 | \title{Middle Class Neighborhood pedigree construction} 6 | \usage{ 7 | simPedMCN(pedTemp, g, Nfam = NULL, noff = 2) 8 | } 9 | \arguments{ 10 | \item{pedTemp}{A \code{data.frame} pedigree of a template pedigree from which 11 | the middle class neighborhood design should continue. If \code{NULL}, a new 12 | pedigree will be created with \code{Nfam} families.} 13 | 14 | \item{g}{Integer number of generations to produce from the middle class 15 | neighborhood design} 16 | 17 | \item{Nfam}{Integer number of families with which to start a new pedigree 18 | following the middle class neighborhood design.} 19 | 20 | \item{noff}{Integer number of full-sib offspring produced by each family 21 | (must be >=2).} 22 | } 23 | \value{ 24 | A \code{data.frame} with columns corresponding to: id, dam, sire, sex, 25 | and generation. Sex is \code{M} for males and \code{F} for females. The 26 | first generation produced in the middle class neighborhood scheme is assigned 27 | a value of \dQuote{1}, with their parents being assigned to generation 28 | \code{0}. If \code{pedTemp} was provided, the generations from this pedigree 29 | will be denoted with negative integers. 30 | } 31 | \description{ 32 | Simulates a pedigree for the \dQuote{middle class neighborhood} mating design 33 | (Shabalina, Yampolsky, and Kondrashov 1997). 34 | } 35 | \details{ 36 | This creates a pedigree following a breeding design which maintains equal 37 | contributions to the next generation by each family in the design. It 38 | effectively removes the effect of natural selection which makes it amenable 39 | to quantify the contribution of mutations to phenotypic variance over the 40 | course of the breeding design. 41 | 42 | For a starting pedigree template (\code{pedTemp}), the last generation is used 43 | as parents to begin the breeding design for the next \code{g} generations. 44 | The number of families in the last generation of the template pedigree 45 | (\code{pedTemp}) will be the number of families in each generation. 46 | 47 | Alternatively, if no template pedigree is provided (\code{pedTemp=NULL}), 48 | \code{Nfam} number of families will be produced in the first generation from 49 | \code{Nfam} unique sire and \code{Nfam} unique dams. 50 | 51 | Either \code{pedTemp} or \code{Nfam} must be \code{NULL}, but not both. 52 | } 53 | \examples{ 54 | # No template pedigree provided - start from scrtach 55 | mcn1 <- simPedMCN(pedTemp = NULL, g = 3, Nfam = 4, noff = 2) 56 | 57 | # Provide a template pedigree (half-sib design) 58 | hsped <- simPedHS(s = 2, d = 2, n = 4) 59 | mcnHS <- simPedMCN(pedTemp = hsped, g = 3) 60 | } 61 | \references{ 62 | Shabalina, S.A, L.Y. Yampolsky, and A.S. Kondrashov. 1997. Rapid 63 | decline of fitness in panmictic populations of Drosophila melanogaster 64 | maintained under relaxed natural selection. Proc. Natl. Acad. Sci. USA. 65 | 94:13034-13039. 66 | } 67 | \seealso{ 68 | \code{\link{simPedHS}}, \code{\link{simPedDFC}} 69 | } 70 | \author{ 71 | \email{matthewwolak@gmail.com} 72 | } 73 | -------------------------------------------------------------------------------- /man/LRTest.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/LRTest.R 3 | \name{LRTest} 4 | \alias{LRTest} 5 | \title{log-Likelihood Ratio Test} 6 | \usage{ 7 | LRTest(full, reduced, df = 1, boundaryCorrection = FALSE) 8 | } 9 | \arguments{ 10 | \item{full}{A numeric variable indicating the log-likelihood of the full 11 | model} 12 | 13 | \item{reduced}{A numeric variable indicating the log-likelihood of the 14 | reduced model} 15 | 16 | \item{df}{The number of degrees of freedom to use, representing the 17 | difference between the full and reduced model in the number of parameters 18 | estimated} 19 | 20 | \item{boundaryCorrection}{A logical argument indicating whether a boundary 21 | correction under one degree of freedom should be included. If the parameter 22 | that is dropped from the reduced model is estimated at the boundary of its 23 | parameter space in the full model, the boundary correction is often 24 | required. See Details for more.} 25 | } 26 | \value{ 27 | a \code{list}: 28 | \describe{ 29 | \item{lambda }{a numeric log-likelihood ratio test statistic} 30 | \item{Pval }{a numeric p-value given the \code{lambda} tested against a 31 | chi-squared distribution with the number of degrees of freedom as 32 | specified. May have had a boundary correction applied.} 33 | \item{corrected.Pval }{a logical indicating if the p-value was derived 34 | using a boundary correction. See \code{Details}} 35 | } 36 | } 37 | \description{ 38 | Test the null hypothesis that the two models fit the data equally well. 39 | } 40 | \details{ 41 | Boundary correction should be applied if the parameter that is dropped from 42 | the full model was on the boundary of its parameter space. In this instance, 43 | the distribution of the log-likelihood ratio test statistic is approximated 44 | by a mix of chi-square distributions (Self and Liang 1987). A \code{TRUE} 45 | value will implement the boundary correction for a one degree of freedom 46 | test. This is equivalent to halving the p-value from a test using a 47 | chi-square distribution with one degree of freedom (Dominicus et al. 2006). 48 | 49 | Currently, the test assumes that both log-likelihoods are negative or both 50 | are positive and will stop if they are of opposite sign. The interpretation 51 | is that the model with a greater negative log-likelihood (closer to zero) or 52 | greater positive log-likelihood provides a better fit to the data. 53 | } 54 | \examples{ 55 | 56 | # No boundary correction 57 | (noBC <- LRTest(full = -2254.148, reduced = -2258.210, 58 | df = 1, boundaryCorrection = FALSE)) 59 | # No boundary correction 60 | (withBC <- LRTest(full = -2254.148, reduced = -2258.210, 61 | df = 1, boundaryCorrection = TRUE)) 62 | stopifnot(noBC$Pval == 2*withBC$Pval) 63 | 64 | } 65 | \references{ 66 | Self, S. G., and K. Y. Liang. 1987. Asymptotic properties of 67 | maximum likelihood estimators and likelihood ratio tests under nonstandard 68 | conditions. Journal of the American Statistical Association 82:605-610. 69 | 70 | Dominicus, A., A. Skrondal, H. K. Gjessing, N. L. Pedersen, and J. Palmgren. 71 | 2006. Likelihood ratio tests in behavioral genetics: problems and solutions. 72 | Behavior Genetics 36:331-340. 73 | } 74 | \seealso{ 75 | \code{\link{constrainFun}} 76 | } 77 | \author{ 78 | \email{matthewwolak@gmail.com} 79 | } 80 | -------------------------------------------------------------------------------- /man/prepPed.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/prepPed.R 3 | \name{prepPed} 4 | \alias{prepPed} 5 | \title{Prepares a pedigree by sorting and adding 'founders'} 6 | \usage{ 7 | prepPed(pedigree, gender = NULL, check = TRUE) 8 | } 9 | \arguments{ 10 | \item{pedigree}{An object, where the first 3 columns correspond to: ID, Dam, 11 | & Sire. See details.} 12 | 13 | \item{gender}{An optional character for the name of the column in 14 | \code{pedigree} that corresponds to the gender/sex of individuals. If 15 | specified, \code{prepPed} will assign a gender to any founders it adds to 16 | the pedigree.} 17 | 18 | \item{check}{A logical argument indicating if checks on the validity of the 19 | pedigree structure should be made} 20 | } 21 | \value{ 22 | The pedigree object (can have more columns than just ID, Dam, and 23 | Sire), where: (1) the ID column contains an ID for all individuals from the 24 | original pedigree object's ID, Dam, and Sire columns (i.e., founders are 25 | added) and (2) the pedigree is now sorted so that individuals are not in 26 | rows preceding either their Dam or Sire. 27 | } 28 | \description{ 29 | This function takes a pedigree, adds missing founders, and then sorts the 30 | pedigree. 31 | } 32 | \details{ 33 | Many functions (both in nadiv and from other programs) dealing with 34 | pedigrees must first sort a pedigree such that individuals appear in the ID 35 | column in rows preceding where they appear in either the Dam or Sire 36 | column. Further, these functions and programs require that all individuals 37 | in the dam and sire columns of a pedigree also have an entry in the ID 38 | column. This function easily prepares data sets to accommodate these 39 | requirements using a very fast topological sorting algorithm. 40 | 41 | NOTE: more columns than just a pedigree can be passed in the \code{pedigree} 42 | argument. In the case of missing founders, these columns are given NA 43 | values for all rows where founders have been added to the pedigree. The 44 | entire object supplied to \code{pedigree} is ordered, ensuring that all 45 | information remains connected to the individual 46 | 47 | Missing parents (e.g., base population) should be denoted by either 'NA', 48 | '0', or '*'. 49 | 50 | When a non-null argument is given to \code{gender}, dams without an entry in 51 | the ID column (that are subsequently added to the pedigree) are given the 52 | gender designated for other dams (and similarly for sires). 53 | 54 | The \code{check} argument performs checks on the format of the pedigree 55 | supplied to try and identify any issues regarding the notation of missing 56 | values and validity of the basic pedigree for further processing. 57 | } 58 | \examples{ 59 | 60 | # First create an unordered pedigree with (4) missing founders 61 | warcolak_unsuitable <- warcolak[sample(seq(5, nrow(warcolak), 1), 62 | size = (nrow(warcolak) - 4), replace = FALSE), ] 63 | nrow(warcolak) 64 | nrow(warcolak_unsuitable) 65 | # Fix and sort the pedigree 66 | ## Automatically assign the correct gender to the added founders 67 | ### Also sort the data accompanying each individual 68 | warcolak_fixed_ordered <- prepPed(warcolak_unsuitable, gender = "sex") 69 | head(warcolak_fixed_ordered) 70 | 71 | } 72 | \seealso{ 73 | \code{\link[nadiv]{genAssign}}, \code{\link[nadiv]{prunePed}} 74 | } 75 | -------------------------------------------------------------------------------- /R/founderLine.R: -------------------------------------------------------------------------------- 1 | #' Identifies the matriline or patriline to which each individual in a pedigree 2 | #' belongs 3 | #' 4 | #' For every individual in a pedigree, the function identifies either the one 5 | #' female or male ancestor that is a founder (defined here as an individual 6 | #' identity in the pedigree for which both dam and sire information are 7 | #' missing). 8 | #' 9 | #' Missing parents (e.g., base population) should be denoted by either 'NA', 10 | #' '0', or '*'. 11 | #' 12 | #' Individuals with a missing parent for the column identified by the 'sex' 13 | #' argument are assigned themselves as their founder line. Thus, the definition 14 | #' of the founder population from a given pedigree is simply all individuals 15 | #' with missing parents (and in this case just a single missing parent 16 | #' classifies an individual as a founder). 17 | #' 18 | #' @param pedigree A pedigree where the columns are ordered ID, Dam, Sire, Sex 19 | #' @param sex Character indicating the column name in pedigree identifying 20 | #' either the dam (for matriline) or sire (for patriline) identities 21 | #' 22 | #' @return A vector of length equal to the number of rows in the pedigree 23 | #' @author \email{matthewwolak@@gmail.com} 24 | #' @examples 25 | #' 26 | #' founderLine(FG90, sex = "dam") # matriline from this example pedigree 27 | #' 28 | #' #Create random pedigree, tracking the matrilines 29 | #' ## Then compare with founderLine() output 30 | #' K <- 8 # No. individuals per generation (KEEP and even number) 31 | #' gen <- 10 # No. of generations 32 | #' datArr <- array(NA, dim = c(K, 5, gen)) 33 | #' dimnames(datArr) <- list(NULL, 34 | #' c("id", "dam", "sire", "sex", "matriline"), NULL) 35 | #' # initialize the data array 36 | #' datArr[, "id", ] <- seq(K*gen) 37 | #' datArr[, "sex", ] <- c(1, 2) 38 | #' femRow <- which(datArr[, "sex", 1] == 2) # assume this is same each generation 39 | #' # (Why K should always be an even number) 40 | #' datArr[femRow, "matriline", 1] <- femRow 41 | #' # males have overlapping generations, BUT females DO NOT 42 | #' for(g in 2:gen){ 43 | #' datArr[, "sire", g] <- sample(c(datArr[femRow-1, "id", 1:(g-1)]), 44 | #' size = K, replace = TRUE) 45 | #' gdams <- sample(femRow, size = K, replace = TRUE) 46 | #' datArr[, c("dam", "matriline"), g] <- datArr[gdams, c("id", "matriline"), g-1] 47 | #' } 48 | #' ped <- data.frame(apply(datArr, MARGIN = 2, FUN = function(x){x})) 49 | #' nrow(ped) 50 | #' #Now run founderLine() and compare 51 | #' ped$line <- founderLine(ped, sex = "dam") 52 | #' stopifnot(identical(ped$matriline, ped$line), 53 | #' sum(ped$matriline-ped$line, na.rm = TRUE) == 0, 54 | #' range(ped$matriline-ped$line, na.rm = TRUE) == 0) 55 | #' 56 | #' 57 | #' @export 58 | founderLine <- function(pedigree, sex){ 59 | colsel <- match(sex, names(pedigree)) 60 | if(!colsel %in% seq(ncol(pedigree))){ 61 | stop("character argument to 'sex' must exactly match a column name in 'pedigree'") 62 | } 63 | nPed <- numPed(pedigree[, 1:3]) 64 | line <- par <- nPed[, colsel] 65 | parKnown <- par > 0 66 | while(any(parKnown)){ 67 | par[parKnown] <- nPed[line[parKnown], colsel] 68 | parKnown <- par > 0 69 | line[parKnown] <- par[parKnown] 70 | } 71 | line[which(line < 0 & pedigree[, 4] == pedigree[line[line > 0][1], 4])] <- which(line < 0 & pedigree[, 4] == pedigree[line[line > 0][1], 4]) 72 | line[line < 0] <- NA 73 | if(is.factor(pedigree[, 1])) as.character(pedigree[line, 1]) else pedigree[line, 1] 74 | } 75 | 76 | -------------------------------------------------------------------------------- /R/makeDufam.R: -------------------------------------------------------------------------------- 1 | makeDufam <- function(pedigree, parallel = FALSE, 2 | ncores = getOption("mc.cores", 2L), invertD = TRUE, 3 | returnA = FALSE, det = TRUE, verbose = TRUE){ 4 | 5 | N <- nrow(pedigree) 6 | pedigree <- cbind(pedigree, gen = genAssign(pedigree), oseq = seq.int(N)) 7 | pedigree <- pedigree[order(pedigree$gen, pedigree[, 2], pedigree[, 3]), ] 8 | numeric.pedigree <- numPed(pedigree[, 1:3]) 9 | A <- makeA(pedigree[, 1:3]) 10 | dA <- diag(A) 11 | 12 | if(parallel){ 13 | if(length(A@x)/ncores < 10){ 14 | warning("pedigree too small - 'parallel' set to FALSE instead") 15 | parallel <- FALSE 16 | } 17 | } 18 | 19 | if(!parallel){ 20 | if(verbose) cat(paste("starting to make D...")) 21 | Cout <- .C("dijjskip", PACKAGE = "nadiv", 22 | as.integer(numeric.pedigree[, 2] - 1), 23 | as.integer(numeric.pedigree[, 3] - 1), 24 | as.integer(A@i), 25 | as.integer(A@p), 26 | as.double(A@x/2), 27 | as.integer(N), 28 | as.double(rep(0, length(A@x))), 29 | as.integer(rep(0, length(A@i))), 30 | as.integer(rep(0, N)), 31 | as.integer(0)) 32 | 33 | D <- sparseMatrix(i = Cout[[8]][1:Cout[[10]]], 34 | p = c(Cout[[9]], Cout[[10]]), 35 | x = Cout[[7]][1:Cout[[10]]], 36 | dims = c(N, N), dimnames = list(as.character(pedigree[, 1]), NULL), 37 | symmetric = TRUE, index1 = FALSE) 38 | diag(D) <- 2 - dA 39 | 40 | if(!returnA) A <- NULL 41 | rm("Cout") 42 | 43 | } else{ 44 | listA <- data.frame(Row = as.integer(rep(1:length(A@p[-1]), diff(A@p))), Column = as.integer(A@i + 1)) 45 | wrap_dij <- function(x){ 46 | sub_lA <- listA[min(x):max(x), 1:2] 47 | lA_r <- dim(sub_lA)[1] 48 | Cout <- .C("dijp", PACKAGE = "nadiv", 49 | as.integer(numeric.pedigree[, 2] - 1), 50 | as.integer(numeric.pedigree[, 3] - 1), 51 | as.integer(lA_r), 52 | as.integer(sub_lA[, 1] - 1), 53 | as.integer(sub_lA[, 2] - 1), 54 | as.integer(A@i), 55 | as.integer(A@p), 56 | as.double(A@x/2), 57 | as.double(rep(0, lA_r))) 58 | Cout[[9]] 59 | } 60 | 61 | if(verbose) cat(paste("starting to make D...")) 62 | Dijs <- parallel::pvec(seq(1, dim(listA)[1], 1), FUN = wrap_dij, mc.set.seed = FALSE, mc.silent = FALSE, mc.cores = ncores, mc.cleanup = TRUE) 63 | 64 | D <- sparseMatrix(i = A@i, 65 | p = A@p, 66 | x = Dijs, 67 | dims = c(N, N), dimnames = list(as.character(pedigree[, 1]), NULL), 68 | symmetric = TRUE, index1 = FALSE) 69 | if(!returnA) A <- NULL 70 | D <- drop0(D) 71 | diag(D) <- 2 - dA 72 | 73 | } 74 | 75 | if(verbose) cat(paste(".done", "\n")) 76 | D <- D[pedigree$oseq, pedigree$oseq] 77 | if(returnA) A <- A[pedigree$oseq, pedigree$oseq] 78 | if(det) logDet <- determinant(D, logarithm = TRUE)$modulus[1] else logDet <- NULL 79 | if(invertD){ 80 | Dinv <- as(solve(D), "dgCMatrix") 81 | Dinv@Dimnames <- list(as.character(pedigree[pedigree$oseq, 1]), NULL) 82 | listDinv <- sm2list(Dinv, rownames = pedigree[pedigree$oseq, 1], colnames=c("row", "column", "Dinverse")) 83 | return(list(A = A, D = D, logDet = logDet, Dinv=Dinv, listDinv=listDinv)) 84 | } else{ 85 | return(list(A = A, D = D, logDet = logDet)) 86 | } 87 | } 88 | 89 | -------------------------------------------------------------------------------- /man/simPedDFC.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simPed.R 3 | \name{simPedDFC} 4 | \alias{simPedDFC} 5 | \title{Double first cousin pedigree construction} 6 | \usage{ 7 | simPedDFC(U, gpn = 4, fsn = 4, s = 2, fws = 2, prefix = NULL) 8 | } 9 | \arguments{ 10 | \item{U}{An integer number of units or blocks for the design} 11 | 12 | \item{gpn}{Number of grandparent pairs in the generation 0 (GP) 13 | (must be >= 2). Equals the number of full-sib families in generation 1 (P).} 14 | 15 | \item{fsn}{Number of offspring in each full-sib family of generations 1 and 2 16 | (P and F1 - must be an even number >= 4).} 17 | 18 | \item{s}{Number of sires per full-sib family in generation 1 (P - must be >=2)} 19 | 20 | \item{fws}{Number of generation 1 (P) families with sires. Together, with 21 | \code{s}, sets up how cousins and double first cousins are produced} 22 | 23 | \item{prefix}{Optional prefix to add to every identity} 24 | } 25 | \value{ 26 | A \code{data.frame} with columns corresponding to: id, dam, sire, 27 | and sex. Sex is \code{M} for males and \code{F} for females. 28 | } 29 | \description{ 30 | Simulates a pedigree for the \dQuote{double first cousin} mating design 31 | (Fairbairn and Roff 2006). 32 | } 33 | \details{ 34 | This is an adaption to a half-sib breeding design which also produces first 35 | cousins and double first cousins. Double first cousins are produced by 36 | mating two brothers to two sisters (the offspring of the resulting two 37 | families are double first cousins with one another). This is described in 38 | Fairbairn and Roff (2006) as being particularly effective for separating 39 | autosomal additive genetic variance from sex chromosomal additive genetic 40 | variance. It is also amenable to estimating dominance variance, however, it 41 | still has difficulty separating dominance variance from common maternal 42 | environmental variance (Meyer 2008). 43 | 44 | For a given unit of the design (\code{U} total), \code{2*gpn} 0-generation 45 | (grandparental or GP) individuals are created and paired to make \code{gpn} 46 | full-sib families. Then the first \code{fws} families are each allocated 47 | \code{s} males/sires and \code{s*(fws-1)} females/dams in the 1 (parental or P) 48 | generation. The remaining (\code{gpn-fws}) families (only when: 49 | \code{gpn > fws}) are assigned \code{s*fws} females/dams. If 50 | \code{fsn > (s*fws)}, the remaining generation 1 (P) individuals in each 51 | full-sib family (\code{fsn - (s*fws)}) are allocated to each family with 52 | equal numbers of females and males [this allows for more individuals to be 53 | phenotyped in generation 1 (P) than are used to produce generation 2 (F1)]. 54 | Generation 2 (F1) is then assigned, based on the mating design in Fairbairn 55 | and Roff (2006) - essentially each sire [of the \code{s} per full-sib family 56 | in generation 1 (P)] is mated to a female from each of the other \code{gpn-1} 57 | full-sib families to produce \code{fsn} offspring (with equal numbers of 58 | females and males). 59 | } 60 | \examples{ 61 | 62 | DFC1 <- simPedDFC(U = 1, gpn = 2, fsn = 4, s = 2, fws = 2) 63 | 64 | } 65 | \references{ 66 | Fairbairn, D.J. and D.A. Roff. 2006. The quantitative genetics 67 | of sexual dimorphism: assessing the importance of sex-linkage. Heredity 68 | 97:319-328. 69 | 70 | Meyer, K. 2008. Likelihood calculations to evaluate experimental designs to 71 | estimate genetic variances. Heredity 101:212-221. 72 | } 73 | \seealso{ 74 | \code{\link{simPedHS}}, \code{\link{warcolak}} 75 | } 76 | \author{ 77 | \email{matthewwolak@gmail.com} 78 | } 79 | -------------------------------------------------------------------------------- /man/makeS.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeS.R 3 | \name{makeS} 4 | \alias{makeS} 5 | \title{Creates the additive genetic relationship matrix for the shared sex 6 | chromosomes} 7 | \usage{ 8 | makeS( 9 | pedigree, 10 | heterogametic, 11 | DosageComp = c(NULL, "ngdc", "hori", "hedo", "hoha", "hopi"), 12 | returnS = FALSE 13 | ) 14 | } 15 | \arguments{ 16 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire, Sex} 17 | 18 | \item{heterogametic}{Character indicating the label corresponding to the 19 | heterogametic sex used in the \dQuote{Sex} column of the pedigree} 20 | 21 | \item{DosageComp}{A character indicating which model of dosage compensation. 22 | If \code{NULL} then the \dQuote{ngdc} model is assumed.} 23 | 24 | \item{returnS}{Logical statement, indicating if the relationship matrix 25 | should be constructed in addition to the inverse} 26 | } 27 | \value{ 28 | a \code{list}: 29 | \describe{ 30 | \item{model }{the model of sex-chromosome dosage compensation assumed.} 31 | \item{S }{the sex-chromosome relationship matrix in sparse matrix 32 | form or NULL if \code{returnS} = FALSE} 33 | \item{logDet }{the log determinant of the S matrix} 34 | \item{Sinv }{the inverse of the S matrix in sparse matrix form} 35 | \item{listSinv }{the three column form of the non-zero elements for the 36 | inverse of the S matrix} 37 | \item{inbreeding }{the sex-linked inbreeding coefficients for all 38 | individuals in the pedigree} 39 | \item{vii }{a vector of the (non-zero) elements of the diagonal V matrix 40 | of the S=TVT' decomposition. Contains the variance of Mendelian 41 | sampling for a sex-linked locus} 42 | } 43 | } 44 | \description{ 45 | The function returns the inverse of the additive relationship matrix in 46 | sparse matrix format for the sex chromosomes (e.g., either X or Z). 47 | } 48 | \details{ 49 | Missing parents (e.g., base population) should be denoted by either 'NA', 50 | '0', or '*'. 51 | 52 | The inverse of the sex-chromosome additive genetic relationship matrix 53 | (S-matrix) is constructed implementing the Meuwissen and Luo (1992) 54 | algorithm to directly construct inverse additive relationship matrices 55 | (borrowing code from Jarrod Hadfield's MCMCglmm function, \code{inverseA}) 56 | and using equations presented in Fernando & Grossman (1990; see Wolak et al. 57 | 2013). Additionally, the S-matrix itself can be constructed (although this 58 | takes much longer than computing S-inverse directly). 59 | 60 | The choices of dosage compensation models are: no global dosage compensation 61 | ("ngdc"), random inactivation in the homogametic sex ("hori"), doubling of 62 | the single shared sex chromosome in the heterogametic sex ("hedo"), halving 63 | expression of both sex chromosomes in the homogametic sex ("hoha"), or 64 | inactivation of the paternal sex chromosome in the homogametic sex ("hopi"). 65 | } 66 | \examples{ 67 | 68 | makeS(FG90, heterogametic = "0", returnS = TRUE) 69 | 70 | } 71 | \references{ 72 | Wolak, M.E., D.A. Roff, and D.J. Fairbairn. in prep. The 73 | contribution of sex chromosomal additive genetic (co)variation to the 74 | phenotypic resemblance between relatives under alternative models of dosage 75 | compensation. 76 | 77 | Fernando, R.L. & Grossman, M. 1990. Genetic evaluation with autosomal and 78 | X-chromosomal inheritance. Theoretical and Applied Genetics, 80:75-80. 79 | 80 | Meuwissen, T.H.E. and Z. Luo. 1992. Computing inbreeding coefficients in 81 | large populations. Genetics, Selection, Evolution, 24:305-313. 82 | } 83 | \author{ 84 | \email{matthewwolak@gmail.com} 85 | } 86 | -------------------------------------------------------------------------------- /man/makeDomEpi.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeDomEpi.R 3 | \name{makeDomEpi} 4 | \alias{makeDomEpi} 5 | \title{Creates the additive by dominance and dominance by dominance epistatic 6 | genetic relationship matrices} 7 | \usage{ 8 | makeDomEpi( 9 | pedigree, 10 | output = c("AD", "DD", "both"), 11 | parallel = FALSE, 12 | invertD = FALSE, 13 | det = TRUE 14 | ) 15 | } 16 | \arguments{ 17 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 18 | 19 | \item{output}{Character(s) denoting which matrix and its inverse is to be 20 | constructed.} 21 | 22 | \item{parallel}{A logical indicating whether or not to use parallel 23 | processing. Note, this may only be available on Mac and Linux operating 24 | systems.} 25 | 26 | \item{invertD}{A logical indicating whether or not to invert the D matrix} 27 | 28 | \item{det}{A logical indicating whether or not to return the determinants 29 | for the epistatic relationship matrices} 30 | } 31 | \value{ 32 | All of the following will be returned. However, the values of the 33 | \code{output} and \code{invertD} options passed to the function will 34 | determine which of the following are not NULL objects within the list: 35 | \describe{ 36 | \item{D }{the D matrix in sparse matrix form} 37 | \item{logDetD }{the log determinant of the D matrix} 38 | \item{AD }{the AD matrix in sparse matrix form} 39 | \item{logDetAD }{the log determinant of the AD matrix} 40 | \item{DD }{the DD matrix in sparse matrix form} 41 | \item{logDetDD }{the log determinant of the DD matrix} 42 | \item{Dinv }{the inverse of the D matrix in sparse matrix form} 43 | \item{ADinv }{the inverse of the AD matrix in sparse matrix form} 44 | \item{DDinv }{the inverse of the DD matrix in sparse matrix form} 45 | \item{listDinv }{the three column form of the non-zero elements for the 46 | inverse of the D matrix} 47 | \item{listADinv }{the three column form of the non-zero elements for the 48 | inverse of the AD matrix} 49 | \item{listDDinv }{the three column form of the non-zero elements for the 50 | inverse of the DD matrix} 51 | } 52 | } 53 | \description{ 54 | Given a pedigree, the matrix of additive by dominance (AD) genetic 55 | relatedness, dominance by dominance (DD) genetic relatedness, or both are 56 | returned. 57 | } 58 | \details{ 59 | Missing parents (e.g., base population) should be denoted by either 'NA', 60 | '0', or '*'. 61 | 62 | Because of the computational demands of constructing the D matrix (see 63 | \code{\link{makeD}}), this function allows for the inverses that are derived 64 | from the D matrix (i.e., D-inverse, AD-inverse, and DD-inverse)to be 65 | constructed at the same time. This way, the D matrix will only have to be 66 | constructed once for use in the three separate genetic relatedness inverse 67 | matrices that depend upon it. However, using the \code{output} and 68 | \code{invertD} options in different combinations will ensure that only the 69 | desired matrix inverses are constructed. 70 | 71 | \code{parallel} = TRUE should only be used on Linux or Mac OSes (i.e., not 72 | Windows). 73 | 74 | Both the AD and DD matrix are computed from the Hadamard product of the 75 | respective matrices (see also, \code{\link{makeAA}}). 76 | } 77 | \examples{ 78 | 79 | Boutput <- makeDomEpi(Mrode9, output = "b", parallel = FALSE, invertD = FALSE) 80 | str(Boutput) 81 | 82 | DADoutput <- makeDomEpi(Mrode9, output = "AD", parallel = FALSE, invertD = TRUE) 83 | str(DADoutput) 84 | 85 | } 86 | \seealso{ 87 | \code{\link{makeA}}, \code{\link{makeD}}, \code{\link{makeAA}} 88 | } 89 | \author{ 90 | \email{matthewwolak@gmail.com} 91 | } 92 | -------------------------------------------------------------------------------- /man/aiFun.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aiFun.R 3 | \name{aiFun} 4 | \alias{aiFun} 5 | \title{Sampling (co)variances} 6 | \usage{ 7 | aiFun(model = NULL, AI.vec = NULL, inverse = TRUE, Dimnames = NULL) 8 | } 9 | \arguments{ 10 | \item{model}{A model object returned by a call to the \code{asreml} function.} 11 | 12 | \item{AI.vec}{A numeric vector of the Average Information matrix. The order 13 | must be the row-wise lower triangle of the matrix (including the diagonal).} 14 | 15 | \item{inverse}{A logical indicating whether the elements of the 16 | \emph{inverse} Average Information matrix are being provided. If FALSE, 17 | the Average Information matrix (and not its inverse) is being supplied.} 18 | 19 | \item{Dimnames}{A vector of characters if names are desired for the output 20 | (co)variance matrix. If not specified, either the default labels from the 21 | \code{asreml} object will be used or the rows and columns will be 22 | unlabeled.} 23 | } 24 | \value{ 25 | A \code{matrix} of k x k dimensions is returned, if k is the number 26 | of (co)variance components estimated in the model. Sampling covariances are 27 | above and below the diagonal while variances are located along the 28 | diagonal. If \code{Dimnames} is specified, the row and column names are 29 | assigned according the vector of names in this argument. 30 | } 31 | \description{ 32 | This function returns the sampling (co)variances of the variance components 33 | fitted in an mixed model solved using the Average Information algorithm 34 | } 35 | \details{ 36 | The inverse of the Average Information matrix provides the sampling 37 | (co)variance of each (co)variance component in the random portion of the 38 | mixed model. If a model from the ASReml-R function is supplied (\code{model} 39 | is not NULL), this function extracts the inverse of the AI matrix from an 40 | ASReml-R model and organizes it so that the sampling covariances between 41 | random terms are the off-diagonals and the sampling variances of random 42 | terms are located along the diagonal. The order of the variances along the 43 | diagonal is the same as the order entered in the random section of the 44 | \code{asreml} function. This is also the same order as the rows of a call to 45 | the summary function, \code{summary(model)$varcomp}. 46 | 47 | If \code{model} is NULL then \code{AI.vec} should contain the vector of 48 | values from an Average Information matrix. The function will then 49 | reconstruct this matrix, invert it, and supply the sampling (co) variances 50 | for the random terms in the model as described above. Note, either 51 | \code{model} or \code{AI.vec} must be supplied, but not both. 52 | } 53 | \note{ 54 | The vector of \code{Dimnames} should match the same order of variance 55 | components specified in the model. 56 | } 57 | \examples{ 58 | 59 | \dontrun{ 60 | library(asreml) 61 | ginvA <- ainverse(warcolak) 62 | ginvD <- makeD(warcolak[, 1:3])$listDinv 63 | attr(ginvD, "rowNames") <- as.character(warcolak[, 1]) 64 | attr(ginvD, "INVERSE") <- TRUE 65 | warcolak$IDD <- warcolak$ID 66 | warcolak.mod <- asreml(trait1 ~ sex, 67 | random = ~ vm(ID, ginvA) + vm(IDD, ginvD), 68 | data = warcolak) 69 | summary(warcolak.mod)$varcomp 70 | aiFun(model = warcolak.mod, Dimnames = c("Va", "Vd", "Ve"), inverse = TRUE) 71 | } 72 | 73 | output <- c(7.3075921, 7.0635161, 12.3423380, 1.9539486, 2.7586340, 0.6626111) 74 | aiFun(AI.vec = output, inverse = FALSE, Dimnames = c("Va", "Vd", "Ve")) 75 | 76 | } 77 | \references{ 78 | Gilmour, A.R., Gogel, B.J., Cullis, B.R., & Thompson, R. 2009. 79 | ASReml User Guide Release 3.0. VSN International Ltd., Hemel Hempstead, UK. 80 | } 81 | \author{ 82 | \email{matthewwolak@gmail.com} 83 | } 84 | -------------------------------------------------------------------------------- /man/ggTutorial.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nadiv-datasets.R 3 | \docType{data} 4 | \name{ggTutorial} 5 | \alias{ggTutorial} 6 | \title{Simulated dataset used to analyze data with genetic group animal models} 7 | \format{ 8 | A \code{data.frame} with 6000 observations on the following 10 9 | variables: 10 | \describe{ 11 | \item{id }{an integer vector specifying the 6000 unique individual 12 | identities} 13 | \item{dam }{an integer vector specifying the unique dam for each 14 | individual} 15 | \item{sire }{an integer vector specifying the unique sire for each 16 | individual} 17 | \item{parAvgU }{a numeric vector of the average autosomal total additive 18 | genetic effects (\code{u}) of each individual's parents} 19 | \item{mendel }{a numeric vector of the Mendelian sampling deviations 20 | from \code{parAvgU} autosomal total additive genetic effects that is 21 | unique to each individual} 22 | \item{u }{a numeric vector of the total autosomal additive genetic 23 | effects underlying \code{p}} 24 | \item{r }{a numeric vector of the residual (environmental) effects 25 | underlying \code{p}} 26 | \item{p }{a numeric vector of phenotypic values} 27 | \item{is}{an integer vector with \code{0} for individuals born in the 28 | focal population and \code{1} for individuals born outside of the 29 | focal population, but immigrated} 30 | \item{gen }{an integer vector specifying the generation in which each 31 | individual was born} 32 | } 33 | } 34 | \source{ 35 | Wolak, M.E. & J.M. 2017. Accounting for genetic differences among 36 | unknown parents in microevolutionary studies: how to include genetic 37 | groups in quantitative genetic animal models. Journal of Animal Ecology 38 | 86:7-20. doi:10.1111/1365-2656.12597 39 | } 40 | \usage{ 41 | ggTutorial 42 | } 43 | \description{ 44 | The dataset was simulated using the \code{\link{simGG}} function so that the 45 | pedigree contains a base population comprised of founders and non-founder 46 | immigrants. These data are then used in the main manuscript and tutorials 47 | accompanying Wolak & Reid (2017). 48 | } 49 | \details{ 50 | The dataset was simulated as described in the \sQuote{examples} section 51 | using the \code{\link{simGG}} function. Full details of the function and 52 | dataset can be found in Wolak & Reid (2017). 53 | 54 | The \code{data.frame} contains 6000 individuals across 15 generations. In 55 | each generation, the carrying capacity is limited to 400 individuals, the 56 | number of mating pairs limited to 200 pairs, and 40 immigrants per 57 | generation arrive starting in the second generation. 58 | 59 | The breeding values of the founders are drawn from a normal distribution 60 | with an expected mean of 0 and a variance of 1. The breeding values of all 61 | immigrants are drawn from a normal distribution with an expected mean of 3 62 | and variance of 1. Consequently, the expected difference between mean 63 | breeding values in the founders and immigrants is 3. All individuals are 64 | assigned a residual (environmental) deviation that is drawn from a normal 65 | distribution with an expected mean of 0 and variance of 1. 66 | } 67 | \examples{ 68 | 69 | \donttest{ 70 | set.seed(102) #<-- seed value used originally 71 | library(nadiv) 72 | # create data using `simGG()` 73 | ggTutorial <- simGG(K = 400, pairs = 200, noff = 4, g = 15, 74 | nimm = 40, nimmG = seq(2, 14, 1), # nimmG default value 75 | VAf = 1, VAi = 1, VRf = 1, VRi = 1, # all default values 76 | mup = 20, muf = 0, mui = 3, murf = 0, muri = 0, # mup and mui non-default values 77 | d_bvf = 0, d_bvi = 0, d_rf = 0, d_ri = 0) # all default values 78 | } 79 | 80 | } 81 | \keyword{datasets} 82 | -------------------------------------------------------------------------------- /R/findDFC.R: -------------------------------------------------------------------------------- 1 | #' Finds the double first cousins in a pedigree 2 | #' 3 | #' Given a pedigree, all pairs of individuals that are double first cousins are 4 | #' returned. 5 | #' 6 | #' When exact = TRUE, only those individuals whose grandparents are completely 7 | #' unrelated will be identified as double first cousins. When exact = FALSE, 8 | #' as long as the parents of individuals i and j are two sets of siblings 9 | #' (i.e., either sires full brothers/dams full sisters or two pairs of opposite 10 | #' sex full sibs) then i and j will be considered double first cousins. In the 11 | #' event where the grandparents of i and j are also related, exact = FALSE will 12 | #' still consider i and j full sibs, even though genetically they will be more 13 | #' related than exact = TRUE double first cousins. 14 | #' 15 | #' \code{parallel} = TRUE should only be used on Linux or Mac OSes (i.e., not 16 | #' Windows). 17 | #' 18 | #' @param pedigree A pedigree with columns organized: ID, Dam, Sire 19 | #' @param exact A logical statement indicating if individuals who are exactly 20 | #' double first cousins are to be identified 21 | #' @param parallel A logical statement indicating if parallelization should be 22 | #' attempted. Note, only reliable for Mac and Linux operating systems. 23 | #' @param ncores Number of cpus to use, default is maximum available 24 | #' 25 | #' @return a \code{list}: 26 | #' \describe{ 27 | #' \item{PedPositionList }{gives the list of row numbers for all the 28 | #' pairs of individuals that are related as double first cousins.} 29 | #' \item{DFC }{gives the list of IDs, as characters, for all the pairs of 30 | #' individuals that are related as double first cousins.} 31 | #' \item{FamilyCnt }{If two individuals, i and j, are double first cousins, 32 | #' then i's siblings will also be double first cousins with j's siblings. 33 | #' Therefore, this is the total number of family pairs where offspring 34 | #' are related as double first cousins.} 35 | #' } 36 | #' @author \email{matthewwolak@@gmail.com} 37 | #' @export 38 | findDFC <- function(pedigree, exact = FALSE, parallel = FALSE, ncores = getOption("mc.cores", 2L)) 39 | { 40 | numeric.pedigree <- numPed(pedigree) 41 | ped <- cbind(numeric.pedigree, genAssign(numeric.pedigree), rep(0, dim(numeric.pedigree)[1])) 42 | num.out <- ped[ped[,4] >= 2, ] 43 | ni <- dim(num.out)[1] 44 | maxid <- max(num.out[,1]) 45 | 46 | i <- unlist(mapply(rep, num.out[-ni, 1], each = seq((ni-1), 1))) 47 | j <- unlist(lapply(seq(2,ni), FUN = function(x) num.out[x:ni, 1])) 48 | if(exact) exct <- 1 else exct <- 0 49 | 50 | if(parallel) { 51 | wrap_DFC <- function(x){ 52 | i.tmp <- i[min(x):max(x)] 53 | j.tmp <- j[min(x):max(x)] 54 | Cout <- .C("dfc", PACKAGE = "nadiv", 55 | as.integer(numeric.pedigree[, 2] - 1), 56 | as.integer(numeric.pedigree[, 3] - 1), 57 | as.integer(i.tmp - 1), 58 | as.integer(j.tmp - 1), 59 | as.integer(length(i.tmp)), 60 | as.integer(exct)) 61 | Cout[[3]] 62 | } 63 | dfcs.vec <- parallel::pvec(seq.int(length(i)), FUN = wrap_DFC, mc.set.seed = FALSE, mc.silent = TRUE, mc.cores = ncores, mc.cleanup = TRUE) 64 | } else{ 65 | Cout <- .C("dfc", PACKAGE = "nadiv", 66 | as.integer(numeric.pedigree[, 2] - 1), 67 | as.integer(numeric.pedigree[, 3] - 1), 68 | as.integer(i - 1), 69 | as.integer(j - 1), 70 | as.integer(length(i)), 71 | as.integer(exct)) 72 | dfcs.vec <- Cout[[3]] 73 | } 74 | 75 | 76 | yes.dfcs <- which(dfcs.vec == 1) 77 | 78 | return(list(PedPositionList = data.frame(i = i[yes.dfcs], j = j[yes.dfcs]), DFC = data.frame(i = pedigree[i[yes.dfcs], 1], j = pedigree[j[yes.dfcs], 1]), FamilyCnt = dim(unique(cbind(pedigree[i[yes.dfcs], 2:3], pedigree[j[yes.dfcs], 2:3])))[1])) 79 | } 80 | 81 | -------------------------------------------------------------------------------- /man/makeMinv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeMinv.R 3 | \name{makeMinv} 4 | \alias{makeMinv} 5 | \alias{makeMinvML} 6 | \title{Create the inverse (additive) mutational effects relationship matrix} 7 | \usage{ 8 | makeMinv(pedigree, ...) 9 | 10 | makeMinvML(pedigree, ...) 11 | } 12 | \arguments{ 13 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 14 | 15 | \item{\dots}{Arguments to be passed to methods} 16 | } 17 | \value{ 18 | a \code{list}: 19 | \describe{ 20 | \item{Minv }{the inverse of the (additive) mutational effects 21 | relationship matrix in sparse matrix form} 22 | \item{listMinv }{the three column list of the non-zero elements for the 23 | inverse of the (additive) mutational effects relationship matrix. 24 | \code{attr(*, "rowNames")} links the integer for rows/columns to the ID 25 | column from the pedigree.} 26 | \item{h }{the amount by which segregation variance is reduced by 27 | inbreeding. Similar to the individual coefficients of inbreeding (f) 28 | derived during the construction of the inverse numerator relatedness matrix. 29 | in the pedigree (matches the order of the first/ID column of the 30 | pedigree).} 31 | \item{logDet }{the log determinant of the M matrix} 32 | \item{dii }{the (non-zero) elements of the diagonal D matrix of the M=TDT' 33 | decomposition. Contains the variance of Mendelian sampling. Matches 34 | the order of the first/ID column of the pedigree. Note Wray (1990) and 35 | Casellas and Medrano (2008) algorithms use \code{v=sqrt(dii)}.} 36 | } 37 | } 38 | \description{ 39 | Returns the inverse of the (additive) mutational effects relationship matrix. 40 | It can also be used to obtain components needed for the calculations in the 41 | underlying algorithm. 42 | } 43 | \details{ 44 | Missing parents (e.g., base population) should be denoted by either 'NA', 45 | '0', or '*'. 46 | 47 | Note the assumption under the infinitesimal model, that mutation has essentially 48 | zero probability of affecting an inbred locus (hence removing inbred 49 | identity-by-descent), however, mutations may themselves be subject to 50 | inbreeding (Wray 1990). 51 | 52 | By default, the algorithm described in Casellas and Medrano (2008) is 53 | implemented here, in which the inverse-M is separate from the typical inverse 54 | relatedness matrix (inverse-A). Casellas and Medrano's algorithm allows 55 | separate partitioning of additive genetic variance attributed to inheritance 56 | of allelic variation present in the base population (inverse-A) from 57 | additive genetic variance arising from mutation and subsequent sharing of 58 | mutant alleles identical-by-descent. Alternatively, Wray (1990) formulates 59 | an algorithm which combines both of these processes (i.e., the A-inverse with 60 | the M-inverse matrices). If the Wray algorithm is desired, this can be 61 | implemented by specifying a numeric value to an argument named \code{theta}. 62 | The value used for \code{theta} should be as described in Wray (1990). See 63 | examples below for use of this argument. 64 | } 65 | \examples{ 66 | 67 | ## Example pedigree from Wray 1990 68 | #### Implement Casellas & Medrano (2008) algorithm 69 | Mout <- makeMinv(Wray90[, 1:3]) 70 | #### Wray (1990) algorithm with extra argument `theta` 71 | Mwray <- makeMinv(Wray90[, 1:3], theta = 10.0)$Minv # compare to Wray p.184 72 | } 73 | \references{ 74 | Casellas, J. and J.F. Medrano. 2008. Within-generation mutation 75 | variance for litter size in inbred mice. Genetics. 179:2147-2155. 76 | 77 | Meuwissen, T.H.E & Luo, Z. 1992. Computing inbreeding 78 | coefficients in large populations. Genetics, Selection, Evolution. 24:305-313. 79 | 80 | Mrode, R.A. 2005. Linear Models for the Prediction of Animal Breeding 81 | Values, 2nd ed. Cambridge, MA: CABI Publishing. 82 | 83 | Wray, N.A. 1990. Accounting for mutation effects in the additive genetic 84 | variance-covariance matrix and its inverse. Biometrics. 46:177-186. 85 | } 86 | \author{ 87 | \email{matthewwolak@gmail.com} 88 | } 89 | -------------------------------------------------------------------------------- /R/aiFun.R: -------------------------------------------------------------------------------- 1 | #' Sampling (co)variances 2 | #' 3 | #' This function returns the sampling (co)variances of the variance components 4 | #' fitted in an mixed model solved using the Average Information algorithm 5 | #' 6 | #' The inverse of the Average Information matrix provides the sampling 7 | #' (co)variance of each (co)variance component in the random portion of the 8 | #' mixed model. If a model from the ASReml-R function is supplied (\code{model} 9 | #' is not NULL), this function extracts the inverse of the AI matrix from an 10 | #' ASReml-R model and organizes it so that the sampling covariances between 11 | #' random terms are the off-diagonals and the sampling variances of random 12 | #' terms are located along the diagonal. The order of the variances along the 13 | #' diagonal is the same as the order entered in the random section of the 14 | #' \code{asreml} function. This is also the same order as the rows of a call to 15 | #' the summary function, \code{summary(model)$varcomp}. 16 | #' 17 | #' If \code{model} is NULL then \code{AI.vec} should contain the vector of 18 | #' values from an Average Information matrix. The function will then 19 | #' reconstruct this matrix, invert it, and supply the sampling (co) variances 20 | #' for the random terms in the model as described above. Note, either 21 | #' \code{model} or \code{AI.vec} must be supplied, but not both. 22 | #' 23 | #' @param model A model object returned by a call to the \code{asreml} function. 24 | #' @param AI.vec A numeric vector of the Average Information matrix. The order 25 | #' must be the row-wise lower triangle of the matrix (including the diagonal). 26 | #' @param inverse A logical indicating whether the elements of the 27 | #' \emph{inverse} Average Information matrix are being provided. If FALSE, 28 | #' the Average Information matrix (and not its inverse) is being supplied. 29 | #' @param Dimnames A vector of characters if names are desired for the output 30 | #' (co)variance matrix. If not specified, either the default labels from the 31 | #' \code{asreml} object will be used or the rows and columns will be 32 | #' unlabeled. 33 | #' 34 | #' @return A \code{matrix} of k x k dimensions is returned, if k is the number 35 | #' of (co)variance components estimated in the model. Sampling covariances are 36 | #' above and below the diagonal while variances are located along the 37 | #' diagonal. If \code{Dimnames} is specified, the row and column names are 38 | #' assigned according the vector of names in this argument. 39 | #' @note The vector of \code{Dimnames} should match the same order of variance 40 | #' components specified in the model. 41 | #' @author \email{matthewwolak@@gmail.com} 42 | #' @references Gilmour, A.R., Gogel, B.J., Cullis, B.R., & Thompson, R. 2009. 43 | #' ASReml User Guide Release 3.0. VSN International Ltd., Hemel Hempstead, UK. 44 | #' @examples 45 | #' 46 | #' \dontrun{ 47 | #' library(asreml) 48 | #' ginvA <- ainverse(warcolak) 49 | #' ginvD <- makeD(warcolak[, 1:3])$listDinv 50 | #' attr(ginvD, "rowNames") <- as.character(warcolak[, 1]) 51 | #' attr(ginvD, "INVERSE") <- TRUE 52 | #' warcolak$IDD <- warcolak$ID 53 | #' warcolak.mod <- asreml(trait1 ~ sex, 54 | #' random = ~ vm(ID, ginvA) + vm(IDD, ginvD), 55 | #' data = warcolak) 56 | #' summary(warcolak.mod)$varcomp 57 | #' aiFun(model = warcolak.mod, Dimnames = c("Va", "Vd", "Ve"), inverse = TRUE) 58 | #' } 59 | #' 60 | #' output <- c(7.3075921, 7.0635161, 12.3423380, 1.9539486, 2.7586340, 0.6626111) 61 | #' aiFun(AI.vec = output, inverse = FALSE, Dimnames = c("Va", "Vd", "Ve")) 62 | #' 63 | #' @export 64 | aiFun <- function(model = NULL, AI.vec = NULL, inverse = TRUE, Dimnames=NULL) 65 | { 66 | if(!is.null(model)){ 67 | AI.vec <- model$ai 68 | } 69 | 70 | dimAI <- sqrt(length(AI.vec) * 2 + 0.25) - 0.5 71 | AI <- matrix(0, dimAI, dimAI) 72 | AI[which(upper.tri(AI, diag = TRUE) == TRUE)] <- AI.vec 73 | AI[which(lower.tri(AI) == TRUE)]<-t(AI)[which(lower.tri(AI) == TRUE)] 74 | if(inverse == FALSE) AI <- solve(AI) 75 | 76 | if(is.null(Dimnames)){Dimnames <- names(model$gammas)} 77 | dimnames(AI) <- list(Dimnames, Dimnames) 78 | 79 | AI 80 | } 81 | 82 | -------------------------------------------------------------------------------- /man/grfx.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/grfx.R 3 | \name{grfx} 4 | \alias{grfx} 5 | \title{Simulated genetic random effects} 6 | \usage{ 7 | grfx(n, G, incidence = NULL, output = "matrix", stdnorms = NULL, warn = TRUE) 8 | } 9 | \arguments{ 10 | \item{n}{The number of individuals for which to simulate effects} 11 | 12 | \item{G}{The variance-covariance matrix to model the effects after} 13 | 14 | \item{incidence}{A matrix of the covariance structure of the 'n' individuals 15 | or the Cholesky factorization of class \code{CHMfactor} for this structure.} 16 | 17 | \item{output}{Format for the output} 18 | 19 | \item{stdnorms}{Standard normal deviates to use} 20 | 21 | \item{warn}{Should a warning message be produced when the function interprets 22 | what to do based on the object class supplied to \code{incidence}} 23 | } 24 | \value{ 25 | The random effects coerced to be in the format specified by output. 26 | The default is a "matrix". 27 | } 28 | \description{ 29 | This function simulates effects for random terms in a linear mixed model 30 | based on relatedness matrices. The intended purpose is for simulating 31 | genetic and environmental effects from a pedigree. 32 | } 33 | \details{ 34 | The total number of effects simulated will be n*d, where d is the number of 35 | columns in the 'G' matrix. The standard normal deviates can be supplied 36 | instead of generated within the function when \code{stdnorms != NULL}. The 37 | length of this vector must be \code{n*nrow(G)}. 38 | 39 | Supplied incidence matrices should be n-by-n symmetric matrices or cholesky 40 | factorizations that resulted from a call to \code{Matrix::Cholesky()}. For 41 | simulated random effects using design matrices, see \code{\link{drfx}}. If 42 | no incidence matrix is supplied, \code{incidence = NULL}, the Identity matrix 43 | is used, which assumes that all 'n' random effects are independently and 44 | identically distributed (default to Identity matrix). 45 | 46 | See examples for how to make and use a Cholesky factorized incidence matrix, 47 | for instance in a Monte Carlo simulation. Whether such an approach results 48 | in performance of speed improvements within the Monte Carlo simulation, by 49 | avoiding a Cholesky decomposition of a large matrix at each iteration, has 50 | not been tested. Setting \code{warn = FALSE} will suppress the warnings that 51 | the function is assuming a Cholesky factorization is contained in the object 52 | supplied to the \code{incidence} argument. Currently, Cholesky factorizations 53 | must inherit from the class \dQuote{CHMfactor}. 54 | 55 | If G = x, where 'x' is a single number, then 'x' should still be specified 56 | as a 1-by-1 matrix (e.g., \code{matrix(x)}). Note, the G-matrix should 57 | never have a structure which produces a correlation exactly equal to 1 or 58 | -1. Instead, covariances should be specified so as to create a correlation 59 | of slightly less than (greater than) 1 (-1). For example: 0.9999 or 60 | -0.9999. 61 | } 62 | \examples{ 63 | 64 | # Create additive genetic breeding values for 2 uncorrelated traits 65 | # with different additive genetic variances 66 | A <- makeA(warcolak[1:200, 1:3]) 67 | Gmat <- matrix(c(20, 0, 0, 10), 2, 2) 68 | breedingValues <- grfx(n = 200, G = Gmat, incidence = A) 69 | 70 | # Now with a user supplied set of standard normal deviates 71 | snorms <- rnorm(nrow(warcolak[1:200,]) * ncol(Gmat)) 72 | breedingValues2a <- grfx(n = 200, G = Gmat, incidence = A, stdnorms = snorms) 73 | breedingValues2b <- grfx(n = 200, G = Gmat, incidence = A, stdnorms = snorms) 74 | identical(breedingValues2a, breedingValues2b) #<-- TRUE 75 | var(breedingValues2a) 76 | var(breedingValues2b) 77 | 78 | # User supplied Cholesky factorization of the incidence matrix from above 79 | cA <- Cholesky(A, LDL = FALSE, super = FALSE) 80 | inherits(cA, "CHMfactor") #<-- TRUE 81 | breedingValues3 <- grfx(n = 200, G = Gmat, incidence = cA, stdnorms = snorms) 82 | all.equal(breedingValues2a, breedingValues3) #<-- TRUE 83 | } 84 | \seealso{ 85 | \code{\link[MCMCglmm]{MCMCglmm}}, \code{\link{drfx}}, 86 | \code{\link{makeA}}, \code{\link{makeAA}}, \code{\link{makeD}}, 87 | \code{\link{makeDomEpi}}, \code{\link{makeDsim}}, \code{\link{makeS}} 88 | } 89 | \author{ 90 | \email{matthewwolak@gmail.com} 91 | } 92 | -------------------------------------------------------------------------------- /src/cs_util.c: -------------------------------------------------------------------------------- 1 | #include "cs.h" 2 | /* allocate a sparse matrix (triplet form or compressed-column form) */ 3 | cs *cs_spalloc (int m, int n, int nzmax, int values, int triplet) 4 | { 5 | cs *A = cs_calloc (1, sizeof (cs)) ; /* allocate the cs struct */ 6 | if (!A) return (NULL) ; /* out of memory */ 7 | A->m = m ; /* define dimensions and nzmax */ 8 | A->n = n ; 9 | A->nzmax = nzmax = CS_MAX (nzmax, 1) ; 10 | A->nz = triplet ? 0 : -1 ; /* allocate triplet or comp.col */ 11 | A->p = cs_malloc (triplet ? nzmax : n+1, sizeof (int)) ; 12 | A->i = cs_malloc (nzmax, sizeof (int)) ; 13 | A->x = values ? cs_malloc (nzmax, sizeof (double)) : NULL ; 14 | return ((!A->p || !A->i || (values && !A->x)) ? cs_spfree (A) : A) ; 15 | } 16 | 17 | /* change the max # of entries sparse matrix */ 18 | int cs_sprealloc (cs *A, int nzmax) 19 | { 20 | int ok, oki, okj = 1, okx = 1 ; 21 | if (!A) return (0) ; 22 | if (nzmax <= 0) nzmax = (CS_CSC (A)) ? (A->p [A->n]) : A->nz ; 23 | A->i = cs_realloc (A->i, nzmax, sizeof (int), &oki) ; 24 | if (CS_TRIPLET (A)) A->p = cs_realloc (A->p, nzmax, sizeof (int), &okj) ; 25 | if (A->x) A->x = cs_realloc (A->x, nzmax, sizeof (double), &okx) ; 26 | ok = (oki && okj && okx) ; 27 | if (ok) A->nzmax = nzmax ; 28 | return (ok) ; 29 | } 30 | 31 | /* free a sparse matrix */ 32 | cs *cs_spfree (cs *A) 33 | { 34 | if (!A) return (NULL) ; /* do nothing if A already NULL */ 35 | cs_free (A->p) ; 36 | cs_free (A->i) ; 37 | cs_free (A->x) ; 38 | return (cs_free (A)) ; /* free the cs struct and return NULL */ 39 | } 40 | 41 | /* free a numeric factorization */ 42 | csn *cs_nfree (csn *N) 43 | { 44 | if (!N) return (NULL) ; /* do nothing if N already NULL */ 45 | cs_spfree (N->L) ; 46 | cs_spfree (N->U) ; 47 | cs_free (N->pinv) ; 48 | cs_free (N->B) ; 49 | return (cs_free (N)) ; /* free the csn struct and return NULL */ 50 | } 51 | 52 | /* free a symbolic factorization */ 53 | css *cs_sfree (css *S) 54 | { 55 | if (!S) return (NULL) ; /* do nothing if S already NULL */ 56 | cs_free (S->pinv) ; 57 | cs_free (S->q) ; 58 | cs_free (S->parent) ; 59 | cs_free (S->cp) ; 60 | cs_free (S->leftmost) ; 61 | return (cs_free (S)) ; /* free the css struct and return NULL */ 62 | } 63 | 64 | /* allocate a cs_dmperm or cs_scc result */ 65 | csd *cs_dalloc (int m, int n) 66 | { 67 | csd *D ; 68 | D = cs_calloc (1, sizeof (csd)) ; 69 | if (!D) return (NULL) ; 70 | D->p = cs_malloc (m, sizeof (int)) ; 71 | D->r = cs_malloc (m+6, sizeof (int)) ; 72 | D->q = cs_malloc (n, sizeof (int)) ; 73 | D->s = cs_malloc (n+6, sizeof (int)) ; 74 | return ((!D->p || !D->r || !D->q || !D->s) ? cs_dfree (D) : D) ; 75 | } 76 | 77 | /* free a cs_dmperm or cs_scc result */ 78 | csd *cs_dfree (csd *D) 79 | { 80 | if (!D) return (NULL) ; /* do nothing if D already NULL */ 81 | cs_free (D->p) ; 82 | cs_free (D->q) ; 83 | cs_free (D->r) ; 84 | cs_free (D->s) ; 85 | return (cs_free (D)) ; 86 | } 87 | 88 | /* free workspace and return a sparse matrix result */ 89 | cs *cs_done (cs *C, void *w, void *x, int ok) 90 | { 91 | cs_free (w) ; /* free workspace */ 92 | cs_free (x) ; 93 | return (ok ? C : cs_spfree (C)) ; /* return result if OK, else free it */ 94 | } 95 | 96 | /* free workspace and return int array result */ 97 | int *cs_idone (int *p, cs *C, void *w, int ok) 98 | { 99 | cs_spfree (C) ; /* free temporary matrix */ 100 | cs_free (w) ; /* free workspace */ 101 | return (ok ? p : cs_free (p)) ; /* return result if OK, else free it */ 102 | } 103 | 104 | /* free workspace and return a numeric factorization (Cholesky, LU, or QR) */ 105 | csn *cs_ndone (csn *N, cs *C, void *w, void *x, int ok) 106 | { 107 | cs_spfree (C) ; /* free temporary matrix */ 108 | cs_free (w) ; /* free workspace */ 109 | cs_free (x) ; 110 | return (ok ? N : cs_nfree (N)) ; /* return result if OK, else free it */ 111 | } 112 | 113 | /* free workspace and return a csd result */ 114 | csd *cs_ddone (csd *D, cs *C, void *w, int ok) 115 | { 116 | cs_spfree (C) ; /* free temporary matrix */ 117 | cs_free (w) ; /* free workspace */ 118 | return (ok ? D : cs_dfree (D)) ; /* return result if OK, else free it */ 119 | } 120 | -------------------------------------------------------------------------------- /R/LRTest.R: -------------------------------------------------------------------------------- 1 | # Likelihood Ratio Test: 2 | # Tests the hypothesis that the reduced model offers a better fit 3 | # Helpful reading: section 6.4.1.1 of Bolker 2008. pp. 189-194 4 | #NOTE: sometimes ASReml-R returns positive log-likelihoods, other times negative log-likelihoods. My experience so far is that positive values are returned when there are often boundary parameters or the model is having trouble fitting the data. 5 | # ***!!!ASSUMPTION:*** 6 | ## when both are positive, the log-likelihood is being maximized (i.e., the greater value is a better fit). 7 | 8 | 9 | #' log-Likelihood Ratio Test 10 | #' 11 | #' Test the null hypothesis that the two models fit the data equally well. 12 | #' 13 | #' Boundary correction should be applied if the parameter that is dropped from 14 | #' the full model was on the boundary of its parameter space. In this instance, 15 | #' the distribution of the log-likelihood ratio test statistic is approximated 16 | #' by a mix of chi-square distributions (Self and Liang 1987). A \code{TRUE} 17 | #' value will implement the boundary correction for a one degree of freedom 18 | #' test. This is equivalent to halving the p-value from a test using a 19 | #' chi-square distribution with one degree of freedom (Dominicus et al. 2006). 20 | #' 21 | #' Currently, the test assumes that both log-likelihoods are negative or both 22 | #' are positive and will stop if they are of opposite sign. The interpretation 23 | #' is that the model with a greater negative log-likelihood (closer to zero) or 24 | #' greater positive log-likelihood provides a better fit to the data. 25 | #' 26 | #' @param full A numeric variable indicating the log-likelihood of the full 27 | #' model 28 | #' @param reduced A numeric variable indicating the log-likelihood of the 29 | #' reduced model 30 | #' @param df The number of degrees of freedom to use, representing the 31 | #' difference between the full and reduced model in the number of parameters 32 | #' estimated 33 | #' @param boundaryCorrection A logical argument indicating whether a boundary 34 | #' correction under one degree of freedom should be included. If the parameter 35 | #' that is dropped from the reduced model is estimated at the boundary of its 36 | #' parameter space in the full model, the boundary correction is often 37 | #' required. See Details for more. 38 | #' @return a \code{list}: 39 | #' \describe{ 40 | #' \item{lambda }{a numeric log-likelihood ratio test statistic} 41 | #' \item{Pval }{a numeric p-value given the \code{lambda} tested against a 42 | #' chi-squared distribution with the number of degrees of freedom as 43 | #' specified. May have had a boundary correction applied.} 44 | #' \item{corrected.Pval }{a logical indicating if the p-value was derived 45 | #' using a boundary correction. See \code{Details}} 46 | #' } 47 | #' @author \email{matthewwolak@@gmail.com} 48 | #' @seealso \code{\link{constrainFun}} 49 | #' @references Self, S. G., and K. Y. Liang. 1987. Asymptotic properties of 50 | #' maximum likelihood estimators and likelihood ratio tests under nonstandard 51 | #' conditions. Journal of the American Statistical Association 82:605-610. 52 | #' 53 | #' Dominicus, A., A. Skrondal, H. K. Gjessing, N. L. Pedersen, and J. Palmgren. 54 | #' 2006. Likelihood ratio tests in behavioral genetics: problems and solutions. 55 | #' Behavior Genetics 36:331-340. 56 | #' @examples 57 | #' 58 | #' # No boundary correction 59 | #' (noBC <- LRTest(full = -2254.148, reduced = -2258.210, 60 | #' df = 1, boundaryCorrection = FALSE)) 61 | #' # No boundary correction 62 | #' (withBC <- LRTest(full = -2254.148, reduced = -2258.210, 63 | #' df = 1, boundaryCorrection = TRUE)) 64 | #' stopifnot(noBC$Pval == 2*withBC$Pval) 65 | #' 66 | #' @export 67 | LRTest <- function(full, reduced, df = 1, boundaryCorrection = FALSE){ 68 | if(sign(full) != sign(reduced)){ 69 | stop("Signs of the log-likelihoods are opposite - or 1 log-likelihood is zero...don't know what to do") 70 | } 71 | # positive log-likelihoods: better fit has higher log-likelihood (more positive) 72 | if(sign(full) > 0){ 73 | lambda <- 2*(full - reduced) 74 | warning("Positive log-likelihoods:\nASSUMING full model has greater log-likelihood if it fits the data better than the reduced model") 75 | } 76 | # negative log-likelihoods: better fit has greater log-likelihood (less negative) 77 | if(sign(full) < 0){ 78 | lambda <- 2*(full - reduced) 79 | } 80 | 81 | if(boundaryCorrection & df == 1){ 82 | lrtP <- 0.5*(pchisq(lambda, df = df, lower.tail = FALSE)) 83 | } else{ 84 | lrtP <- pchisq(lambda, df = df, lower.tail = FALSE) 85 | } 86 | 87 | return(list(lambda = lambda, Pval = lrtP, corrected.Pval = boundaryCorrection)) 88 | } 89 | 90 | -------------------------------------------------------------------------------- /R/prunePed.R: -------------------------------------------------------------------------------- 1 | # Generic 2 | 3 | 4 | #' Prunes a pedigree based on individuals with phenotypes 5 | #' 6 | #' This function removes individuals who are either not themselves or not 7 | #' ancestors to phenotyped individuals 8 | #' 9 | #' Often mixed effect models run much faster when extraneous information is 10 | #' removed before running the model. This is particularly so when reducing the 11 | #' number of random effects associated with a relationship matrix constructed 12 | #' from a pedigree. 13 | #' 14 | #' NOTE: more columns than just a pedigree can be passed in the \code{pedigree} 15 | #' argument. 16 | #' 17 | #' Missing parents (e.g., base population) should be denoted by either 'NA', 18 | #' '0', or '*'. 19 | #' 20 | #' This function is very similar to (and the code is heavily borrowed from) a 21 | #' function of the same name in the \code{MCMCglmm} package by Jarrod Hadfield. 22 | #' 23 | #' @aliases prunePed prunePed.default prunePed.numPed 24 | #' @param pedigree An object, where the first 3 columns correspond to: ID, Dam, 25 | #' & Sire. See details. 26 | #' @param phenotyped A vector indicating which individuals in the pedigree have 27 | #' phenotypic information available. 28 | #' @param \dots Arguments to be passed to methods 29 | #' 30 | #' @return The pedigree object (can have more columns than just ID, Dam, and 31 | #' Sire), where the ID column contains an ID for all individuals who are 32 | #' actually phenotyped or are an ancestor to an individual with a phenotype 33 | #' (and are thus informative for estimating parameters in the base 34 | #' population). 35 | #' @seealso \code{\link[nadiv]{prepPed}} 36 | #' @examples 37 | #' 38 | #' 39 | #' # Make a pedigree (with sex) from the warcolak dataset 40 | #' warcolak_ped <- warcolak[, 1:4] 41 | #' 42 | #' # Reduce the number of individuals that have a phenotype for "trait1" in 43 | #' #the warcolak dataset 44 | #' t1phenotyped <- warcolak 45 | #' t1phenotyped[sample(seq.int(nrow(warcolak)), 1500, replace = FALSE), "trait1"] <- NA 46 | #' t1phenotyped <- t1phenotyped[which(!is.na(t1phenotyped$trait1)), ] 47 | #' 48 | #' # The following will give a pedigree with only individuals that have a 49 | #' # phenotype for "trait1" OR are an ancestor to a phenotyped individual. 50 | #' pruned_warcolak_ped <- prunePed(warcolak_ped, phenotyped = t1phenotyped$ID) 51 | #' 52 | #' # Now compare the sizes (note, pruned_warcolak_ped retained its column indicating sex. 53 | #' dim(warcolak_ped) 54 | #' dim(pruned_warcolak_ped) 55 | #' # We could have kept all of the data associated with individuals who had phenotypic 56 | #' # information on "trait1" by instead specifying 57 | #' pruned_fullt1_warcolak_ped <- prunePed(warcolak, phenotyped = t1phenotyped$ID) 58 | #' dim(pruned_fullt1_warcolak_ped) #<-- compare number of columns with above 59 | #' 60 | #' @export 61 | prunePed <- function(pedigree, phenotyped, ...){ 62 | UseMethod("prunePed", pedigree) 63 | } 64 | 65 | ############################################################################### 66 | ############################################################################### 67 | # Methods: 68 | ############################################################################### 69 | ############################################################################### 70 | 71 | ################################################ 72 | #Borrowed heavily from the 'prunePed' function 73 | # written by Jarrod Hadfield 74 | #in the 'MCMCglmm' package 75 | ################################################ 76 | 77 | #' @method prunePed default 78 | #' @rdname prunePed 79 | #' @export 80 | prunePed.default <- function (pedigree, phenotyped, ...) { 81 | nPed <- numPed(pedigree[, 1:3]) 82 | ikeep <- match(phenotyped, pedigree[, 1]) 83 | nind <- length(ikeep) + 1 84 | while(length(ikeep) != nind){ 85 | nind <- length(ikeep) 86 | ikeep <- union(c(nPed[ikeep, 2:3]), ikeep) 87 | ikeep <- ikeep[which(ikeep > 0)] 88 | } 89 | 90 | pedigree <- pedigree[sort(ikeep), ] 91 | pedigree[, 1] <- as.factor(as.character(pedigree[, 1])) 92 | pedigree[, 2] <- as.factor(as.character(pedigree[, 2])) 93 | pedigree[, 3] <- as.factor(as.character(pedigree[, 3])) 94 | pedigree 95 | } 96 | 97 | 98 | 99 | 100 | 101 | #' @method prunePed numPed 102 | #' @rdname prunePed 103 | #' @export 104 | prunePed.numPed <- function (pedigree, phenotyped, ...) { 105 | ikeep <- match(phenotyped, pedigree[, 1]) 106 | nind <- length(ikeep) + 1 107 | while(length(ikeep) != nind){ 108 | nind <- length(ikeep) 109 | ikeep <- union(c(pedigree[ikeep, 2:3]), ikeep) 110 | ikeep <- ikeep[which(ikeep > 0)] 111 | } 112 | pedigree[sort(ikeep), ] 113 | } 114 | 115 | -------------------------------------------------------------------------------- /R/geneDrop.R: -------------------------------------------------------------------------------- 1 | # Generic 2 | 3 | #' Functions to conduct gene dropping through a pedigree 4 | #' 5 | #' Functions that perform and summarize gene dropping conducted on supplied pedigrees 6 | #' 7 | #' Missing parents (e.g., base population) should be denoted by either 'NA', '0' 8 | #' , or '*'. 9 | #' 10 | #' \code{parallel} = TRUE should only be used on Linux or Mac operating systems 11 | #' (i.e., not Windows). 12 | #' 13 | #' Founder allelic values (the alleles assigned to an individual's maternal, 14 | #' paternal, or both haplotypes when the maternal, paternal, or both parents are 15 | #' missing) are equivalent positive and negative integer values corresponding to 16 | #' the maternal and paternal haplotypes, respectively. For example, if the first 17 | #' individual in the pedigree has two unknown parents it will have the following 18 | #' two allelic values: 1=maternal haplotype and -1=paternal haplotype. 19 | #' 20 | #' @aliases geneDrop geneDrop.default geneDrop.numPed 21 | #' @param pedigree A pedigree with columns organized: ID, Dam, Sire. 22 | #' @param N The number of times to iteratively trace alleles through the 23 | #' pedigree 24 | #' @param parallel A logical indicating whether or not to use parallel 25 | #' processing. Note, this may only be available for Mac and Linux operating 26 | #' systems. 27 | #' @param ncores The number of cpus to use when constructing the dominance 28 | #' relatedness matrix. Default is all available. 29 | #' @param \dots Other arguments that can be supplied to alter what summaries are 30 | #' reported. 31 | #' 32 | #' @return a \code{list}: 33 | #' \describe{ 34 | #' \item{IDs }{Original identities in the pedigree} 35 | #' \item{maternal }{Simulated maternal haplotypes} 36 | #' \item{paternal }{Simulated paternal haplotypes} 37 | #' \item{numericPedigree }{Pedigree in class \code{numPed} for convenient 38 | #' post-processing of haplotypes} 39 | #' } 40 | #' @author \email{matthewwolak@@gmail.com} 41 | #' @seealso \code{\link{makeDsim}} 42 | #' @examples 43 | #' geneDrop(Mrode2, N = 10) 44 | #' 45 | #' @export 46 | geneDrop <- function(pedigree, N, 47 | parallel = FALSE, ncores = getOption("mc.cores", 2L), ...){ 48 | UseMethod("geneDrop", pedigree) 49 | } 50 | 51 | ############################################################################### 52 | # Methods: 53 | #' @rdname geneDrop 54 | #' @method geneDrop default 55 | #' @export 56 | geneDrop.default <- function(pedigree, N, 57 | parallel = FALSE, ncores = getOption("mc.cores", 2L), ...){ 58 | 59 | nPed <- numPed(pedigree) 60 | n <- nrow(pedigree) 61 | dfounders <- which(nPed[, 2] == -998) 62 | sfounders <- which(nPed[, 3] == -998) 63 | #FIXME allow alleles to be specified, 64 | ## but associate user supplied alleles with integers (work on integers in c++) 65 | dalleles <- salleles <- vector("integer", length = n) 66 | #TODO allow supplied inbreeding coefficients so founders can be inbred 67 | dalleles[dfounders] <- as.integer(dfounders) 68 | salleles[sfounders] <- as.integer(-sfounders) 69 | Ndalleles <- rep(dalleles, each = N) 70 | Nsalleles <- rep(salleles, each = N) 71 | 72 | #TODO execute in parallel 73 | Cout <- .C("genedrop", 74 | as.integer(Ndalleles), 75 | as.integer(Nsalleles), 76 | as.integer(N), 77 | as.integer(n), 78 | as.integer(nPed[, 2] - 1), 79 | as.integer(nPed[, 3] - 1)) 80 | 81 | return(list(IDs = pedigree[, 1], 82 | maternal = matrix(Cout[[1]], ncol = N, byrow = TRUE), 83 | paternal = matrix(Cout[[2]], ncol = N, byrow = TRUE), 84 | numericPedigree = nPed)) 85 | } 86 | 87 | ###################################### 88 | 89 | #' @rdname geneDrop 90 | #' @method geneDrop numPed 91 | #' @export 92 | geneDrop.numPed <- function(pedigree, N, 93 | parallel = FALSE, ncores = getOption("mc.cores", 2L), ...){ 94 | 95 | n <- nrow(pedigree) 96 | dfounders <- which(pedigree[, 2] == -998) 97 | sfounders <- which(pedigree[, 3] == -998) 98 | #FIXME allow alleles to be specified, 99 | ## but associate user supplied alleles with integers (work on integers in c++) 100 | dalleles <- salleles <- vector("integer", length = n) 101 | #TODO allow supplied inbreeding coefficients so founders can be inbred 102 | dalleles[dfounders] <- as.integer(dfounders) 103 | salleles[sfounders] <- as.integer(-sfounders) 104 | Ndalleles <- rep(dalleles, each = N) 105 | Nsalleles <- rep(salleles, each = N) 106 | 107 | #TODO execute in parallel 108 | Cout <- .C("genedrop", 109 | as.integer(Ndalleles), 110 | as.integer(Nsalleles), 111 | as.integer(N), 112 | as.integer(n), 113 | as.integer(pedigree[, 2] - 1), 114 | as.integer(pedigree[, 3] - 1)) 115 | 116 | return(list(IDs = pedigree[, 1], 117 | maternal = matrix(Cout[[1]], ncol = N, byrow = TRUE), 118 | paternal = matrix(Cout[[2]], ncol = N, byrow = TRUE), 119 | numericPedigree = pedigree)) 120 | } 121 | 122 | -------------------------------------------------------------------------------- /man/makeTinv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeTinvDF.R 3 | \name{makeTinv} 4 | \alias{makeTinv} 5 | \alias{makeT} 6 | \alias{makeT.default} 7 | \alias{makeT.numPed} 8 | \alias{makeTinv.default} 9 | \alias{makeTinv.numPed} 10 | \alias{makeDiiF} 11 | \alias{makeDiiF.default} 12 | \alias{makeDiiF.numPed} 13 | \title{Creates components of the additive genetic relationship matrix and its inverse} 14 | \usage{ 15 | makeTinv(pedigree, ...) 16 | 17 | \method{makeTinv}{default}(pedigree, ...) 18 | 19 | \method{makeTinv}{numPed}(pedigree, ...) 20 | 21 | \method{makeT}{default}(pedigree, genCol = NULL, ...) 22 | 23 | \method{makeDiiF}{default}(pedigree, f = NULL, ...) 24 | 25 | \method{makeDiiF}{numPed}(pedigree, f = NULL, ...) 26 | } 27 | \arguments{ 28 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 29 | 30 | \item{\dots}{Arguments to be passed to methods} 31 | 32 | \item{genCol}{An integer value indicating the generation up to which the 33 | \code{T} matrix is to be created (corresponding to columns of the lower 34 | triangle \code{T} matrix). The first generation is numbered 0, default is 35 | all generations.} 36 | 37 | \item{f}{A numeric vector indicating the level of inbreeding. See Details} 38 | } 39 | \value{ 40 | a \code{list}: 41 | \describe{ 42 | \item{Tinv }{the inverse of the Cholesky decomposition of the additive 43 | genetic relationship matrix (Ainv=Tinv' Dinv Tinv) in sparse matrix form} 44 | \item{D }{the diagonal D matrix of the A=TDT' Cholesky decomposition. 45 | Contains the variance of Mendelian sampling. Matches 46 | the order of the first/ID column of the pedigree.} 47 | \item{f }{the individual coefficients of inbreeding for each individual 48 | in the pedigree (matches the order of the first/ID column of the 49 | pedigree).} 50 | } 51 | } 52 | \description{ 53 | This returns the Cholesky decomposition of the numerator relationship matrix 54 | and its inverse. It can also be used to obtain coefficients of inbreeding for 55 | the pedigreed population. 56 | } 57 | \details{ 58 | Missing parents (e.g., base population) should be denoted by either 'NA', 59 | '0', or '*'. 60 | 61 | The function implements an adaptation of the Meuwissen and Luo (1992) 62 | algorithm (particularly, following the description of the algorithm in 63 | Mrode 2005) with some code borrowed from the \code{inverseA} function by 64 | Jarrod Hadfield in the \code{MCMCglmm} package. 65 | 66 | The inbreeding level of individuals can be provided instead of calculated. 67 | \code{f} must be a vector that is the same length as individuals in the 68 | pedigree. Supplied coefficients of inbreeding are used instead of being 69 | calculated until a \code{NA} is encountered in the vector. From this position 70 | on, then coefficients of inbreeding are calculated and replace entries in 71 | \code{f}. This can be used, for example, to calculate coefficients of 72 | inbreeding for later generations when coefficients of inbreeding in the 73 | previous generations have already been calculated. To specify an average 74 | coefficient of inbreeding for the base population, modify the pedigree to 75 | include a single phantom parent and specify this individual's non-zero 76 | coefficient of inbreeding in \code{f} with the rest of the terms as NA. 77 | } 78 | \examples{ 79 | 80 | Tinv <- makeTinv(Mrode2) 81 | # Method for a numeric pedigree (of `nadiv` class "numPed") 82 | nPed <- numPed(Mrode2) 83 | Tinv2 <- makeTinv(nPed) 84 | 85 | ######## 86 | DF <- makeDiiF(Mrode2) 87 | # manually construct the inverse of the relatedness matrix `Ainv` 88 | Dinv <- DF$D #<-- not the inverse yet, just copying the object 89 | Dinv@x <- 1 / DF$D@x #<-- inverse of a diagonal matrix 90 | handAinv <- crossprod(Tinv, Dinv) \%*\% Tinv 91 | # make the A-inverse directly 92 | Ainv <- makeAinv(Mrode2)$Ainv 93 | # Compare 94 | handAinv 95 | Ainv 96 | stopifnot(all(abs((Ainv - handAinv)@x) < 1e-6)) 97 | 98 | # supply previous generation coefficients of inbreeding (f) 99 | ## to keep from re-calculating their f when analyzing subsequent generations 100 | DF <- makeDiiF(Mrode2[, 1:3]) 101 | Mrode2$gen <- genAssign(Mrode2) 102 | Mrode2$f_full <- DF$f 103 | Mrode2$f_in <- with(Mrode2, c(f_full[gen <= 1], rep(NA, sum(gen > 1)))) 104 | DF2 <- makeDiiF(Mrode2[, 1:3], f = Mrode2$f_in) 105 | stopifnot(identical(DF, DF2)) 106 | 107 | } 108 | \references{ 109 | Meuwissen, T.H.E & Luo, Z. 1992. Computing inbreeding 110 | coefficients in large populations. Genetics, Selection, Evolution. 24:305-313. 111 | 112 | Mrode, R.A. 2005. Linear Models for the Prediction of Animal Breeding 113 | Values, 2nd ed. Cambridge, MA: CABI Publishing. 114 | } 115 | \seealso{ 116 | \code{\link{makeAinv}}, \code{\link{makeA}} 117 | } 118 | \author{ 119 | \email{matthewwolak@gmail.com} 120 | } 121 | -------------------------------------------------------------------------------- /R/makeSd.R: -------------------------------------------------------------------------------- 1 | #' @aliases makeSd makeD 2 | #' @rdname makeD 3 | #' @export 4 | makeSd <- function(pedigree, heterogametic, 5 | DosageComp = c(NULL, "ngdc", "hori", "hedo", "hoha", "hopi"), 6 | parallel = FALSE, ncores = getOption("mc.cores", 2L), 7 | invertSd = TRUE, returnS = FALSE, det = TRUE, verbose = TRUE){ 8 | 9 | 10 | if(length(unique(pedigree[,4])) > 2) stop("Error: more than 2 sexes specified") 11 | 12 | dc.model <- match.arg(DosageComp) 13 | if(is.null(dc.model)){ 14 | warning("Assuming 'ngdc' dosage compensation model") 15 | dc.model <- "ngdc" 16 | } 17 | if(dc.model == "hopi" | dc.model == "hori"){ 18 | warning("Assume sex chromosomal dominance allelic interactions do not occur under 'hopi' or 'hori'\n") 19 | return(NULL) 20 | } 21 | 22 | 23 | Sout <- makeS(pedigree, heterogametic = heterogametic, 24 | DosageComp = dc.model, returnS = TRUE) 25 | # makeA() returns `dsCMatrix`, but S is `dgCMatrix` from above 26 | ## makeD()-like code below expects symmetric matrix ('dsCMatrix') 27 | S <- forceSymmetric(Sout$S) 28 | 29 | nPed <- numPed(pedigree[, 1:3]) 30 | damsex <- pedigree[unique(nPed[, 2])[-1], 4] 31 | if(any(damsex == heterogametic)){ 32 | pedname <- names(pedigree) 33 | pedigree <- pedigree[, c(1,3,2,4)] 34 | names(pedigree) <- pedname 35 | nPed <- numPed(pedigree[, 1:3]) 36 | } 37 | 38 | sex <- rep(-998, dim(pedigree)[1L]) 39 | sex[homs <- which(pedigree[,4] != heterogametic)] <- 1 40 | sex[hets <- which(pedigree[,4] == heterogametic)] <- 0 41 | nhom <- sum(sex) # Number of individuals with homogametic sex chromosomes 42 | N <- dim(nPed)[1L] 43 | 44 | #FIXME turned off next check so can test parallel=TRUE on small pedigrees 45 | # if(parallel){ 46 | # if(length(S@x)/ncores < 10){ 47 | # warning("pedigree too small - 'parallel' set to FALSE instead") 48 | # parallel <- FALSE 49 | # } 50 | # } 51 | 52 | if(!parallel){ 53 | if(verbose) cat("starting to make Sd...") 54 | 55 | Cout <- .C("sdij", PACKAGE = "nadiv", 56 | as.integer(nPed[, 2] - 1), # [[1]] dam ID/No. 57 | as.integer(nPed[, 3] - 1), # [[2]] sire ID/No. 58 | as.integer(S@i), # [[3]] S@i 59 | as.integer(S@p), # [[4]] S@p 60 | as.double(S@x), # [[5]] S@x 61 | as.integer(N), # [[6]] No. in pedigree 62 | as.double(rep(0, length(S@x))), # [[7]] Sd@x 63 | as.integer(rep(0, length(S@i))), # [[8]] Sd@i 64 | as.integer(rep(0, N)), # [[9]] Sd@p 65 | as.integer(0), # [[10]] cnt/count 66 | as.integer(sex)) # [[11]] sex 67 | 68 | Sd <- sparseMatrix(i = Cout[[8]][1:Cout[[10]]], 69 | p = Cout[[9]][1:(nhom+1)], 70 | x = Cout[[7]][1:Cout[[10]]], 71 | dims = c(nhom, nhom), 72 | dimnames = list(as.character(pedigree[homs, 1]), NULL), 73 | symmetric = TRUE, index1 = FALSE) 74 | diag(Sd) <- 1 - Sout$inbreeding[homs] 75 | 76 | if(!returnS) S <- NULL 77 | rm("Cout") 78 | 79 | } else{ 80 | #TODO 81 | stop("code not yet written to parallelize function") #FIXME 82 | # listA <- data.frame(Row = as.integer(rep(1:length(A@p[-1]), diff(A@p))), Column = as.integer(A@i + 1)) 83 | # wrap_dij <- function(x){ 84 | # sub_lA <- listA[min(x):max(x), 1:2] 85 | # lA_r <- dim(sub_lA)[1] 86 | # Cout <- .C("dijp", PACKAGE = "nadiv", 87 | # as.integer(numeric.pedigree[, 2] - 1), 88 | # as.integer(numeric.pedigree[, 3] - 1), 89 | # as.integer(lA_r), 90 | # as.integer(sub_lA[, 1] - 1), 91 | # as.integer(sub_lA[, 2] - 1), 92 | # as.integer(A@i), 93 | # as.integer(A@p), 94 | # as.double(A@x/2), 95 | # as.double(rep(0, lA_r))) 96 | # Cout[[9]] 97 | # } 98 | 99 | # if(verbose) cat("starting to make D...") 100 | # Dijs <- parallel::pvec(seq(1, dim(listA)[1], 1), FUN = wrap_dij, mc.set.seed = FALSE, mc.silent = FALSE, mc.cores = ncores, mc.cleanup = TRUE) 101 | 102 | # D <- sparseMatrix(i = A@i, p = A@p, x = Dijs, ...) 103 | # if(!returnA) A <- NULL 104 | # D <- drop0(D) 105 | # diag(D) <- 2 - dA 106 | 107 | } 108 | 109 | if(verbose) cat(".done", "\n") 110 | 111 | if(det) logDet <- determinant(Sd, logarithm = TRUE)$modulus[1] else logDet <- NULL 112 | if(invertSd){ 113 | if(verbose) cat("starting to invert Sd...") 114 | Sdinv <- as(solve(Sd), "dgCMatrix") 115 | Sdinv@Dimnames <- Sd@Dimnames 116 | if(verbose) cat(".done", "\n") 117 | listSdinv <- sm2list(Sdinv, rownames = Sd@Dimnames[[1L]], 118 | colnames = c("row", "column", "Sdinverse")) 119 | return(list(S = S, Sd = Sd, logDet = logDet, 120 | Sdinv = Sdinv, listSdinv = listSdinv)) 121 | } else{ 122 | return(list(S = S, Sd = Sd, logDet = logDet)) 123 | } 124 | } 125 | 126 | 127 | -------------------------------------------------------------------------------- /src/sinv.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void sinv( 6 | int *dam, 7 | int *sire, 8 | double *f, 9 | double *vii, 10 | int *iQP, 11 | int *pQP, 12 | double *xQP, 13 | int *nQP, 14 | int *nzmaxQP, 15 | int *iSP, 16 | int *pSP, 17 | double *xSP, 18 | int *nzmaxSP, 19 | double *DC, 20 | double *sex 21 | ){ 22 | 23 | int j, k, h, ntwo, cnt, sj, dj; 24 | double si; 25 | double *AN = new double[2*nQP[0]]; 26 | double *li = new double[nQP[0]]; 27 | cs *Q, *V, *tQ, *QV, *tS, *S; 28 | 29 | for(k=0; ki[k] = iQP[k]; 42 | Q->x[k] = xQP[k]; 43 | } 44 | for (k = 0 ; k <= nQP[0]; k++){ 45 | Q->p[k] = pQP[k]; 46 | } 47 | 48 | tQ = cs_transpose(Q, true); 49 | 50 | V = cs_spalloc(nQP[0], nQP[0], nzmaxQP[0], true, false); 51 | for (k = 0; k < nQP[0]; k++){ 52 | V->i[k] = k; 53 | V->x[k] = 1.0; 54 | V->p[k] = k; 55 | } 56 | V->p[nQP[0]] = nQP[0]; 57 | 58 | 59 | if(DC[0] == 0.0){ 60 | for(k=0; k=0){ 76 | 77 | dj=dam[j]; 78 | 79 | if(dj != ntwo){ 80 | AN[cnt] = dj; 81 | li[dj] += 0.5*li[j]; 82 | cnt++; 83 | } 84 | 85 | si += li[j]*li[j]*vii[j]; 86 | 87 | j -= ntwo; // set to value lower than all known identities 88 | 89 | for(h=0; hj){ 91 | j = AN[h]; 92 | } 93 | } 94 | for(h=0; h=0){ 131 | 132 | sj=sire[j]; 133 | dj=dam[j]; 134 | 135 | if(sex[j] == 1.0){ 136 | if(sj != ntwo){ 137 | AN[cnt] = sj; 138 | if(DC[0] == 0.25){ 139 | li[sj] += 1.0*li[j]; 140 | } 141 | else{ 142 | li[sj] += 0.5*li[j]; 143 | } 144 | cnt++; 145 | } 146 | } 147 | 148 | if(dj != ntwo){ 149 | AN[cnt] = dj; 150 | li[dj] += 0.5*li[j]; 151 | cnt++; 152 | } 153 | 154 | si += li[j]*li[j]*vii[j]; 155 | 156 | j -= ntwo; // set to value lower than all known identities 157 | 158 | for(h=0; hj){ 160 | j = AN[h]; 161 | } 162 | } 163 | for(h=0; hx[k] = 1.0 / vii[k]; 183 | } 184 | 185 | QV = cs_multiply(Q, V); 186 | tS = cs_multiply(QV, tQ); 187 | S = cs_transpose(tS, TRUE); 188 | 189 | for (k = 0 ; k < S->nzmax; k++){ 190 | iSP[k] = S->i[k]; 191 | xSP[k] = S->x[k]; 192 | } 193 | for (k = 0 ; k <= S->n; k++){ 194 | pSP[k] = S->p[k]; 195 | } 196 | nzmaxSP[0] = S->nzmax; 197 | 198 | cs_spfree(Q); 199 | cs_spfree(tQ); 200 | cs_spfree(V); 201 | cs_spfree(QV); 202 | cs_spfree(tS); 203 | cs_spfree(S); 204 | delete[] AN; 205 | delete[] li; 206 | } 207 | } 208 | -------------------------------------------------------------------------------- /man/makeAstarMult.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeAstarMult.R 3 | \name{makeAstarMult} 4 | \alias{makeAstarMult} 5 | \title{Creates the inverse additive genetic relationship matrix with genetic groups} 6 | \usage{ 7 | makeAstarMult(pedigree, ggroups, fuzz = NULL, gOnTop = FALSE) 8 | } 9 | \arguments{ 10 | \item{pedigree}{A pedigree where the columns are ordered ID, Dam, Sire} 11 | 12 | \item{ggroups}{Either a vector with the unique name of each genetic group, 13 | or a numeric indicating the number of unique genetic groups. See Details 14 | for different ways to specify. Note, cannot be NULL.} 15 | 16 | \item{fuzz}{A matrix containing the fuzzy classification of individuals into 17 | genetic groups.} 18 | 19 | \item{gOnTop}{A logical indicating if the A-inverse should be constructed 20 | with the \sQuote{g} genetic groups located in the first \sQuote{g} rows 21 | and columns if TRUE, else the \sQuote{g} genetic groups are located in the 22 | last \sQuote{g} rows and columns of A-inverse.} 23 | } 24 | \value{ 25 | Returns A*, or the inverse of the numerator relationship with 26 | groups, in sparse matrix form. 27 | } 28 | \description{ 29 | This returns the inverse of the additive genetic relationship matrix with 30 | genetic groups (A*). The matrix is set up through matrix multiplication of 31 | two sub-matrices instead of directly (as \code{\link{makeAinv}} does). 32 | } 33 | \details{ 34 | Missing parents (e.g., base population) should be denoted by either 'NA', 35 | '0', or '*'. 36 | 37 | The function implements the matrix multiplication, using sub-matrices 38 | \code{Q} and \code{A^-1}, as detailed in Quaas (1988, pp. 1342-1343). 39 | 40 | Genetic groups can be incorporated into the A-inverse by providing a value 41 | to the \code{ggroups} argument. The value supplied to \code{ggroups} can 42 | either be (1) a single integer indicating the number of unique genetic 43 | groups or (2) a character vector containing the name for each genetic group. 44 | These are referred to as pedigree types "A" and "D", respectively, and 45 | further details follow below. (Type="A") the pedigree contains unique IDs 46 | for the 'g' genetic groups in the first 'g' lines of the pedigree. The dam 47 | and sire of the genetic group rows should contain missing values (e.g., NA, 48 | "0", or "*"). All individuals in the pedigree should then have one of the 49 | 'g' genetic groups instead of an unknown parent. (Type="D") the pedigree 50 | contains only individuals in the ID column (no genetic groups have an ID) 51 | and there should be no missing values for any dams or sires. Instead, 52 | individuals for whom the dam and/or sire is unknown should have one of the 53 | genetic groups identified in the vector supplied to \code{ggroups} as the 54 | dam or sire. 55 | 56 | Fuzzy classification of genetic groups is implemented when \code{fuzz} is 57 | non-NULL. 58 | 59 | The argument to \code{gOnTop} specifies if the elements in the A-inverse 60 | should come at the beginning (\code{gOnTop = TRUE}) or end (\code{gOnTop = 61 | FALSE}) of the matrix. Depending on how the software implementing an animal 62 | model solves the mixed model equations, the equations for the genetic groups 63 | (and thus the elements in the augmented A-inverse) should be the first or 64 | last set of equations. 65 | 66 | See function \code{\link{makeAinv}} for directly obtaining the inverse of 67 | the additive genetic relationship matrix with genetic groups. 68 | } 69 | \examples{ 70 | 71 | # Using the Q1988 dataset in nadiv 72 | ## assign a null fuzzy classification matrix 73 | QfuzzNull <- matrix(c(1,0,0,1,0, 0,1,1,0,1), nrow = 5, ncol = 2, 74 | dimnames = list(letters[1:5], c("g1", "g2"))) 75 | 76 | # Type A 77 | ## no fuzzy classification 78 | Astar_A <- makeAstarMult(Q1988[-c(3:7), c(1,4,5)], ggroups = 2) 79 | ## with fuzzy classification 80 | Astar_Afuzzy <- makeAstarMult(Q1988[, c(1, 6, 7)], 81 | ggroups = 2, fuzz = QfuzzNull) 82 | 83 | # Type D 84 | ## no fuzzy classification 85 | Astar_D <- makeAstarMult(Q1988[-c(1:7), c(1, 4, 5)], ggroups = c("g1", "g2")) 86 | ## with fuzzy classification 87 | Astar_Dfuzzy <- makeAstarMult(Q1988[-c(1:2), c(1, 6, 7)], 88 | ggroups = c("g1", "g2"), fuzz = QfuzzNull) 89 | 90 | 91 | # Obtain the matrix directly 92 | ## no fuzzy classification 93 | Astar_direct <- makeAinv(Q1988[-c(3:7), c(1,4,5)], ggroups = 2)$Ainv 94 | stopifnot(length(drop0(round(Astar_direct 95 | - (Astar_A - Astar_Afuzzy) 96 | - (Astar_D - Astar_Dfuzzy) 97 | - Astar_direct, 10))@x) == 0) 98 | 99 | ## with fuzzy classification 100 | Astar_directF <- makeAinv(Q1988[-c(1:2), c(1, 6, 7)], fuzz = QfuzzNull)$Ainv 101 | stopifnot(length(drop0(round(Astar_directF 102 | - (Astar_A - Astar_Afuzzy) 103 | - (Astar_D - Astar_Dfuzzy) 104 | - Astar_direct, 10))@x) == 0) 105 | 106 | 107 | } 108 | \references{ 109 | Quaas, R.L. 1988. Additive genetic model with groups and 110 | relationships. Journal of Dairy Science. 71:1338-1345. 111 | } 112 | \seealso{ 113 | \code{\link{makeAinv}}, \code{\link{ggcontrib}} 114 | } 115 | \author{ 116 | \email{matthewwolak@gmail.com} 117 | } 118 | -------------------------------------------------------------------------------- /R/makeSdsim.R: -------------------------------------------------------------------------------- 1 | #' @aliases makeSdsim makeDsim 2 | #' @rdname makeDsim 3 | #' @export 4 | makeSdsim <- function(pedigree, heterogametic, N, 5 | DosageComp = c(NULL, "ngdc", "hori", "hedo", "hoha", "hopi"), 6 | parallel = FALSE, ncores = getOption("mc.cores", 2L), 7 | invertSd = TRUE, calcSE = FALSE, returnS = FALSE, verbose = TRUE){ 8 | 9 | if(length(unique(pedigree[,4])) > 2) stop("Error: more than 2 sexes specified") 10 | 11 | dc.model <- match.arg(DosageComp) 12 | if(is.null(dc.model)){ 13 | warning("Assuming 'ngdc' dosage compensation model") 14 | dc.model <- "ngdc" 15 | } 16 | if(dc.model == "hopi" | dc.model == "hori"){ 17 | warning("Assume sex chromosomal dominance allelic interactions do not occur under 'hopi' or 'hori'\n") 18 | return(NULL) 19 | } 20 | 21 | approxSd <- makeSd(pedigree, heterogametic = heterogametic, DosageComp = DosageComp, 22 | parallel = parallel, ncores = ncores, 23 | invertSd = invertSd, returnS = returnS) 24 | lapproxSd <- summary(approxSd$Sd) 25 | 26 | n <- dim(pedigree)[1L] 27 | nPed <- numPed(pedigree[, 1:3]) 28 | damsex <- pedigree[unique(nPed[, 2])[-1], 4] 29 | if(any(damsex == heterogametic)){ 30 | pedname <- names(pedigree) 31 | pedigree <- pedigree[, c(1,3,2,4)] 32 | names(pedigree) <- pedname 33 | nPed <- numPed(pedigree[, 1:3]) 34 | } 35 | sex <- rep(-998, n) 36 | sex[homs <- which(pedigree[,4] != heterogametic)] <- 1 37 | sex[hets <- which(pedigree[,4] == heterogametic)] <- 0 38 | nhom <- sum(sex) # Number of individuals with homogametic sex chromosomes 39 | 40 | #TODO delete next note once consolidated 'gene dropping' functions/code 41 | # diverges from `makeDsim()` and follows simplifications in `geneDrop()` 42 | dfounders <- which(nPed[, 2] == -998) 43 | sfounders <- which(nPed[, 3] == -998 & sex == 1) 44 | dalleles <- salleles <- vector("integer", length = n) 45 | 46 | dalleles[dfounders] <- as.integer(dfounders) 47 | salleles[sfounders] <- as.integer(-sfounders) 48 | Ndalleles <- rep(dalleles, each = N) 49 | Nsalleles <- rep(salleles, each = N) 50 | 51 | if(verbose) cat("making Sdsim ...") 52 | 53 | # diversion to calculate maximum expected entries in sex-chromosome D matrix 54 | ## based on calculation for sex-chromosome S matrix (additive) 55 | dnmiss <- which(nPed[, 2] != -998 & sex == 1) 56 | snmiss <- which(nPed[, 3] != -998 & sex == 1) 57 | bnmiss <- which(nPed[, 2] != -998 & nPed[, 3] != -998 & sex == 1) 58 | nSd <- nhom + 2 * length(dnmiss) + 2 * length(snmiss) 59 | nSd <- nSd + 2 * sum(duplicated(paste(nPed[, 2], nPed[, 3])[bnmiss]) == FALSE) 60 | 61 | Cout <- .C("sdsim", PACKAGE = "nadiv", 62 | as.integer(Ndalleles), # [[1]] N dam alleles (or homogametic sex if ZZ/ZW) 63 | as.integer(Nsalleles), # [[2]] N sire alleles (or heterogametic sex if ZZ/ZW) 64 | as.integer(N), # [[3]] N (number of replications) 65 | as.integer(n), # [[4]] n pedigree size 66 | as.integer(nPed[, 2] - 1), # [[5]] dam number IDs 67 | as.integer(nPed[, 3] - 1), # [[6]] sire number IDs 68 | as.integer(sex), # [[7]] sex or number of homogametic sex chromosomes 69 | as.integer(rep(0, nSd)), # [[8]] i slot of sex-chrom. dom. relatedness matrix 70 | as.integer(rep(0, n+1)), # [[9]] p slot of matrix 71 | as.integer(rep(0, nSd))) # [[10]] x slot of matrix 72 | 73 | nSd <- Cout[[9]][nhom+1] # change to reflect actual number of non-zeroes 74 | Sdsim <- sparseMatrix(i = Cout[[8]][1:nSd], 75 | p = Cout[[9]][1:(nhom+1)], 76 | x = Cout[[10]][1:nSd] / N, 77 | dims = c(nhom, nhom), dimnames = list(as.character(pedigree[homs, 1]), NULL), 78 | symmetric = TRUE, index1 = FALSE) 79 | diag(Sdsim) <- diag(approxSd$Sd) 80 | #TODO don't *have* to calculate diagonals in c++ ('sdsim.cc') because of above line 81 | ## But make sure doesn't mess up below combining of `lapproxSd` and `summary(Sdsim)` 82 | 83 | lapproxSd$simSd <- summary(Sdsim)$x 84 | listSdsim <- NULL 85 | if(calcSE) { 86 | #TODO check that SE calc is the same for sex-chromosomal case as it is for autosomes 87 | ## Could differ, because different chances of inheriting certain alleles 88 | ## Not strictly binomial sampling in same way as for autosomes 89 | lapproxSd$simSdse <- vapply(lapproxSd$simSd, FUN = function(x, N){(sqrt(x * (1 - x))) / sqrt(N)}, FUN.VALUE = vector("numeric", 1), N) 90 | listSdsim <- lapproxSd 91 | } 92 | 93 | if(verbose) cat(".done", "\n") 94 | logDetSdsim <- determinant(Sdsim, logarithm = TRUE)$modulus[1] 95 | 96 | if(invertSd){ 97 | if(verbose) cat("inverting Sdsim ...") 98 | Sdsiminv <- solve(Sdsim) 99 | Sdsiminv@Dimnames <- Sdsim@Dimnames 100 | if(verbose) cat(".done", "\n") 101 | listSdsiminv <- sm2list(Sdsiminv, rownames = Sdsim@Dimnames[[1L]], 102 | colnames = c("row", "column", "simSdinverse")) 103 | Sdsim <- as(Sdsim, "generalMatrix") 104 | 105 | return(list(S = approxSd$S, 106 | Sd = approxSd$Sd, logDetSd = approxSd$logDet, 107 | Sdinv = approxSd$Sdinv, listSdinv = approxSd$listSdinv, 108 | Sdsim = Sdsim, logDetSdsim = logDetSdsim, 109 | Sdsiminv = Sdsiminv, listSdsim = listSdsim, listSdsiminv = listSdsiminv)) 110 | } else{ 111 | return(list(S = approxSd$S, 112 | Sd = approxSd$Sd, logDetSd = approxSd$logDet, 113 | Sdsim = Sdsim, logDetSdsim = logDetSdsim, listSdsim = listSdsim)) 114 | } 115 | 116 | 117 | } 118 | 119 | 120 | -------------------------------------------------------------------------------- /src/dfc.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | extern "C"{ 4 | 5 | void dfc( 6 | int *dam, 7 | int *sire, 8 | int *i, 9 | int *j, 10 | int *Ni, 11 | int *exct 12 | ){ 13 | 14 | int k, idam, isire, jdam, jsire, idgd, idgs, isgd, isgs, jdgd, jdgs, jsgd, jsgs, dfcfbfs, dfcosfs; 15 | 16 | for(k = 0; k < Ni[0]; k++){ 17 | dfcfbfs = 0; 18 | dfcosfs = 0; 19 | idam = dam[i[k]]; 20 | isire = sire[i[k]]; 21 | jdam = dam[j[k]]; 22 | jsire = sire[j[k]]; 23 | if((idam == -999) || (isire == -999) || (jdam == -999) || (jsire == -999) || (idam == jdam) || (isire == jsire)){ 24 | i[k] = 0; 25 | } 26 | else{ 27 | idgd = dam[idam]; 28 | idgs = sire[idam]; 29 | isgd = dam[isire]; 30 | isgs = sire[isire]; 31 | jdgd = dam[jdam]; 32 | jdgs = sire[jdam]; 33 | jsgd = dam[jsire]; 34 | jsgs = sire[jsire]; 35 | if((idgd == -999) || (idgs == -999) || (isgd == -999) || (isgs == -999) || (jdgd == -999) || (jdgs == -999) || (jsgd == -999) || (jsgs == -999)){ 36 | i[k] = 0; 37 | } 38 | else{ 39 | if((idgd == jdgd) && (idgs == jdgs) && (isgd == jsgd) && (isgs == jsgs)){ 40 | dfcfbfs = 1; 41 | if(exct[0] == 1){ 42 | if(dam[idgd] != -999){ 43 | if(dam[idgd] == dam[jdgd]){ 44 | dfcfbfs = 0; 45 | } 46 | } 47 | if(sire[idgd] != -999){ 48 | if(sire[idgd] == sire[jdgd]){ 49 | dfcfbfs = 0; 50 | } 51 | } 52 | 53 | if(dam[idgs] != -999){ 54 | if(dam[idgs] == dam[jdgs]){ 55 | dfcfbfs = 0; 56 | } 57 | } 58 | if(sire[idgs] != -999){ 59 | if(sire[idgs] == sire[jdgs]){ 60 | dfcfbfs = 0; 61 | } 62 | } 63 | 64 | if(dam[isgd] != -999){ 65 | if(dam[isgd] == dam[jsgd]){ 66 | dfcfbfs = 0; 67 | } 68 | } 69 | if(sire[isgd] != -999){ 70 | if(sire[isgd] == sire[jsgd]){ 71 | dfcfbfs = 0; 72 | } 73 | } 74 | 75 | if(dam[isgs] != -999){ 76 | if(dam[isgs] == dam[jsgs]){ 77 | dfcfbfs = 0; 78 | } 79 | } 80 | if(sire[isgs] != -999){ 81 | if(sire[isgs] == sire[jsgs]){ 82 | dfcfbfs = 0; 83 | } 84 | } 85 | } 86 | } 87 | if((idgd == jsgd) && (idgs == jsgs) && (isgd == jdgd) && (isgs == jdgs)){ 88 | dfcosfs = 1; 89 | if(exct[0] == 1){ 90 | if(dam[idgd] != -999){ 91 | if(dam[idgd] == dam[jsgd]){ 92 | dfcosfs = 0; 93 | } 94 | } 95 | if(sire[idgd] != -999){ 96 | if(sire[idgd] == sire[jsgd]){ 97 | dfcosfs = 0; 98 | } 99 | } 100 | 101 | if(dam[idgs] != -999){ 102 | if(dam[idgs] == dam[jsgs]){ 103 | dfcosfs = 0; 104 | } 105 | } 106 | if(sire[idgs] != -999){ 107 | if(sire[idgs] == sire[jsgs]){ 108 | dfcosfs = 0; 109 | } 110 | } 111 | 112 | if(dam[isgd] != -999){ 113 | if(dam[isgd] == dam[jdgd]){ 114 | dfcosfs = 0; 115 | } 116 | } 117 | if(sire[isgd] != -999){ 118 | if(sire[isgd] == sire[jdgd]){ 119 | dfcosfs = 0; 120 | } 121 | } 122 | 123 | if(dam[isgs] != -999){ 124 | if(dam[isgs] == dam[jdgs]){ 125 | dfcosfs = 0; 126 | } 127 | } 128 | if(sire[isgs] != -999){ 129 | if(sire[isgs] == sire[jdgs]){ 130 | dfcosfs = 0; 131 | } 132 | } 133 | } 134 | } 135 | if((dfcfbfs == 1) || (dfcosfs == 1)){ 136 | i[k] = 1; 137 | } 138 | else{ 139 | i[k] = 0; 140 | } 141 | } 142 | } 143 | 144 | } 145 | 146 | } 147 | } 148 | -------------------------------------------------------------------------------- /R/grfx.R: -------------------------------------------------------------------------------- 1 | #' Simulated genetic random effects 2 | #' 3 | #' This function simulates effects for random terms in a linear mixed model 4 | #' based on relatedness matrices. The intended purpose is for simulating 5 | #' genetic and environmental effects from a pedigree. 6 | #' 7 | #' The total number of effects simulated will be n*d, where d is the number of 8 | #' columns in the 'G' matrix. The standard normal deviates can be supplied 9 | #' instead of generated within the function when \code{stdnorms != NULL}. The 10 | #' length of this vector must be \code{n*nrow(G)}. 11 | #' 12 | #' Supplied incidence matrices should be n-by-n symmetric matrices or cholesky 13 | #' factorizations that resulted from a call to \code{Matrix::Cholesky()}. For 14 | #' simulated random effects using design matrices, see \code{\link{drfx}}. If 15 | #' no incidence matrix is supplied, \code{incidence = NULL}, the Identity matrix 16 | #' is used, which assumes that all 'n' random effects are independently and 17 | #' identically distributed (default to Identity matrix). 18 | #' 19 | #' See examples for how to make and use a Cholesky factorized incidence matrix, 20 | #' for instance in a Monte Carlo simulation. Whether such an approach results 21 | #' in performance of speed improvements within the Monte Carlo simulation, by 22 | #' avoiding a Cholesky decomposition of a large matrix at each iteration, has 23 | #' not been tested. Setting \code{warn = FALSE} will suppress the warnings that 24 | #' the function is assuming a Cholesky factorization is contained in the object 25 | #' supplied to the \code{incidence} argument. Currently, Cholesky factorizations 26 | #' must inherit from the class \dQuote{CHMfactor}. 27 | #' 28 | #' If G = x, where 'x' is a single number, then 'x' should still be specified 29 | #' as a 1-by-1 matrix (e.g., \code{matrix(x)}). Note, the G-matrix should 30 | #' never have a structure which produces a correlation exactly equal to 1 or 31 | #' -1. Instead, covariances should be specified so as to create a correlation 32 | #' of slightly less than (greater than) 1 (-1). For example: 0.9999 or 33 | #' -0.9999. 34 | #' 35 | #' @param n The number of individuals for which to simulate effects 36 | #' @param G The variance-covariance matrix to model the effects after 37 | #' @param incidence A matrix of the covariance structure of the 'n' individuals 38 | #' or the Cholesky factorization of class \code{CHMfactor} for this structure. 39 | #' @param output Format for the output 40 | #' @param stdnorms Standard normal deviates to use 41 | #' @param warn Should a warning message be produced when the function interprets 42 | #' what to do based on the object class supplied to \code{incidence} 43 | #' 44 | #' @return The random effects coerced to be in the format specified by output. 45 | #' The default is a "matrix". 46 | #' @author \email{matthewwolak@@gmail.com} 47 | #' @seealso \code{\link[MCMCglmm]{MCMCglmm}}, \code{\link{drfx}}, 48 | #' \code{\link{makeA}}, \code{\link{makeAA}}, \code{\link{makeD}}, 49 | #' \code{\link{makeDomEpi}}, \code{\link{makeDsim}}, \code{\link{makeS}} 50 | #' @examples 51 | #' 52 | #' # Create additive genetic breeding values for 2 uncorrelated traits 53 | #' # with different additive genetic variances 54 | #' A <- makeA(warcolak[1:200, 1:3]) 55 | #' Gmat <- matrix(c(20, 0, 0, 10), 2, 2) 56 | #' breedingValues <- grfx(n = 200, G = Gmat, incidence = A) 57 | #' 58 | #' # Now with a user supplied set of standard normal deviates 59 | #' snorms <- rnorm(nrow(warcolak[1:200,]) * ncol(Gmat)) 60 | #' breedingValues2a <- grfx(n = 200, G = Gmat, incidence = A, stdnorms = snorms) 61 | #' breedingValues2b <- grfx(n = 200, G = Gmat, incidence = A, stdnorms = snorms) 62 | #' identical(breedingValues2a, breedingValues2b) #<-- TRUE 63 | #' var(breedingValues2a) 64 | #' var(breedingValues2b) 65 | #' 66 | #' # User supplied Cholesky factorization of the incidence matrix from above 67 | #' cA <- Cholesky(A, LDL = FALSE, super = FALSE) 68 | #' inherits(cA, "CHMfactor") #<-- TRUE 69 | #' breedingValues3 <- grfx(n = 200, G = Gmat, incidence = cA, stdnorms = snorms) 70 | #' all.equal(breedingValues2a, breedingValues3) #<-- TRUE 71 | #' @export 72 | grfx <- function(n, G, incidence = NULL, output = "matrix", stdnorms = NULL, 73 | warn = TRUE){ 74 | d <- nrow(G) 75 | if(d > 1 && all(G == G[1,1])){ 76 | warning("variance-covariance matrix 'G' may have caused 'chol.default(G)' error. If so, consider subtracting 0.0001 from the covariances to make correlations < 1 or >-1") 77 | } 78 | 79 | Mg <- as(as(chol(G), "triangularMatrix"), "CsparseMatrix") 80 | 81 | if(is.null(incidence)){ 82 | chol_incidence <- Diagonal(n, 1) 83 | if(warn) warning("Incidence matrix used = Identity matrix") 84 | } else{ 85 | if(inherits(incidence, "CHMfactor")){ 86 | if(warn) warning("Object given to incidence inherits from class 'CHMfactor'. Object in incidence being used as a Cholesky factor of an incidence matrix") 87 | chol_incidence <- Reduce("%*%", 88 | expand2(incidence, LDL = FALSE)[c("P1.", "L.", "P1")]) 89 | } else chol_incidence <- chol(incidence) 90 | } 91 | 92 | M <- kronecker(chol_incidence, Mg) 93 | if(is.null(stdnorms)){ 94 | Z <- Matrix(rnorm(n*d), nrow = 1) 95 | } else{ 96 | if(length(stdnorms) != n*d){ 97 | stop("length(stdnorms) must be equal to 'n' times the order of 'G'") 98 | } 99 | Z <- Matrix(stdnorms, nrow = 1) 100 | } 101 | X <- Matrix((Z %*% M)@x, ncol = d, byrow = TRUE) 102 | 103 | return(as(X, output)) 104 | } 105 | 106 | -------------------------------------------------------------------------------- /R/numPed.R: -------------------------------------------------------------------------------- 1 | ################################################ 2 | #Adapted from part of the 'inverseA' function 3 | # written by Jarrod Hadfield 4 | #in the 'MCMCglmm' package 5 | ################################################ 6 | 7 | 8 | 9 | #' Integer Format Pedigree 10 | #' 11 | #' Conversion, checking, and row re-ordering of a pedigree in integer form of 12 | #' class \sQuote{numPed}. 13 | #' 14 | #' Missing parents (e.g., base population) should be denoted by either 'NA', 15 | #' '0', '-998', or '*'. 16 | #' 17 | #' Individuals must appear in the ID column in rows preceding where they 18 | #' appear in either the Dam or Sire column. See the 19 | #' \code{\link[nadiv]{prepPed}} function if this is not the case. 20 | #' 21 | #' If pedigree inherits the class "numPed" (from a previous call to 22 | #' \code{numPed()}) and \code{check = TRUE}, the checks are skipped. If 23 | #' \code{check = FALSE} any pedigree will be transformed into a pedigree 24 | #' consisting of integers and missing values denoted by '-998'. 25 | #' 26 | #' Based on code from the \code{MCMCglmm} package 27 | #' 28 | #' @aliases numPed ronPed 29 | #' @param pedigree A three column pedigree object, where the columns correspond 30 | #' to: ID, Dam, & Sire 31 | #' @param check A logical argument indicating if checks on the validity of the 32 | #' pedigree structure should be made, but see Details 33 | #' @param x A pedigree of class \sQuote{\code{numPed}} 34 | #' @param i,\dots Index specifying elements to extract or replace: see 35 | #' \code{\link[base]{[}} 36 | #' 37 | #' @return An S3 object of class \dQuote{numPed} representing the pedigree, 38 | #' where individuals are now numbered from 1 to \code{n} and unknown parents 39 | #' are assigned a value of \sQuote{-998}. 40 | #' @author \email{matthewwolak@@gmail.com} 41 | #' @seealso \code{\link[nadiv]{prepPed}}, \code{\link[MCMCglmm]{MCMCglmm}}, 42 | #' \code{\link[base]{[}} 43 | #' @examples 44 | #' 45 | #' (nPed <- numPed(Mrode2)) 46 | #' class(nPed) 47 | #' 48 | #' # re-order and retain class 'numPed' 49 | #' ronPed(nPed, order(nPed[, 2], nPed[, 3])) 50 | #' class(nPed) 51 | #' 52 | #' @export 53 | numPed <- function(pedigree, check = TRUE){ 54 | if(!inherits(pedigree, "numPed") && check){ 55 | if(any(d0 <- pedigree[, 2] == 0, na.rm = TRUE)){ 56 | pedigree[which(d0), 2] <- NA 57 | warning("Zero in the dam column interpreted as a missing parent") 58 | } 59 | if(any(s0 <- pedigree[, 3] == 0, na.rm = TRUE)){ 60 | pedigree[which(s0), 3] <- NA 61 | warning("Zero in the sire column interpreted as a missing parent") 62 | } 63 | if(any(d998 <- pedigree[, 2] == -998, na.rm = TRUE)){ 64 | pedigree[which(d998), 2] <- NA 65 | if(!inherits(pedigree, "numPed")) warning("-998 in the dam column interpreted as a missing parent") 66 | } 67 | if(any(s998 <- pedigree[, 3] == -998, na.rm = TRUE)){ 68 | pedigree[which(s998), 3] <- NA 69 | if(!inherits(pedigree, "numPed")) warning("-998 in the sire column interpreted as a missing parent") 70 | } 71 | if(any(dast <- pedigree[, 2] == "*", na.rm = TRUE)) pedigree[which(dast), 2] <- NA 72 | if(any(sast <- pedigree[, 3] == "*", na.rm = TRUE)) pedigree[which(sast), 3] <- NA 73 | 74 | if(all(is.na(pedigree[, 2])) & all(is.na(pedigree[, 3]))){ 75 | stop("All dams and sires are missing") 76 | } 77 | if(dim(pedigree)[2] != 3){ 78 | stop("pedigree must have three columns: ID, Dam and Sire") 79 | } 80 | if(sum((na.omit(pedigree[, 2]) %in% pedigree[, 1]) == FALSE) > 0 & any(is.na(pedigree[, 2]) == FALSE)){ 81 | stop("individuals appearing as dams but not in pedigree: first use the 'prepPed' function") 82 | } 83 | if(sum((na.omit(pedigree[, 3]) %in% pedigree[, 1]) == FALSE) > 0 & any(is.na(pedigree[, 3]) == FALSE)){ 84 | stop("individuals appearing as sires but not in pedigree: first use the 'prepPed' function") 85 | } 86 | if(any(duplicated(pedigree[, 1]))){ 87 | stop("some individuals appear more than once in the pedigree") 88 | } 89 | } 90 | nPed <- matrix(as.integer(-998), dim(pedigree)[1], dim(pedigree)[2]) 91 | nPed[, 1] <- as.integer(seq(1, dim(pedigree)[1], 1)) 92 | nPed[, 2] <- match(pedigree[, 2], pedigree[, 1], nomatch = -998) 93 | nPed[, 3] <- match(pedigree[, 3], pedigree[, 1], nomatch = -998) 94 | dnmiss <- which(nPed[, 2] != -998) 95 | snmiss <- which(nPed[, 3] != -998) 96 | bnmiss <- which(nPed[, 2] != -998 & nPed[, 3] != -998) 97 | if(check){ 98 | if(length(intersect(nPed[, 2][dnmiss], nPed[, 3][snmiss])) > 0 & (length(dnmiss) > 0) & (length(snmiss) > 0)){ 99 | warning("Dams appearing as Sires - assumed selfing in pedigree") 100 | } 101 | if(any(nPed[, 2][dnmiss] > nPed[, 1][dnmiss]) & (length(dnmiss) > 0)){ 102 | stop("Offspring appearing before their dams: first use the 'prepPed' function") 103 | } 104 | if(any(nPed[, 3][snmiss] > nPed[, 1][snmiss]) & (length(snmiss) > 0)){ 105 | stop("Offspring appearing before their Sires: first use the 'prepPed' function") 106 | } 107 | if(any((nPed[, 1] - nPed[, 2]) == 0)){ 108 | stop("Individual(s):", nPed[which((nPed[, 1] - nPed[, 2]) == 0), 1], "\n", 109 | "Individual appearing as its own Dam") 110 | } 111 | if(any((nPed[, 1] - nPed[, 3]) == 0)){ 112 | stop("Individual(s):", nPed[which((nPed[, 1] - nPed[, 3]) == 0), 1], "\n", 113 | "Individual appearing as its own Sire") 114 | } 115 | } 116 | nPed <- structure(nPed, class = "numPed") 117 | nPed 118 | } 119 | 120 | 121 | 122 | 123 | 124 | 125 | # re-ordering rows of object with class 'numPed' 126 | 127 | #' @rdname numPed 128 | #' @export 129 | ronPed <- function(x, i, ...){ 130 | r <- structure(unclass(x)[i, ,...], class = "numPed") 131 | r 132 | } 133 | 134 | 135 | -------------------------------------------------------------------------------- /R/makeDomEpi.R: -------------------------------------------------------------------------------- 1 | #' Creates the additive by dominance and dominance by dominance epistatic 2 | #' genetic relationship matrices 3 | #' 4 | #' Given a pedigree, the matrix of additive by dominance (AD) genetic 5 | #' relatedness, dominance by dominance (DD) genetic relatedness, or both are 6 | #' returned. 7 | #' 8 | #' Missing parents (e.g., base population) should be denoted by either 'NA', 9 | #' '0', or '*'. 10 | #' 11 | #' Because of the computational demands of constructing the D matrix (see 12 | #' \code{\link{makeD}}), this function allows for the inverses that are derived 13 | #' from the D matrix (i.e., D-inverse, AD-inverse, and DD-inverse)to be 14 | #' constructed at the same time. This way, the D matrix will only have to be 15 | #' constructed once for use in the three separate genetic relatedness inverse 16 | #' matrices that depend upon it. However, using the \code{output} and 17 | #' \code{invertD} options in different combinations will ensure that only the 18 | #' desired matrix inverses are constructed. 19 | #' 20 | #' \code{parallel} = TRUE should only be used on Linux or Mac OSes (i.e., not 21 | #' Windows). 22 | #' 23 | #' Both the AD and DD matrix are computed from the Hadamard product of the 24 | #' respective matrices (see also, \code{\link{makeAA}}). 25 | #' 26 | #' @param pedigree A pedigree where the columns are ordered ID, Dam, Sire 27 | #' @param output Character(s) denoting which matrix and its inverse is to be 28 | #' constructed. 29 | #' @param parallel A logical indicating whether or not to use parallel 30 | #' processing. Note, this may only be available on Mac and Linux operating 31 | #' systems. 32 | #' @param invertD A logical indicating whether or not to invert the D matrix 33 | #' @param det A logical indicating whether or not to return the determinants 34 | #' for the epistatic relationship matrices 35 | #' 36 | #' @return All of the following will be returned. However, the values of the 37 | #' \code{output} and \code{invertD} options passed to the function will 38 | #' determine which of the following are not NULL objects within the list: 39 | #' \describe{ 40 | #' \item{D }{the D matrix in sparse matrix form} 41 | #' \item{logDetD }{the log determinant of the D matrix} 42 | #' \item{AD }{the AD matrix in sparse matrix form} 43 | #' \item{logDetAD }{the log determinant of the AD matrix} 44 | #' \item{DD }{the DD matrix in sparse matrix form} 45 | #' \item{logDetDD }{the log determinant of the DD matrix} 46 | #' \item{Dinv }{the inverse of the D matrix in sparse matrix form} 47 | #' \item{ADinv }{the inverse of the AD matrix in sparse matrix form} 48 | #' \item{DDinv }{the inverse of the DD matrix in sparse matrix form} 49 | #' \item{listDinv }{the three column form of the non-zero elements for the 50 | #' inverse of the D matrix} 51 | #' \item{listADinv }{the three column form of the non-zero elements for the 52 | #' inverse of the AD matrix} 53 | #' \item{listDDinv }{the three column form of the non-zero elements for the 54 | #' inverse of the DD matrix} 55 | #' } 56 | #' @author \email{matthewwolak@@gmail.com} 57 | #' @seealso \code{\link{makeA}}, \code{\link{makeD}}, \code{\link{makeAA}} 58 | #' @examples 59 | #' 60 | #' Boutput <- makeDomEpi(Mrode9, output = "b", parallel = FALSE, invertD = FALSE) 61 | #' str(Boutput) 62 | #' 63 | #' DADoutput <- makeDomEpi(Mrode9, output = "AD", parallel = FALSE, invertD = TRUE) 64 | #' str(DADoutput) 65 | #' 66 | #' @export 67 | makeDomEpi <- function(pedigree, output = c("AD", "DD", "both"), 68 | parallel = FALSE, invertD = FALSE, det = TRUE) 69 | { 70 | type <- match.arg(output) 71 | Dout <- makeD(pedigree, parallel = parallel, invertD = invertD, returnA = TRUE) 72 | 73 | if(type == "AD"){ 74 | AD <- Dout$A * Dout$D 75 | if(det) logDetAD <- determinant(AD, logarithm = TRUE)$modulus[1] else logDetAD <- NULL 76 | ADinv <- as(solve(AD), "dgCMatrix") 77 | ADinv@Dimnames <- list(as.character(pedigree[, 1]), NULL) 78 | listADinv <-sm2list(ADinv, rownames=pedigree[,1], colnames=c("row", "column", "ADinverse")) 79 | DD <- NULL 80 | logDetDD <- NULL 81 | DDinv <- NULL 82 | listDDinv <- NULL 83 | } 84 | 85 | if(type == "DD"){ 86 | DD <- Dout$D * Dout$D 87 | if(det) logDetDD <- determinant(DD, logarithm = TRUE)$modulus[1] else logDetDD <- NULL 88 | DDinv <- as(solve(DD), "dgCMatrix") 89 | DDinv@Dimnames <- list(as.character(pedigree[, 1]), NULL) 90 | listDDinv<-sm2list(DDinv, rownames=pedigree[,1], colnames=c("row", "column", "DDinverse")) 91 | AD <- NULL 92 | logDetAD <- NULL 93 | ADinv <- NULL 94 | listADinv <- NULL 95 | } 96 | 97 | if(type == "both"){ 98 | AD <- Dout$A * Dout$D 99 | ADinv <- Matrix(solve(AD), sparse = TRUE, doDiag = FALSE) 100 | listADinv <- sm2list(ADinv, rownames = pedigree[, 1], 101 | colnames = c("row", "column", "ADinverse")) 102 | ADinv <- as(ADinv, "dgCMatrix") 103 | ADinv@Dimnames <- list(as.character(pedigree[, 1]), NULL) 104 | DD <- Dout$D * Dout$D 105 | if(det){ 106 | logDetAD <- determinant(AD, logarithm = TRUE)$modulus[1] 107 | logDetDD <- determinant(DD, logarithm = TRUE)$modulus[1] 108 | } else{ logDetAD <- logDetDD <- NULL} 109 | DDinv <- as(solve(DD), "dgCMatrix") 110 | DDinv@Dimnames <- list(as.character(pedigree[, 1]), NULL) 111 | listDDinv<-sm2list(DDinv, rownames=pedigree[,1], colnames=c("row", "column", "DDinverse")) 112 | } 113 | return(list(D=Dout$D, logDetD = Dout$logDet, AD=AD, logDetAD = logDetAD, DD=DD, logDetDD = logDetDD, Dinv=Dout$Dinv, ADinv=ADinv, DDinv=DDinv, listDinv=Dout$listDinv, listADinv=listADinv, listDDinv=listDDinv)) 114 | 115 | } 116 | 117 | -------------------------------------------------------------------------------- /man/makeDsim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makeDsim.R, R/makeSdsim.R 3 | \name{makeDsim} 4 | \alias{makeDsim} 5 | \alias{makeSdsim} 6 | \title{Create the dominance genetic relationship matrix through an iterative 7 | (simulation) process} 8 | \usage{ 9 | makeDsim( 10 | pedigree, 11 | N, 12 | parallel = FALSE, 13 | ncores = getOption("mc.cores", 2L), 14 | invertD = TRUE, 15 | calcSE = FALSE, 16 | returnA = FALSE, 17 | verbose = TRUE 18 | ) 19 | 20 | makeSdsim( 21 | pedigree, 22 | heterogametic, 23 | N, 24 | DosageComp = c(NULL, "ngdc", "hori", "hedo", "hoha", "hopi"), 25 | parallel = FALSE, 26 | ncores = getOption("mc.cores", 2L), 27 | invertSd = TRUE, 28 | calcSE = FALSE, 29 | returnS = FALSE, 30 | verbose = TRUE 31 | ) 32 | } 33 | \arguments{ 34 | \item{pedigree}{A pedigree with columns organized: ID, Dam, Sire. For use 35 | with \code{makeSdsim}, a fourth column indicates the sex of each individual 36 | in the pedigree.} 37 | 38 | \item{N}{The number of times to iteratively trace alleles through the 39 | pedigree} 40 | 41 | \item{parallel}{A logical indicating whether or not to use parallel 42 | processing. Note, this may only be available for Mac and Linux operating 43 | systems.} 44 | 45 | \item{ncores}{The number of cpus to use when constructing the dominance 46 | relatedness matrix. Default is all available.} 47 | 48 | \item{invertD, invertSd}{A logical indicating whether or not to invert the D 49 | or Sd matrix} 50 | 51 | \item{calcSE}{A logical indicating whether or not the standard errors for 52 | each coefficient of fraternity should be calculated} 53 | 54 | \item{returnA, returnS}{Logical, indicating if the numerator relationship 55 | matrix (A or S) should be stored and returned.} 56 | 57 | \item{verbose}{Logical, indicating if progress messages should be displayed.} 58 | 59 | \item{heterogametic}{Character indicating the label corresponding to the 60 | heterogametic sex used in the "Sex" column of the pedigree} 61 | 62 | \item{DosageComp}{A character indicating which model of dosage compensation. 63 | If \code{NULL} then the \dQuote{ngdc} model is assumed.} 64 | } 65 | \value{ 66 | a \code{list}: 67 | \describe{ 68 | \item{A,S }{the A or S matrix in sparse matrix form} 69 | \item{D,Sd }{the approximate D or Sd matrix in sparse matrix form} 70 | \item{logDetD,logDetSd }{the log determinant of the D or Sd matrix} 71 | \item{Dinv,Sdinv }{the inverse of the approximate D or approximate Sd 72 | matrix in sparse matrix form} 73 | \item{listDinv,listSdinv }{the three column form of the non-zero elements 74 | for the inverse of the approximate D matrix or the inverse of the 75 | approximate Sd matrix} 76 | \item{Dsim,Sdsim }{the simulated D or Sd matrix in sparse matrix form} 77 | \item{logDetDsim,logDetSdsim }{the log determinant of the simulated D or 78 | simulated Sd matrix} 79 | \item{Dsiminv,Sdsiminv }{the inverse of the simulated D or simulated Sd 80 | matrix in sparse matrix form} 81 | \item{listDsim,listSdsim }{the three column form of the non-zero and 82 | non-self elements for the simulated D or simulated Sd matrix} 83 | \item{listDsiminv,listSdsiminv }{the three column form of the non-zero 84 | elements for the inverse of the simulated D or the inverse of the 85 | simulated Sd matrix} 86 | } 87 | } 88 | \description{ 89 | Alleles are explicitly traced through a pedigree to obtain coefficients of 90 | fraternity between pairs of individuals (the probability of sharing both 91 | alleles identical by descent) - for either autosomes or sex chromosomes. 92 | This is accomplished in an iterative process to account for the various 93 | routes by which an allele will progress through a pedigree due to Mendelian 94 | sampling at either autosomes or sex chromosomes. The autosomal case is an 95 | implementation of the simulation approach of Ovaskainen et al. (2008). 96 | } 97 | \details{ 98 | Missing parents (e.g., base population) should be denoted by either 'NA', 99 | '0', or '*'. 100 | 101 | \code{parallel} = TRUE should only be used on Linux or Mac operating systems 102 | (i.e., not Windows). 103 | 104 | Ovaskainen et al. (2008) indicated that the method of calculating the D 105 | matrix (see \code{\link{makeD}}) is only an approximation. They proposed a 106 | simulation method that is implemented here. This should be more 107 | appropriate, especially when inbreeding occurs in the pedigree. 108 | 109 | The objects \code{listDsim} and \code{listSdsim} will list both the 110 | approximate values (returned from \code{\link{makeD}} or 111 | \code{\link{makeSd}}) as well as the simulated values. If \code{calcSE} is 112 | TRUE, these values will be listed in \code{listDsim} or \code{listSdsim}. 113 | } 114 | \note{ 115 | This simulation can take a long time for large pedigrees (a few 116 | thousand and higher) and large values of \code{N} (one thousand and 117 | higher). If unsure, it is advisable to start with a lower \code{N} and 118 | gradually increase to obtain a sense of the time required to execute a 119 | desired \code{N}. 120 | } 121 | \examples{ 122 | 123 | simD <- makeDsim(Mrode9, N = 1000, parallel = FALSE, 124 | invertD = TRUE, calcSE = TRUE)$listDsim 125 | 126 | simSd <- makeSdsim(FG90, heterogametic = "0", N = 1000, parallel = FALSE, 127 | invertSd = TRUE, calcSE = TRUE)$listSdsim 128 | } 129 | \references{ 130 | Ovaskainen, O., Cano, J.M., & Merila, J. 2008. A Bayesian 131 | framework for comparative quantitative genetics. Proceedings of the Royal 132 | Society B 275, 669-678. 133 | } 134 | \seealso{ 135 | \code{\link{makeD}}, \code{\link{makeSd}} 136 | } 137 | \author{ 138 | \email{matthewwolak@gmail.com} 139 | } 140 | -------------------------------------------------------------------------------- /src/diif.cc: -------------------------------------------------------------------------------- 1 | #include "nadivcc.h" 2 | 3 | // R-interface/wrapper for M&L routine 4 | extern "C"{ 5 | 6 | void diif( 7 | int *dam, 8 | int *sire, 9 | double *f, 10 | double *dii, 11 | int *n, 12 | int *g, 13 | int *fmiss 14 | ){ 15 | 16 | // Meuwissen and Luo 1992 algorithm to obtain f and dii values 17 | ml(dam, sire, f, dii, n[0], g[0], fmiss[0]); 18 | } 19 | } 20 | 21 | 22 | 23 | 24 | 25 | 26 | // R-interface/wrapper for mutational effects M&L routine 27 | extern "C"{ 28 | 29 | void mdiif( 30 | int *dam, 31 | int *sire, 32 | double *h, 33 | double *dii, 34 | int *n 35 | ){ 36 | 37 | // Meuwissen and Luo 1992 algorithm to obtain f and dii values 38 | //// Extends Wray 1990; Casellas and Medrano 2008 39 | mml(dam, sire, h, dii, n[0]); 40 | } 41 | } 42 | 43 | 44 | 45 | 46 | 47 | 48 | //////////////////////////////////////////////// 49 | // based on M&L 1992 algorithm (for `ainvml`) 50 | // as presented in Mrode 2005 51 | //// replaces elements of f and dii with calculated values in place 52 | void ml(int *dam, int *sire, 53 | double *f, double *dii, 54 | int n, int g, int fmiss 55 | ){ 56 | 57 | int j, k, h, cnt, sj, dj; 58 | double ai; 59 | double *AN = new double[2*n]; 60 | double *li = new double[n]; 61 | 62 | for(k = g; k < n; ++k){ 63 | li[k] = 0.0; // set l to zero 64 | } 65 | for(k = g; k < n; ++k){ 66 | AN[k] = -1; // set AN to "empty" 67 | //// (since lowest ID is 0, make empty with 1 less than it) 68 | } 69 | 70 | for(k = g; k < n; ++k){ // iterate through each row of l 71 | dii[k] = 0.5 - 0.25*(f[dam[k]] + f[sire[k]]); 72 | 73 | if(k >= fmiss + g){ // only do below if f coefficients NOT supplied by user 74 | if((k > 0) && (dam[k] == dam[k-1]) && (sire[k] == sire[k-1])){ 75 | f[k] = f[k-1]; 76 | } 77 | else { 78 | li[k] = 1.0; // set l_ii to one 79 | ai = 0.0; // set a_ii to zero 80 | j = k; 81 | cnt = 0; 82 | while(j >= 0){ 83 | sj = sire[j]; 84 | dj = dam[j]; 85 | 86 | if((sj >= g) && (sj != n)){ 87 | AN[cnt] = sj; 88 | li[sj] += 0.5*li[j]; 89 | ++cnt; 90 | } 91 | 92 | if((dj >= g) && (dj != n)){ 93 | AN[cnt] = dj; 94 | li[dj] += 0.5*li[j]; 95 | ++cnt; 96 | } 97 | 98 | ai += li[j]*li[j]*dii[j]; 99 | j -= n; // set to empty-value lower than all known identities 100 | 101 | for(h = 0; h < cnt; ++h){ // find eldest individual 102 | if(AN[h] > j){ 103 | j = AN[h]; 104 | } 105 | } 106 | for(h = 0; h < cnt; ++h){ // delete duplicates 107 | if(AN[h] == j){ 108 | AN[h] -= n; // set to empty-value lower than all known identities 109 | } 110 | } 111 | } // end of while 112 | 113 | f[k] = ai - 1.0; 114 | 115 | for(h = 0; h <= k; ++h){ 116 | li[h] = 0.0; // reset l to zero 117 | } 118 | 119 | } // end else for checking if k has same parents as k-1 120 | } // end if f missing 121 | } // end of for 122 | delete[] AN; 123 | delete[] li; 124 | 125 | } 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | // Mutational effects inbreeding and dii 142 | //// based on Meuwissen and Luo 1992 algorithm to obtain f and dii values 143 | //// Extends Wray 1990; Casellas and Medrano 2008 144 | 145 | void mml(int *dam, int *sire, 146 | double *h, double *dii, 147 | int n 148 | ){ 149 | 150 | int j, k, m, p, q, cnt, sj, dj; 151 | double g; 152 | double *AN = new double[2*n]; 153 | double *li = new double[n]; 154 | double *u = new double[n]; 155 | 156 | for(k = 0; k < n; ++k){ 157 | li[k] = 0.0; // set l to zero 158 | AN[k] = -1; // set AN to "empty" 159 | //// (since lowest ID is 0, make empty with 1 less than it) 160 | u[k] = 0.0; // set u to zero 161 | } 162 | 163 | 164 | for(k = 0; k < n; ++k){ // iterate through each row of L 165 | 166 | // intialize/guess and change if different 167 | //// if sire < dam OR sire=dam=UNKNOWN 168 | p = sire[k]; 169 | q = dam[k]; 170 | //// otherwise, change so p is always < q (unless p=q) 171 | if(sire[k] > dam[k]){ 172 | p = dam[k]; 173 | q = sire[k]; 174 | } 175 | 176 | if(p != n && q != n){ 177 | dii[k] = 0.25 * (u[p] + u[q]) - 0.5 * (h[p] + h[q]) + 1.0; 178 | } 179 | if(p < n && q == n) dii[k] = 0.25*u[p] - 0.5*h[p] + 0.5; 180 | // because p <= q then if p=n=missing ID, THEN so will q 181 | if(p == n) dii[k] = 1.0; 182 | 183 | 184 | li[k] = 1.0; // set L_ii to one 185 | j = k; 186 | cnt = 0; 187 | g = 0.0; 188 | while(j >= 0){ 189 | sj = sire[j]; 190 | dj = dam[j]; 191 | 192 | if(sj != n){ 193 | AN[cnt] = sj; 194 | li[sj] += 0.5 * li[j]; 195 | ++cnt; 196 | } 197 | 198 | if(dj != n){ 199 | AN[cnt] = dj; 200 | li[dj] += 0.5 * li[j]; 201 | ++cnt; 202 | } 203 | 204 | u[k] += li[j] * li[j] * dii[j]; 205 | g += li[j]; 206 | 207 | j -= n; // set to empty, value lower than all known identities 208 | 209 | for(m = 0; m < cnt; ++m){ // find the eldest individual 210 | if(AN[m] > j){ 211 | j = AN[m]; 212 | } 213 | } 214 | for(m = 0; m < cnt; ++m){ // delete duplicates 215 | if(AN[m] == j){ 216 | AN[m] -= n; // set to negative value so never `AN[m]>j` in above 217 | } 218 | } 219 | 220 | } // end of while 221 | 222 | h[k] = u[k] - g; 223 | 224 | for(m = 0; m <= k; ++m) li[m] = 0.0; // reset li to zero 225 | 226 | } // end of for k 227 | 228 | delete[] AN; 229 | delete[] li; 230 | delete[] u; 231 | 232 | } 233 | 234 | --------------------------------------------------------------------------------