Nothing
context("replace individual IDs")
test_that("check_new_ids() works", {
old_ids <- as.character(1:200)
new_ids <- setNames(sprintf("mouse%03d", as.numeric(old_ids)), old_ids)
# same ids in same order
expect_equal(check_new_ids(new_ids, old_ids), new_ids)
# same ids, but shuffled
shuffled <- sample(new_ids)
expect_equal(check_new_ids(shuffled, old_ids), shuffled)
# error if duplicate IDs
dup_new <- new_ids
dup_new[5] <- dup_new[20]
expect_error(check_new_ids(dup_new, old_ids))
# error if duplicate names in the IDs
dup_old <- new_ids
names(dup_old)[5] <- names(dup_old)[20]
expect_error(check_new_ids(dup_old, old_ids))
# warning if extra IDs
new_extra <- c(new_ids, "201"="mouse201", "202"="mouse202")
expect_warning( expect_equal( check_new_ids(new_extra, old_ids), new_ids) )
o <- sample(length(new_extra))
expect_warning( expect_equal( check_new_ids(new_extra[o], old_ids),
new_extra[o[o<=length(new_ids)]] ) )
# warning if not all IDs are there
new_missing <- sample(new_ids, length(new_ids)-5)
expect_warning( expect_equal( check_new_ids(new_missing, old_ids),
new_missing[names(new_missing) %in% old_ids] ))
})
test_that("replace_ids() works for a cross2 object", {
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)
# same ids, old and new
expect_equal( replace_ids(iron, setNames(ids, ids)), iron)
# simple replacement, everything in order
expect_equal( replace_ids(replace_ids(iron, new_ids), change_back), iron)
# simple replacement, but shuffled
expect_equal( replace_ids(replace_ids(iron, sample(new_ids)), sample(change_back)), iron)
# simple replacement, with some extras plus shuffled
expect_warning(
expect_equal( replace_ids(replace_ids(iron, extra_ids), sample(change_back)), iron)
)
# 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(iron, setNames(sub_ids, sub_ids)),
iron[sub_ids_ordered,])
)
})
test_that("replace_ids() works for calc_genoprob output", {
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)
map <- insert_pseudomarkers(iron$gmap, step=2.5)
pr <- calc_genoprob(iron, map)
# same ids, old and new
expect_equal( replace_ids(pr, setNames(ids, ids)), pr)
# simple replacement, everything in order
expect_equal( replace_ids(replace_ids(pr, new_ids), change_back), pr)
# simple replacement, but shuffled
expect_equal( replace_ids(replace_ids(pr, sample(new_ids)), sample(change_back)), pr)
# simple replacement, with some extras plus shuffled
expect_warning(
expect_equal( replace_ids(replace_ids(pr, extra_ids), sample(change_back)), pr)
)
# 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(pr, setNames(sub_ids, sub_ids)),
pr[sub_ids_ordered,])
)
})
test_that("replace_ids() works for viterbi output", {
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)
map <- insert_pseudomarkers(iron$gmap, step=2.5)
v <- viterbi(iron, map)
# same ids, old and new
expect_equal( replace_ids(v, setNames(ids, ids)), v)
# simple replacement, everything in order
expect_equal( replace_ids(replace_ids(v, new_ids), change_back), v)
# simple replacement, but shuffled
expect_equal( replace_ids(replace_ids(v, sample(new_ids)), sample(change_back)), v)
# simple replacement, with some extras plus shuffled
expect_warning(
expect_equal( replace_ids(replace_ids(v, extra_ids), sample(change_back)), v)
)
# 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(v, setNames(sub_ids, sub_ids)),
v[sub_ids_ordered,])
)
})
test_that("replace_ids() works for sim_geno output", {
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)
map <- insert_pseudomarkers(iron$gmap, step=2.5)
d <- sim_geno(iron, map, n_draws=8)
# 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,])
)
})
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])
)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.