Add replace_ids.matrix() and .data.frame()

[Issue rqtl#191]

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: qtl2
-Version: 0.25-4
+Version: 0.25-5
 Date: 2021-07-12
 Title: Quantitative Trait Locus Mapping in Experimental Crosses
 Description: Provides a set of tools to perform quantitative

NAMESPACE

@@ -29,6 +29,8 @@ S3method(rbind,sim_geno)
 S3method(rbind,viterbi)
 S3method(replace_ids,calc_genoprob)
 S3method(replace_ids,cross2)
+S3method(replace_ids,data.frame)
+S3method(replace_ids,matrix)
 S3method(replace_ids,sim_geno)
 S3method(replace_ids,viterbi)
 S3method(subset,calc_genoprob)

NEWS.md

@@ -1,4 +1,4 @@
-## qtl2 0.25-4 (2021-07-12)
+## qtl2 0.25-5 (2021-07-12)
 
 ### Major changes
 
@@ -15,6 +15,9 @@
 
 ### Minor changes
 
+- Added `replace_ids()` for a matrix or data frame (using the row
+  names as the individual IDs). (Issue #191)
+
 - Have `calc_het()` give an error if the input are for allele dosages.
   [Issue #190](https://github.com/rqtl/qtl2/issues/190)
 

R/replace_ids.R

@@ -132,3 +132,23 @@ replace_ids.viterbi <-
 #' @describeIn replace_ids Replace IDs in output from [sim_geno()]
 #' @export
 replace_ids.sim_geno <- function(x, ids) replace_ids.calc_genoprob(x, ids)
+
+#' @describeIn replace_ids Replace IDs in a matrix
+#' @export
+replace_ids.matrix <-
+    function(x, ids)
+{
+    ids <- check_new_ids(ids, rownames(x))
+    ids_names <- names(ids)
+    names(ids) <- NULL
+
+    m <- match(rownames(x), ids_names)
+    x <- x[!is.na(m),,drop=FALSE]
+    rownames(x) <- ids[m[!is.na(m)]]
+
+    x
+}
+
+#' @describeIn replace_ids Replace IDs in a data frame
+#' @export
+replace_ids.data.frame <- replace_ids.matrix

tests/testthat/test-replace_ids.R

@@ -181,3 +181,76 @@ test_that("replace_ids() works for sim_geno output", {
     )
 
 })
+
+
+
+
+
+test_that("replace_ids() works for a matrix", {
+
+    iron <- read_cross2(system.file("extdata", "iron.zip", package="qtl2"))
+    ids <- ind_ids(iron)
+    new_ids <- setNames(paste0("mouse", ids), ids)
+    change_back <- setNames(ids, paste0("mouse", ids))
+    extra_ids <- sample(c(ids, 1001:1020))
+    extra_ids <- setNames(paste0("mouse", extra_ids), extra_ids)
+
+    # create a matrix
+    set.seed(20210712)
+    n_col <- 12
+    d <- matrix(rnorm(n_ind(iron)*n_col), ncol=n_col)
+    dimnames(d) <- list(ids, paste("V", seq_len(n_col)))
+
+    # same ids, old and new (changed back)
+    expect_equal( replace_ids(d, setNames(ids, ids)), d)
+
+    # simple replacement, everything in order
+    expect_equal( replace_ids(replace_ids(d, new_ids), change_back), d)
+
+    # simple replacement, but shuffled
+    expect_equal( replace_ids(replace_ids(d, sample(new_ids)), sample(change_back)), d)
+
+    # simple replacement, with some extras plus shuffled
+    expect_warning(
+        expect_equal( replace_ids(replace_ids(d, extra_ids), sample(change_back)), d)
+    )
+
+    # missing some individuals
+    sub_ids <- sample(ids, length(ids)-10)
+    sub_ids_ordered <- sub_ids[order(as.numeric(sub_ids))]
+    expect_warning(
+        expect_equal( replace_ids(d, setNames(sub_ids, sub_ids)),
+                      d[sub_ids_ordered,,drop=FALSE])
+    )
+
+
+    ##############################
+    # turn it into a data frame and do it all again
+    ##############################
+    d <- as.data.frame(d)
+
+    # same ids, old and new (changed back)
+    expect_equal( replace_ids(d, setNames(ids, ids)), d)
+
+    # simple replacement, everything in order
+    expect_equal( replace_ids(replace_ids(d, new_ids), change_back), d)
+
+    # simple replacement, but shuffled
+    expect_equal( replace_ids(replace_ids(d, sample(new_ids)), sample(change_back)), d)
+
+    # simple replacement, with some extras plus shuffled
+    expect_warning(
+        expect_equal( replace_ids(replace_ids(d, extra_ids), sample(change_back)), d)
+    )
+
+    # missing some individuals
+    sub_ids <- sample(ids, length(ids)-10)
+    sub_ids_ordered <- sub_ids[order(as.numeric(sub_ids))]
+    expect_warning(
+        expect_equal( replace_ids(d, setNames(sub_ids, sub_ids)),
+                      d[sub_ids_ordered,,drop=FALSE])
+    )
+
+
+
+})