Unit handling

NAMESPACE

@@ -1,5 +1,9 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(get_L_unit,adm)
+S3method(get_L_unit,multiadm)
+S3method(get_T_unit,adm)
+S3method(get_T_unit,multiadm)
 S3method(get_completeness,adm)
 S3method(get_completeness,multiadm)
 S3method(get_height,adm)
@@ -26,13 +30,19 @@ S3method(plot,adm)
 S3method(plot,multiadm)
 S3method(print,adm)
 S3method(print,multiadm)
+S3method(set_L_unit,adm)
+S3method(set_L_unit,multiadm)
+S3method(set_T_unit,adm)
+S3method(set_T_unit,multiadm)
 S3method(strat_to_time,phylo)
 S3method(summary,adm)
 S3method(summary,multiadm)
 S3method(time_to_strat,phylo)
 export(L_axis_lab)
 export(T_axis_lab)
 export(add_adm_to_multiadm)
+export(get_L_unit)
+export(get_T_unit)
 export(get_completeness)
 export(get_height)
 export(get_hiat_duration)
@@ -48,6 +58,8 @@ export(is_destructive)
 export(merge_adm_to_multiadm)
 export(merge_multiadm)
 export(sedrate_to_multiadm)
+export(set_L_unit)
+export(set_T_unit)
 export(split_multiadm)
 export(strat_cont_to_multiadm)
 export(strat_to_time)

R/T_and_L_unit_handling.R

@@ -0,0 +1,146 @@
+get_L_unit = function(x, ...){
+
+  #'
+  #' @export
+  #' 
+  #' @title extract length unit
+  #' 
+  #' @description
+  #' extracts the length unit from adm or multiadm object
+  #'
+  #' @param x adm or multiadm object
+  #' @param ... other parameters
+  #' 
+  #' @returns character - the length unit of `x`
+  #' 
+  #' @seealso [get_T_unit()] [set_L_unit()]
+  # 
+
+  UseMethod("get_L_unit")
+}
+
+get_L_unit.adm = function(x, ...){
+
+  #' @export
+
+  return(x$L_unit)
+}
+
+get_L_unit.multiadm = function(x, ...){
+
+  #' @export
+
+  return(x$L_unit)
+}
+
+set_L_unit = function(x, L_unit, ...){
+
+  #' 
+  #' @export
+  #' 
+  #' @title set length units
+  #' 
+  #' @description
+  #' set length units for adm and multiadm objects
+  #' 
+  #'
+  #' @param x adm or multiadm object
+  #' @param L_unit time unit
+  #' @param ... further parameters
+  #' 
+  #' @returns an adm or multiadm object with the L unit assigned
+  #' 
+  #' @seealso [set_T_unit()] [get_L_unit()]
+  #' 
+
+  UseMethod("set_L_unit")
+}
+
+set_L_unit.adm = function(x, L_unit, ...){
+
+  #' @export
+
+  x$L_unit = L_unit
+  return(x)
+}
+
+set_L_unit.multiadm = function(x, L_unit, ...){
+
+  #' @export
+  #' 
+  x$L_unit = L_unit
+  return(x)
+}
+
+get_T_unit = function(x, ...){
+
+  #'
+  #' @export
+  #' 
+  #' @title extract Time unit
+  #' 
+  #' @description
+  #' extracts the Time unit from adm or multiadm object
+  #'
+  #' @param x adm or multiadm object
+  #' @param ... other parameters
+  #' 
+  #' @returns character - the time unit of `x`
+  #'
+  #' @seealso [set_T_unit()] [get_L_unit()]
+
+  UseMethod("get_T_unit")
+}
+
+get_T_unit.adm = function(x, ...){
+
+  #' @export
+
+  return(x$T_unit)
+}
+
+get_T_unit.multiadm = function(x, ...){
+
+  #' @export
+
+  return(x$T_unit)
+}
+
+set_T_unit = function(x, T_unit, ...){
+
+  #' 
+  #' @export
+  #' 
+  #' @title set time units
+  #' 
+  #' @description
+  #' set time units for adm and multiadm objects
+  #' 
+  #'
+  #' @param x adm or multiadm object
+  #' @param T_unit time unit
+  #' @param ... further parameters
+  #' 
+  #' @returns an adm or multiadm object with the time unit assigned
+  #' 
+  #' @seealso [set_L_unit()] [get_T_unit()]
+  #' 
+
+  UseMethod("set_T_unit")
+}
+
+set_T_unit.adm = function(x, T_unit, ...){
+
+  #' @export
+
+  x$T_unit = T_unit
+  return(x)
+}
+
+set_T_unit.multiadm = function(x, T_unit, ...){
+
+  #' @export
+  #' 
+  x$T_unit = T_unit
+  return(x)
+}

R/add_adm_to_multiadm.R

