Skip to content

Commit

Permalink
Fix migrations, parse all valid test cases correctly
Browse files Browse the repository at this point in the history
  • Loading branch information
@IsabelMarleen
IsabelMarleen committed Mar 8, 2023
1 parent 751770f commit 8ad75e2
Show file tree
Hide file tree
Showing 2 changed files with 56 additions and 89 deletions.
114 changes: 51 additions & 63 deletions R/validate_demes.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -239,6 +239,7 @@ validate_demes <- function(inp){
out$migrations <- list()
} else {
start_num_migr <- length(inp$migrations)
migs <- NULL
for (i in 1:start_num_migr){
# Rate
if (is.null(out$migrations[[i]]$rate) & !is.null(inp$defaults$migration$rate)){
Expand Down Expand Up @@ -295,68 +296,55 @@ validate_demes <- function(inp){
sym_migration <- out$migrations[[i]]
out$migrations[[i]]$demes <- NULL
sym_combs <- combn(sym_migration$demes, 2) # Getting all combinations
asym_from_sym <- list()
mig_counter <- 1

for (k in 1:ncol(sym_combs)){
if (k == 1){ # The very first asymmetric migration replaces the original symmetric migration
# First asymmetric migration of pair
out$migrations[[i]]$source <- sym_combs[1, k]
out$migrations[[i]]$dest <- sym_combs[2, k]
out$migrations[[i]]$rate <- sym_migration$rate
out$migrations[[i]]$start_time <- sym_migration$start_time
out$migrations[[i]]$end_time <- sym_migration$end_time
# start_time
out$migrations[[i]]$start_time <- validate_migration_times(out, i, "start", deme_names)
# end_time
out$migrations[[i]]$end_time <- validate_migration_times(out, i, "end", deme_names)

# Second asymmetric migration of pair
pos_counter <- length(out$migrations)+1
out$migrations[[pos_counter]] <- list()
out$migrations[[pos_counter]]$dest <- sym_combs[1, k]
out$migrations[[pos_counter]]$source <- sym_combs[2, k]
out$migrations[[pos_counter]]$rate <- sym_migration$rate
out$migrations[[pos_counter]]$start_time <- sym_migration$start_time
out$migrations[[pos_counter]]$end_time <- sym_migration$end_time
# start_time
out$migrations[[pos_counter]]$start_time <- validate_migration_times(out, pos_counter, "start", deme_names)
# end_time
out$migrations[[pos_counter]]$end_time <- validate_migration_times(out, pos_counter, "end", deme_names)

} else {
pos_counter <- pos_counter + 1
out$migrations[[pos_counter]] <- list()
# First asymmetric migration of pair
out$migrations[[pos_counter]]$source <- sym_combs[1, k]
out$migrations[[pos_counter]]$dest <- sym_combs[2, k]
out$migrations[[pos_counter]]$rate <- sym_migration$rate
out$migrations[[pos_counter]]$start_time <- sym_migration$start_time
out$migrations[[pos_counter]]$end_time <- sym_migration$end_time
# start_time
out$migrations[[pos_counter]]$start_time <- validate_migration_times(out, pos_counter, "start", deme_names)
# end_time
out$migrations[[pos_counter]]$end_time <- validate_migration_times(out, pos_counter, "end", deme_names)

pos_counter <- pos_counter + 1
out$migrations[[pos_counter]] <- list()
# Second asymmetric migration of pair
out$migrations[[pos_counter]]$dest <- sym_combs[1, k]
out$migrations[[pos_counter]]$source <- sym_combs[2, k]
out$migrations[[pos_counter]]$rate <- sym_migration$rate
out$migrations[[pos_counter]]$start_time <- sym_migration$start_time
out$migrations[[pos_counter]]$end_time <- sym_migration$end_time
# start_time
out$migrations[[pos_counter]]$start_time <- validate_migration_times(out, pos_counter, "start", deme_names)
# end_time
out$migrations[[pos_counter]]$end_time <- validate_migration_times(out, pos_counter, "end", deme_names)
}
asym_from_sym[[mig_counter]] <- list()

# First asymmetric migration of pair
asym_from_sym[[mig_counter]]$source <- sym_combs[1, k]
asym_from_sym[[mig_counter]]$dest <- sym_combs[2, k]
asym_from_sym[[mig_counter]]$rate <- sym_migration$rate
asym_from_sym[[mig_counter]]$start_time <- sym_migration$start_time
asym_from_sym[[mig_counter]]$end_time <- sym_migration$end_time
# start_time
asym_from_sym[[mig_counter]]$start_time <- validate_migration_times(out, asym_from_sym[[mig_counter]], "start", deme_names)
# end_time
asym_from_sym[[mig_counter]]$end_time <- validate_migration_times(out, asym_from_sym[[mig_counter]], "end", deme_names)

# Second asymmetric migration of pair
mig_counter <- mig_counter+1
asym_from_sym[[mig_counter]] <- list()
asym_from_sym[[mig_counter]]$dest <- sym_combs[1, k]
asym_from_sym[[mig_counter]]$source <- sym_combs[2, k]
asym_from_sym[[mig_counter]]$rate <- sym_migration$rate
asym_from_sym[[mig_counter]]$start_time <- sym_migration$start_time
asym_from_sym[[mig_counter]]$end_time <- sym_migration$end_time
# start_time
asym_from_sym[[mig_counter]]$start_time <- validate_migration_times(out, asym_from_sym[[mig_counter]], "start", deme_names)
# end_time
asym_from_sym[[mig_counter]]$end_time <- validate_migration_times(out, asym_from_sym[[mig_counter]], "end", deme_names)
mig_counter <- mig_counter+1
}
if (is.null(migs)){
migs <- asym_from_sym
} else{
migs <- c(migs, asym_from_sym)
}
} else { # asymmetric migrations
# start_time
out$migrations[[i]]$start_time <- validate_migration_times(out, i, "start", deme_names)
out$migrations[[i]]$start_time <- validate_migration_times(out, out$migrations[[i]], "start", deme_names)
# end_time
out$migrations[[i]]$end_time <- validate_migration_times(out, i, "end", deme_names)
out$migrations[[i]]$end_time <- validate_migration_times(out, out$migrations[[i]], "end", deme_names)
if (is.null(migs)){
migs <- list(out$migrations[[i]])
} else{
migs <- c(migs, list(out$migrations[[i]]))
}
}
}
out$migrations <- migs
}

# Pulses
Expand Down Expand Up @@ -401,29 +389,29 @@ validate_demes <- function(inp){



validate_migration_times <- function(out, i, time, deme_names){
validate_migration_times <- function(out, mig, time, deme_names){
if (time == "start"){
if (!is.null(out$migrations[[i]]$start_time)){
start_time <- as.double(out$migrations[[i]]$start_time)
if (!is.null(mig$start_time)){
start_time <- as.double(mig$start_time)
} else if (!is.null(out$defaults$migration$start_time)) {
start_time <- as.double(out$defaults$migration$start_time)
} else {
source_index <- match(out$migrations[[i]]$source, deme_names)
dest_index <- match(out$migrations[[i]]$dest, deme_names)
source_index <- match(mig$source, deme_names)
dest_index <- match(mig$dest, deme_names)
start_time <- as.double(
min(out$demes[[source_index]]$start_time,
out$demes[[dest_index]]$start_time))
}
return(start_time)

} else if (time == "end"){
if (!is.null(out$migrations[[i]]$end_time)){
end_time <- as.double(out$migrations[[i]]$end_time)
if (!is.null(mig$end_time)){
end_time <- as.double(mig$end_time)
} else if (!is.null(out$defaults$migration$end_time)) {
end_time <- as.double(out$defaults$migration$end_time)
} else {
source_index <- match(out$migrations[[i]]$source, deme_names)
dest_index <- match(out$migrations[[i]]$dest, deme_names)
source_index <- match(mig$source, deme_names)
dest_index <- match(mig$dest, deme_names)
source_last_epoch <- length(out$demes[[source_index]]$epochs)
dest_last_epoch <- length(out$demes[[dest_index]]$epochs)

Expand Down
31 changes: 5 additions & 26 deletions tests/testthat/test-validate_demes.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,36 +27,15 @@ test_that("R parser results match the reference implementation in Python", {
setup_env()
setup_demes_spec()

# test_files <- list.files(get_test_file_path())
# test_files <- test_files[test_files == "minimal_01.yaml"]

# get all valid test YAML files available in the Demes specification repository
# test_files <- file.path(get_spec_dir(), "test-cases", "valid") %>% list.files(pattern = ".yaml")
# test_files <- "basic_resolution_05.yaml"
test_files <- c(paste0("minimal_0", 1:2, ".yaml"),
paste0("admixture_0", 1:9, ".yaml"), paste0("admixture_", 10:27, ".yaml"),
paste0("deme_names_0", 1:3, ".yaml"),
paste0("migration_0", 1:9, ".yaml"), "migration_10.yaml",
paste0("structure_0", 1:8, ".yaml") ,
"args_from_file_01.yaml",
"admixture_and_split_01.yaml",
"asymmetric_migration_01.yaml",
"bad_pulse_time_01.yaml",
paste0("deme_cloning_rate_0", 1:3, ".yaml"),
"deme_selfing_rate_01.yaml",
"size_function_defaults_01.yaml",
paste0("split_0", 1:9, ".yaml"), "split_10.yaml",
"selfing_cloning_01.yaml",
paste0("size_changes_0", 1:9, ".yaml"), paste0("size_changes_", 10:32, ".yaml"),
paste0("basic_resolution_0", 1:6, ".yaml"),
paste0("deme_names_0", 1:3, ".yaml"),
paste0("infinity_0", 1:8, ".yaml")
)

test_files <- file.path(get_spec_dir(), "test-cases", "valid") %>% list.files(pattern = ".yaml")
# Remove files that cannot be parsed
# The first three don't pass because they have a deme named "y" and that is interpreted as TRUE in yaml 1.1 which is what the reader is based on
# For the last one it is the pre-parsed file that causes issues. It cannot be read by yaml::read_yaml without causing an error unless encoding UTF-16 is specified
test_files <- test_files[!(test_files %in% c("toplevel_defaults_deme_01.yaml", "successors_predecessors_01.yaml", "deme_end_time_01.yaml", "unicode_deme_name_04.yaml"))]

for (f in test_files){
path_preparsed_file <- parse_ref(get_test_file(f))
# print(path_preparsed_file)

# validating a fully parsed model should not change anything
# Use less strict expectation (as opposed to use_identical), because values should
Expand Down

0 comments on commit 8ad75e2

Please sign in to comment.