Simple examples in Founders.rmd

R/AlphaPart.R

@@ -43,6 +43,9 @@
 #'   see arguments \code{colId}, \code{colFid}, \code{colMid},
 #'   \code{colPath}, and \code{colBV}; see also details about the
 #'   validity of pedigree.
+#' @param UPGname Character, a string pattern used to define the nomenclature
+#'   for identifying unknown parent groups. Default is "UPG",
+#'   where unknown parent groups would be identified with "UPG1", "UPG2", etc.
 #' @param pathNA Logical, set dummy path (to "UNKNOWN") where path
 #'   information is unknown (missing).
 #' @param recode Logical, internally recode individual, father and,
@@ -153,6 +156,7 @@
 #' @export
 AlphaPart <- function(
   x,
+  UPGname = "UPG",
   pathNA = FALSE,
   recode = TRUE,
   unknown = NA,
@@ -259,25 +263,62 @@ AlphaPart <- function(
     recode <- TRUE
     x <- x[order(orderPed(ped = x[, c(colId, colFid, colMid)])), ]
   }
-
-  # TODO: Strip out all centering and scaling in favour of
-  #       the incoming metafounder / UPG code plans #22
-  #       https://github.com/AlphaGenes/AlphaPart/issues/22
-  # We should likely just remove all this code in the if (FALSE) block
-  if (FALSE) {
-    # Centering  to make founders has mean zero
-    controlvals <- getScale()
-    if (!missing(scaleEBV)) {
-      controlvals[names(scaleEBV)] <- scaleEBV
+
+  ## Test for presence of unknown parent groups, labeled "UPG"
+  test <- grepl(UPGname, x[, colId]) | grepl(UPGname, x[, colFid]) | grepl(UPGname, x[, colMid])
+  if (any(test)){
+    ## Test whether each unknown parent group in the pedigree has it's own record.
+    founderTest <- x[!grepl(UPGname, x[, colId]) & (grepl(UPGname, x[, colFid]) | grepl(UPGname, x[, colMid])), c(colFid, colMid)]
+    test <- apply(founderTest, 2, function(z) z %in% x[, colId])
+    if (!all(test)) {
+      stop("Each unknown parent group in the pedigree must have its own record. See vignette founders.Rmd")
     }
-    if (controlvals$center == TRUE | controlvals$scale == TRUE) {
-      x[, colBV] <- sGV(
-        y = x[, c(colId, colFid, colMid, colBV)],
-        center = controlvals$center,
-        scale = controlvals$scale,
-        recode = recode,
-        unknown = unknown
-      )
+    ## Test that each unknown parent group has no duplicated records
+    test <- duplicated(x[grepl(UPGname, x[, colId]), colId]) 
+    if (any(test)) {
+      stop("Each unknown parent group in the pedigree must have only one record. See vignette founders.Rmd")
+    }
+    ## Test whether each unknown parent group record has unknown parents
+    test <- unlist(x[grepl(UPGname, x[, colId]), c(colFid, colMid)]) %in% c(unknown, NA, 0, "")
+    if (!all(test)) {
+      stop("Each unknown parent group record must have unknown parents. See vignette founders.Rmd")
+    }
+    ## Test whether each unknown parent group has their own path defined
+    test <- x[grepl(UPGname, x[, colId]), colId] == x[grepl(UPGname, x[, colId]), colPath]
+    if(!all(test)){
+      stop("Each unknown parent group in the pedigree must have its own path defined. See vignette founders.Rmd")
+    }
+    ## Test whether each unknown parent group has a breeding value defined
+    ## BV could be 0, so check no NAs only or no ""
+    test <- is.na(x[grepl(UPGname, x[, colId]), colBV]) | x[grepl(UPGname, x[, colId]), colBV] == ""
+    if (any(test)) {
+      stop("Each unknown parent group in the pedigree must have a breeding value defined. See vignette founders.Rmd")
+    }
+    ## Test whether each unknown parent group breeding value is equal (or close to) the mean of their founder breeding values
+    ## Gives a warning only.
+    UPG <- x[grepl(UPGname, x[, colId]), colId]
+    for (m in UPG){
+      foundersBV <- sapply(colBV, function(col) 
+        {sum(x[x[,colId] != m & x[,colFid] == m | x[,colMid] == m, col], 
+             na.rm = TRUE)})
+      noFounders <- nrow(x[x[,colId] != m & x[,colFid] == m & x[,colMid] == m, ]) + 
+        0.5*nrow(x[x[,colId] != m & x[,colFid] == m & x[,colMid] != m, ]) + # to consider half-founders
+        0.5*nrow(x[x[,colId] != m & x[,colFid] != m & x[,colMid] == m, ])
+      test <- abs(x[x[, colId] == m, colBV] - foundersBV/noFounders) > 1e-6
+      if (any(test)) {
+        warning(paste("The breeding value for all unknown parent groups is expected to be equal to the mean breeding value of their grouped founders. \n", 
+                      m, " does not meet this expectation. See vignette founders.Rmd", sep = ""))
+      }
+    }
+  } else {
+    ## Test for if the mean of the founders are zero (ignoring half-founders)
+    test <- sapply(colBV, function(col) {
+      mean(x[x[,colFid] %in% c(unknown, NA, 0, "") & x[,colMid] %in% c(unknown, NA, 0, ""), col], na.rm = TRUE)
+    })
+    if (any(abs(test) > 1e-6)) {
+      warning("The mean of the founders breeding values is not zero for atleast 
+              one of the traits. Consider centering or using unknown parent 
+              groups. See vignette founders.Rmd for more.")
     }
   }
 
@@ -448,7 +489,8 @@ AlphaPart <- function(
       nG = nG,
       ped = y,
       P = as.integer(P),
-      Px = as.integer(cumsum(c(0, rep(nP, nT - 1))))
+      Px = as.integer(cumsum(c(0, rep(nP, nT - 1)))),
+      g = as.integer(g)
     )
   }
 

R/methods.R

@@ -685,7 +685,7 @@ plot.summaryAlphaPart <-
         linetype = path,
         geom = "line"
       )
-      p <- p + geom_line(size = lineSize)
+      p <- p + geom_line(linewidth = lineSize)
       p <- p + xlab(label = ifelse(is.null(xlab), by, xlab))
       p <- p + ylab(label = ifelse(is.null(ylab), lT[i], ylab[i])) # lT[i] is the TRAIT!!!
       if (!is.null(xlim)) {

tests/testthat/test-plotSummaryAlphaPart.R

@@ -10,7 +10,7 @@ test_that("Test plotSummary.AlphaPart", {
                      gen=c(  1,   1,   2,   2,   3,   3))
 
   ## Partition additive genetic values
-  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"), center = FALSE)
+  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"))
   sum <- summary(tmp)
   expect_error(plot.summaryAlphaPart(sum), "output is provided only when the 'by' argument is defined on the 'summary' function")
 

tests/testthat/test-printAlphaPart.R

@@ -9,10 +9,10 @@ test_that("Test print.AlphaPart", {
                       trt1=c(100, 120, 115, 130, 125, 125),
                       trt2=c(100, 110, 105, 100,  85, 110),
                       gen=c(  1,   1,   2,   2,   3,   3))
-  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"), center = FALSE)
+  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"))
   ## Partition additive genetic values
-  expect_equal(print(tmp$trt1[,"trt1_w"], digits=1), c(100,120,5,130,2.5,125))
-  expect_equal(print.AlphaPart(AlphaPart(x=ped, colBV=c("trt1", "trt2"), center = FALSE)),NULL)
-  expect_equal(print.AlphaPart(AlphaPart(x=ped, colBV=c("trt1", "trt2"), center = TRUE)),NULL)
+  expect_equal(print(tmp$trt1[,"trt1_ms"], digits=1), c(100,120,5,130,2.5,125))
+  expect_equal(print.AlphaPart(AlphaPart(x=ped, colBV=c("trt1", "trt2"))),NULL)
+  expect_equal(print.AlphaPart(AlphaPart(x=ped, colBV=c("trt1", "trt2"))),NULL)
   expect_equal(print(tmp$info),tmp$info)
 })

tests/testthat/test-printPlotSummaryAlphaPart.R

@@ -9,7 +9,7 @@ test_that("Test print.PlotSummary.AlphaPart", {
                      gen=c(  1,   1,   2,   2,   3,   3))
 
   ## Partition additive genetic values
-  tmp <- AlphaPart(x=ped, colBV="trt1", center = FALSE)
+  tmp <- AlphaPart(x=ped, colBV="trt1")
   sum <- summary(tmp, by="gen")
   k <- print(plot.summaryAlphaPart(sum))
   expect_equal(k,NULL)

tests/testthat/test-printSummary-alphapart.R

@@ -12,7 +12,7 @@ test_that("Test Printsummary.AlphaPart", {
                      gen=c(  1,   1,   2,   2,   3,   3))
 
   ## Partition additive genetic values
-  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"), center = FALSE)
+  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"))
   ## Test summary for trt1
   expect_equal(print.AlphaPart(summary(tmp, by="gen")), NULL)
 })

tests/testthat/test-savePlotSummaryAlphaPart.R

@@ -10,7 +10,7 @@ test_that("Test savePlotSummary.AlphaPart", {
                      gen=c(  1,   1,   2,   2,   3,   3))
 
   ## Partition additive genetic values
-  m <- AlphaPart(x=ped, colBV=c("trt1", "trt2"), center = FALSE)
+  m <- AlphaPart(x=ped, colBV=c("trt1", "trt2"))
   sum <- summary(m, by="gen")
   p1 <- plot.summaryAlphaPart(sum)
 

tests/testthat/test-summary-alphapart.R

@@ -12,7 +12,7 @@ test_that("Test summary.AlphaPart", {
                      gen=c(  1,   1,   2,   2,   3,   3))
 
   ## Partition additive genetic values
-  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"), center = FALSE)
+  tmp <- AlphaPart(x=ped, colBV=c("trt1", "trt2"))
   ##
   ##  Trait: trt1
   ##
@@ -94,7 +94,7 @@ test_that("Test summary.AlphaPart", {
   ## Test the direct use of by group analysis in the AlphaPart function
   ped$gen <- factor(ped$gen)
   tmp1 <- summary(AlphaPart(x=ped, colBV=c("trt1", "trt2")), by="gen")
-  tmp2 <- AlphaPart(x=ped, colBV=c("trt1", "trt2"), colBy="gen", center=FALSE)
+  tmp2 <- AlphaPart(x=ped, colBV=c("trt1", "trt2"), colBy="gen")
   expect_equal(tmp1, tmp2)
 
 })