change proportions and ancestors to vectors, add error messages

R/helper.R

@@ -60,12 +60,18 @@ order_demes <- function(deme) {
  return(ordered_deme)
 }
 
-conv_prop_list <- function(demes){
+conv_prop_anc_vec <- function(demes){
  for (i in 1:length(demes$demes)){
  if (length(demes$demes[[i]]$proportions) > 0){
- demes$demes[[i]]$proportions <- list(as.double(demes$demes[[i]]$proportions))
+ demes$demes[[i]]$proportions <- as.double(demes$demes[[i]]$proportions)
  } else{
- demes$demes[[i]]$proportions <- list()
+ demes$demes[[i]]$proportions <- vector(mode="double")
+ }
+
+ if (length(demes$demes[[i]]$ancestors) > 0){
+ demes$demes[[i]]$ancestors <- unlist(demes$demes[[i]]$ancestors)
+ } else{
+ demes$demes[[i]]$ancestors <- vector(mode="character")
  }
  }
 
@@ -86,7 +92,7 @@ conv_migr <- function(demes){
 post_process_expected <- function(exp){
  exp <- order_demes(exp)
  exp <- convert_infinity(exp)
- exp <- conv_prop_list(exp)
+ exp <- conv_prop_anc_vec(exp)
  exp <- conv_migr(exp)
 
  return(exp)

R/validate_demes.R

@@ -55,29 +55,45 @@ validate_demes <- function(inp){
  }
 
  # Ancestors
- if (is.null(inp$demes[[i]]$ancestors) & !is.null(inp$defaults$deme$ancestors)){
- out$demes[[i]]$ancestors <- inp$defaults$deme$ancestors
- } else if (is.null(inp$demes[[i]]$ancestors)) {
- out$demes[[i]]$ancestors <- list()
+ if (length(inp$demes[[i]]$ancestors) > 0){
+ out$demes[[i]]$ancestors <- unlist(out$demes[[i]]$ancestors)
+ } else if (is.null(inp$demes[[i]]$ancestors) & !is.null(inp$defaults$deme$ancestors)){
+ out$demes[[i]]$ancestors <- unlist(inp$defaults$deme$ancestors)
+ } else {
+ out$demes[[i]]$ancestors <- vector(mode="character")
+ }
+ if (out$demes[[i]]$name %in% out$demes[[i]]$ancestors){
+ stop(paste0("No deme may appear in its own ancestors list. This was violated in deme ", i, "."), .call=F)
+ } else if (length(out$demes[[i]]$ancestors) != length(unique(out$demes[[i]]$ancestors))){
+ stop(paste0("Each element of the ancestors list must be unique. This was violated in deme ", i, "."), .call=F)
+ }
+ is_char_ancestor <- sapply(out$demes[[i]]$ancestors, is.character)
+ if (any(!is_char_ancestor)){
+ stop(paste0("Each element of the ancestors list must be a string. This was violated in deme ", i, ", where an ancestor had type ", typeof(out$demes[[i]]$ancestors[!is_char_ancestor]), "."), .call=F)
  }
 
  # Proportions
  if (!is.null(out$demes[[i]]$proportions)){
  if(length(out$demes[[i]]$proportions) > 0){
- out$demes[[i]]$proportions <- list(as.double(inp$demes[[i]]$proportions))
+ out$demes[[i]]$proportions <- as.double(unlist(inp$demes[[i]]$proportions))
+ } else {
+ out$demes[[i]]$proportions <- vector(mode="double")
  }
  } else if (!is.null(inp$defaults$deme$proportions)){
- out$demes[[i]]$proportions <- list(as.double(inp$defaults$deme$proportions))
+ out$demes[[i]]$proportions <- as.double(unlist(inp$defaults$deme$proportions))
  } else if (length(out$demes[[i]]$ancestors) == 1){
- out$demes[[i]]$proportions <- list(as.double(1))
+ out$demes[[i]]$proportions <- as.double(1)
  } else if(length(out$demes[[i]]$ancestors) == 0){
- out$demes[[i]]$proportions <- list()
+ out$demes[[i]]$proportions <- vector(mode="double")
  } else{
  stop("proportions cannot be determined with the information provided. proportions must either be specified explicitly, via defaults or have one or less ancestors.", .call=FALSE)
  }
- #} #else if (is.null(inp$demes[[i]]$proportions)){
- # out$demes[[i]]$proportions <- list(as.double(inp$demes[[i]]$proportions))
- # }
+
+ if (sum(out$demes[[i]]$proportions) > 1){
+ stop(paste0("If the proportions list is not empty, then the values must sum to 1. This was violated in deme ", i, "."), .call = FALSE)
+ } else if (length(out$demes[[i]]$proportions) != length(out$demes[[i]]$ancestors)){
+ stop(paste0("The proportions list must have the same length as the ancestors list. This was violated in deme ", i, "."), .call=FALSE)
+ }
 
  # Start time
  if (!is.null(inp$demes[[i]]$start_time)){
@@ -96,6 +112,12 @@ validate_demes <- function(inp){
  stop(paste("start_time of deme", i, "cannot be determined from the provided information."), .call=FALSE)
  }
 
+ if (out$demes[[i]]$start_time == Inf & length(out$demes[[i]]$ancestors) != 0){
+ stop(paste0("If the start_time of a deme is infinity, ancestors must be an empty list. This is violated in deme ", i, "."), .call=F)
+ } else if (out$demes[[i]]$start_time != Inf & length(out$demes[[i]]$ancestors) == 0){
+ stop(paste0("If a deme has a finite start_time, it must have specified ancestors. This is violated in deme ", i, "."), .call=F)
+ }
+
  # Epochs
  if (length(inp$demes[[i]]$epochs) == 0){
  inp$demes[[i]]$epochs <- list()
@@ -384,6 +406,16 @@ validate_demes <- function(inp){
  out$pulses <- out$pulses[order(pulse_times, decreasing = TRUE)]
  }
 
+ # Final Validation
+ # Demes
+ if (length(out$demes) == 0){
+ stop("There must be at least one deme, but none were specified.", .call=F)
+ }
+ deme_names <- unlist(lapply(out$demes, function(x){return(x$name)}))
+ if (length(deme_names) != length(unique(deme_names))){
+ stop(paste("Deme names must be unique in the model, but deme(s)", unique(deme_names[duplicated(deme_names)]), "appear(s) several times"))
+ }
+
  return(out)
 }
 

tests/testthat/helper-functions.R

@@ -46,7 +46,12 @@ parse_ref <- function(input_file){
  return(path_preparsed_file)
 }
 
-# Get path to a test file in the Demes specification directory
+# Get path to a valid test file in the Demes specification directory
 get_test_file <- function(file) {
  file.path(get_spec_dir(), "test-cases", "valid", file)
 }
+
+# Get path to an invalid test file in the Demes specification directory
+get_invalid_test_file <- function(file) {
+ file.path(get_spec_dir(), "test-cases", "invalid", file)
+}

tests/testthat/test-validate_demes.R

@@ -16,9 +16,9 @@ test_that("minimal_01.yaml is parsed correctly", {
  named_list <- list()
  names(named_list) <- character()
  expect_equal(d$metadata, named_list)
- expect_equal(d$demes[[1]]$ancestors, list())
+ expect_equal(d$demes[[1]]$ancestors, vector(mode="character"))
  expect_identical(d$demes[[1]]$description, '')
- expect_equal(d$demes[[1]]$proportions, list())
+ expect_equal(d$demes[[1]]$proportions, vector(mode="double"))
  expect_identical(d$migrations, list())
  expect_identical(d$pulses, list())
 })
@@ -62,3 +62,17 @@ test_that("R parser results match the reference implementation in Python", {
  # This is done to avoid type errors for users, when default values like 0, read as an integer by read_yaml() are changed interactively
  # 3) 1) and 2) mean that an extra processing step has to happen to the true comparison object in the testing
 })
+
+# test_that("R parser rejects all invalid test cases", {
+# setup_demes_spec()
+#
+# # get all invalid test YAML files available in the Demes specification repository
+# test_files <- file.path(get_spec_dir(), "test-cases", "invalid") %>% list.files(pattern = ".yaml")
+#
+# for (f in test_files){
+# inp <- yaml::read_yaml(get_invalid_test_file(f))
+# try(validate_demes(inp))
+# print(f)
+# expect_error(validate_demes(inp), label = f)
+# }
+# })