Fix Issue rqtl#181 (calc_het wasn't working with qtl2fst probs)

- Fixed a similar bug in calc_geno_freq()
- Added related tests in R/qtl2fst

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: qtl2
-Version: 0.23-6
-Date: 2020-10-22
+Version: 0.23-7
+Date: 2020-11-18
 Title: Quantitative Trait Locus Mapping in Experimental Crosses
 Description: Provides a set of tools to perform quantitative
     trait locus (QTL) analysis in experimental crosses. It is a

NEWS.md

@@ -1,4 +1,4 @@
-## qtl2 0.23-6 (2020-10-22)
+## qtl2 0.23-7 (2020-11-18)
 
 ### Major changes
 
@@ -18,6 +18,11 @@
 
 ### Bug fixes
 
+- Fixed [Issue #181](https://github.com/rqtl/qtl2/issues/181), where
+  `calc_het()` gave values > 1 when used with
+  [R/qtl2fst](https://github.com/rqtl/qtl2fst)-based probabilities.
+  Also fixed a similar bug in `calc_geno_freq()`.
+
 - Fixed [Issue #172](https://github.com/rqtl/qtl2/issues/172), where
   `fit1()` gave incorrect fitted values when `kinship` is provided,
   because they weren't "rotated back".

R/calc_geno_freq.R

@@ -61,12 +61,14 @@ calc_geno_freq <-
 
     # for rest, can assume that they're all one group
 
+    n_chr <- length(probs)
+
     if(by=="individual") {
         # total markers
-        total_mar <- sum( vapply(probs, function(a) dim(a)[3], 1) )
+        total_mar <- sum(dim(probs)[3,])
 
         # summarize each chromosome
-        result <- lapply(probs, apply, 1:2, sum)
+        result <- lapply(seq_len(n_chr), function(chr) apply(probs[[chr]], 1:2, sum))
 
         if(length(result)>1) {
             for(i in seq_along(result)[-1])
@@ -76,5 +78,5 @@ calc_geno_freq <-
     }
 
     # else: by marker
-    t(do.call("cbind", lapply(probs, apply, 2:3, mean)))
+    t(do.call("cbind", lapply(seq_len(n_chr), function(chr) apply(probs[[chr]], 2:3, mean))))
 }

R/calc_het.R

@@ -41,17 +41,17 @@ calc_het <-
 
     # determine which columns are het
     het_col <- vector("list", n_chr)
+    geno <- dimnames(probs)[[2]]
     for(chr in seq_len(n_chr)) {
-        geno <- colnames(probs[[chr]])
-        a1 <- substr(geno, 1, 1)
-        a2 <- substr(geno, 2, 2)
+        a1 <- substr(geno[[chr]], 1, 1)
+        a2 <- substr(geno[[chr]], 2, 2)
         if(is_x_chr[chr]) het_col[[chr]] <- (a1 != a2 & a2 != "Y")
         else het_col[[chr]] <- (a1 != a2)
     }
 
     if(by=="individual") {
         # total markers
-        total_mar <- sum( vapply(probs, function(a) dim(a)[3], 1) )
+        total_mar <- sum(dim(probs)[3,])
 
         # summarize each chromosome
         result <- lapply(seq_len(n_chr), function(chr) apply(probs[[chr]][,het_col[[chr]],,drop=FALSE], 1, sum))