@@ -18,8 +18,12 @@ add_adm_to_multiadm = function(x, ...){
     x[["t"]][[x$no_of_entries + i]] = inlist[[i]]$t
     x[["h"]][[x$no_of_entries + i]] = inlist[[i]]$h
     x[["destr"]][[x$no_of_entries + i]] = inlist[[i]]$destr
-    x[["T_unit"]][[x$no_of_entries + i]] = inlist[[i]]$T_unit
-    x[["L_unit"]][[x$no_of_entries + i]] = inlist[[i]]$L_unit
+    if (x$T_unit != get_T_unit(inlist[[i]])){
+      stop("Inconsistent time units, can not merge")
+    }
+    if (x$L_unit != get_L_unit(inlist[[i]])){
+      stop("Inconsistent length units, can not merge")
+    }
 
   }
   x$no_of_entries = x$no_of_entries + length(inlist)

R/merge_adm_to_multiadm.R

@@ -18,14 +18,22 @@ merge_adm_to_multiadm = function(...){
                   "no_of_entries" = length(adm_list),
                   "T_unit" = NULL,
                   "L_unit" = NULL)
+  T_units = unlist(sapply(adm_list, get_T_unit))
+  L_units = unlist(sapply(adm_list, get_L_unit))
+
+  if (any(rep(T_units[1], length(adm_list)) != T_units)){
+    stop("Inconsistent time units, can not merge adms")
+  }
+  if (any(rep(L_units[1], length(adm_list)) != L_units)){
+    stop("Inconsistent length units, can not merge adms")
+  }
+
   for (i in seq_along(adm_list)){
     adm = adm_list[[i]]
     multiadm[["t"]][[i]] = adm$t
     multiadm[["h"]][[i]] = adm$h
     multiadm[["destr"]][[i]] = adm$destr
-
   }
-
   class(multiadm) = "multiadm"
   return(multiadm)
 }

tests/testthat/test_T_and_L_unit_handling.R

@@ -0,0 +1,37 @@
+test_that("Setting and getting of T unit for adm works", {
+  T_unit = "cats"
+  adm = tp_to_adm(t = 1:3, h = 1:3)
+  expect_equal(get_T_unit(set_T_unit(x = adm, T_unit = T_unit)), T_unit)
+  adm = tp_to_adm(t = 1:3, h = 1:3, T_unit = T_unit)
+  expect_equal(get_T_unit(adm), T_unit)
+
+})
+
+test_that("Setting and getting of L unit for adm works", {
+  L_unit = "dogs"
+  adm = tp_to_adm(t = 1:3, h = 1:3)
+  expect_equal(get_L_unit(set_L_unit(x = adm, L_unit = L_unit)), L_unit)
+  adm = tp_to_adm(t = 1:3, h = 1:3, L_unit = L_unit)
+  expect_equal(get_L_unit(adm), L_unit)
+
+})
+
+test_that("setting and getting of T unit for multiadm works", {
+  T_unit = "cats"
+  madm = merge_adm_to_multiadm(tp_to_adm(t = 1:3, h = 1:3))
+  expect_equal(get_T_unit.multiadm(set_T_unit.multiadm(x = madm, T_unit = T_unit)), T_unit)
+  madm = merge_adm_to_multiadm(tp_to_adm(t = 1:3, h = 1:3, T_unit = T_unit))
+  madm$T_unit = T_unit
+  expect_equal(get_T_unit(madm), T_unit)
+
+})
+
+test_that("setting and getting of L unit for multiadm works", {
+  L_unit = "dogs"
+  madm = merge_adm_to_multiadm(tp_to_adm(t = 1:3, h = 1:3))
+  expect_equal(get_L_unit.multiadm(set_L_unit.multiadm(x = madm, L_unit = L_unit)), L_unit)
+  madm = merge_adm_to_multiadm(tp_to_adm(t = 1:3, h = 1:3, L_unit = L_unit))
+  madm$L_unit = L_unit
+  expect_equal(get_L_unit(madm), L_unit)
+
+})

tests/testthat/test_merge_adm_to_multiadm.R

@@ -4,3 +4,17 @@ test_that("Produces multiadm object",{
   multiadm = merge_adm_to_multiadm(adm1, adm2)
   expect_true(is_multiadm(multiadm))
 })
+
+test_that("Inconsistent time units throw error", {
+  adm1 = tp_to_adm(t = 1:3, h = 2:4, T_unit = "cats")
+  adm2 = tp_to_adm(t = 1:3, h = 2:5, T_unit = "dogs")
+  expect_error(merge_adm_to_multiadm(adm1, adm2))
+
+})
+
+test_that("Inconsistent length units throw error", {
+  adm1 = tp_to_adm(t = 1:3, h = 2:4, L_unit = "cats")
+  adm2 = tp_to_adm(t = 1:3, h = 2:5, L_unit = "dogs")
+  expect_error(merge_adm_to_multiadm(adm1, adm2))
+
+})