correct 'distribution' section for tip dating, progress ropensci/babe…

…tte#27
ropensci · Nov 30, 2018 · 0601f91 · 0601f91
1 parent 3411208
commit 0601f91
Show file tree

Hide file tree

Showing 3 changed files with 32 additions and 15 deletions.
diff --git a/R/clock_model_to_xml_lh_distr.R b/R/clock_model_to_xml_lh_distr.R
@@ -15,26 +15,39 @@
 #' @noRd
 clock_model_to_xml_lh_distr <- function(
   clock_model,
-  mrca_priors = NA
+  mrca_priors = NA,
+  tipdates_filename = NA
 ) {
   testit::assert(is_clock_model(clock_model)) # nolint internal function
   id <- clock_model$id
   testit::assert(is_id(id)) # nolint internal function
 
   text <- NULL
   if (is_strict_clock_model(clock_model)) { # nolint internal function
-    text <- c(text, paste0("<branchRateModel id=\"StrictClock.c:",
-      id, "\" spec=\"beast.evolution.branchratemodel.StrictClockModel\">"))
-    # initialization may happen here
-    clock_model$clock_rate_param$id <- id
-    text <- c(
-      text,
-      indent( # nolint internal function
-        parameter_to_xml(clock_model$clock_rate_param), # nolint internal function
-        n_spaces = 4
+    if (is.na(tipdates_filename)) {
+      text <- c(text, paste0("<branchRateModel id=\"StrictClock.c:",
+        id, "\" spec=\"beast.evolution.branchratemodel.StrictClockModel\">"))
+      # initialization may happen here
+      clock_model$clock_rate_param$id <- id
+      text <- c(
+        text,
+        indent( # nolint internal function
+          parameter_to_xml(clock_model$clock_rate_param), # nolint internal function
+          n_spaces = 4
+        )
       )
-    )
-    text <- c(text, "</branchRateModel>")
+      text <- c(text, "</branchRateModel>")
+    }
+    else {
+      text <- c(
+        text,
+        paste0(
+          "<branchRateModel id=\"StrictClock.c:", id, "\" ",
+          "spec=\"beast.evolution.branchratemodel.StrictClockModel\" ",
+          "clock.rate=\"@clockRate.c:", id, "\"/>"
+        )
+      )
+    }
   } else if (is_rln_clock_model(clock_model)) { # nolint internal function
     n_discrete_rates <- clock_model$n_rate_categories
     mparam_id <- clock_model$mparam_id

diff --git a/R/create_beast2_input_distr.R b/R/create_beast2_input_distr.R
@@ -46,7 +46,8 @@ create_beast2_input_distr <- function( # nolint internal function
     create_beast2_input_distr_lh(
       site_models = site_models,
       clock_models = clock_models,
-      mrca_priors = mrca_priors
+      mrca_priors = mrca_priors,
+      tipdates_filename = tipdates_filename
     )
   )
   text <- indent(text, n_spaces = 4) # nolint internal function
@@ -129,7 +130,8 @@ create_beast2_input_distr_prior <- function( # nolint internal function
 create_beast2_input_distr_lh <- function( # nolint internal function
   site_models,
   clock_models,
-  mrca_priors = NA
+  mrca_priors = NA,
+  tipdates_filename = NA
 ) {
   testit::assert(length(site_models) == 1)
   testit::assert(length(site_models) == length(clock_models))
@@ -158,7 +160,8 @@ create_beast2_input_distr_lh <- function( # nolint internal function
         indent( # nolint internal function
           clock_model_to_xml_lh_distr( # nolint internal function
             clock_model,
-            mrca_priors = mrca_priors
+            mrca_priors = mrca_priors,
+            tipdates_filename = tipdates_filename
           ),
           n_spaces = 4
         )

diff --git a/tests/testthat/test-create_beast2_input_by_reproducing_files_simple.R b/tests/testthat/test-create_beast2_input_by_reproducing_files_simple.R
@@ -1410,6 +1410,7 @@ test_that("Tip dating", {
 
   expected <- readLines(get_beautier_path("G_VII_pre2003.xml"))
   expect_true(are_equivalent_xml_lines(created, expected, section = "state"))
+  expect_true(are_equivalent_xml_lines(created, expected, section = "distribution")) # molint
 
   compare_lines(created, expected, section = "distribution", "~/created.xml", "~/expected.xml") # nolint
   expect_true(are_equivalent_xml_lines(created, expected, section = "distribution")) # molint