added get_together_sticky function within identify_splits_and_merges and associated testing functions. This may have fixed the issues encountered by Jack, which were possibly due to improper handling of NAs in the previous version.

Author: Ariana Strandburg-Peshkin

NAMESPACE

@@ -17,6 +17,7 @@ export(get_pulls_and_anchors)
 export(get_pulls_and_anchors_with_NA)
 export(get_spatially_discretized_trajectories)
 export(get_speed)
+export(get_together_sticky)
 export(get_turn_and_speed_influence_simplified)
 export(identify_splits_and_merges)
 export(import_axytrek_gps_file)

R/get_together_sticky.R

@@ -1,8 +1,12 @@
 #'Get whether two individuals are together, using a "sticky" definition
 #'
-#'
-
+#' @export
 get_together_sticky <- function(together_inner, together_outer){
+
+  #check lengths
+  checkmate::assert_set_equal(length(together_inner), length(together_outer))
+  checkmate::assert_set_equal(which(is.na(together_inner)),which(is.na(together_outer)))
+
   #build vector to hold whether you are together by a sticky definition
   together_ij <- rep(NA, length(together_inner))
 
@@ -14,11 +18,18 @@ get_together_sticky <- function(together_inner, together_outer){
   apart_idxs <- which(!together_outer)
   together_ij[apart_idxs] <- FALSE
 
-  #make a vector to hold the information on whether your status is ambiguous or not]
+  #NAs are considered FALSE for now (they cannot be part of together sequences), but later we will replace them all with NAs in together_ij
+  na_idxs <- which(is.na(together_outer))
+  together_ij[na_idxs] <- FALSE
+  together_outer[na_idxs] <- FALSE
+  together_inner[na_idxs] <- FALSE
+
+  #make a vector to hold the information on whether your status is ambiguous or not
   #if you are between the thresholds, your status is ambiguous
   status_ambig <- rep(T, length(together_inner))
   status_ambig[inner_idxs] <- F
   status_ambig[apart_idxs] <- F
+  status_ambig[na_idxs] <- F
 
   #get indexes to the ambiguous times
   ambig_idxs <- which(status_ambig)
@@ -69,6 +80,8 @@ get_together_sticky <- function(together_inner, together_outer){
 
       #if unambiguous times were found both before and after
       if(found_fwd & found_bwd){
+        #if both are NA, set together_ij at that ambiguous time to FALSE
+
         #if both are outside the outer threshold, then set together_ij at that ambiguous time to FALSE
         #otherwise, set it to TRUE because they are together due to the "sticky" rule
         if(!together_outer[ambig_idx - backward] & !together_outer[ambig_idx + forward]){
@@ -94,9 +107,12 @@ get_together_sticky <- function(together_inner, together_outer){
     }
   }
 
-  #any NAs are not considered together
+  #any lingering ambiguous values are turned to FALSE
   together_ij[which(is.na(together_ij))] <- FALSE
 
+  #any NAs that were in the original vectors are turned back into NAs
+  together_ij[na_idxs] <- NA
+
   return(together_ij)
 }
 

inst/tinytest/test-get_together_sticky.R

@@ -0,0 +1,130 @@
+#test together sticky
+
+#various situations of coming together and splitting
+
+R_inner <- 0.4
+R_outer <- 0.6
+
+a <- 1 #apart distance
+m <- 0.5 #mid distance (between the thresholds)
+t <- 0.3 #together distance
+
+#Test 1
+dists <-  c(a, a, m, m, t, t, m, m, a, a)
+result <- c(F, F, T, T, T, T, T, T, F, F)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 2
+#apart -- mid -- apart -- mid -- together -- mid -- apart
+dists <-  c(a, a, m, m, a, a, m, t, t, m, m, a, a)
+result <- c(F, F, F, F, F, F, T, T, T, T, T, F, F)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 3
+#apart -- mid -- together -- mid -- together -- mid -- apart
+dists <-  c(a, a, m, m, a, a, m, t, t, m, m, a, a)
+result <- c(F, F, F, F, F, F, T, T, T, T, T, F, F)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 4
+#apart -- together -- mid -- apart
+dists  <- c(a, a, t, t, m, m, a, a)
+result <- c(F, F, T, T, T, T, F, F)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 5
+#together -- mid -- apart -- mid -- together
+dists <-  c(t, m, a, m, t)
+result <- c(T, T, F, T, T)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 6
+#together -- apart -- together -- apart -- together
+dists <-  c(t, a, t, a, t)
+result <- c(T, F, T, F, T)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 7
+#NA -- apart -- mid -- together -- mid -- apart
+dists <-  c(NA, a, m, t, m, a)
+result <- c(NA,  F, T, T, T, F)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 8
+#apart -- mid -- together -- NA -- together -- mid -- apart
+dists <-  c(a, m, t, NA, t, m, a)
+result <- c(F, T, T, NA,  T, T, F)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 9
+#NA -- mid -- NA -- mid -- together -- apart
+dists <-  c(NA, m,  NA, m,  t, a)
+result <- c(NA, F,  NA, T,  T, F)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 10
+#NA -- together -- mid -- NA -- mid -- together -- apart
+dists <-  c(NA, t, m, NA, m, t)
+result <- c(NA, T, T, NA, T, T)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 11
+#NA -- together -- mid -- NA -- mid -- together -- apart
+dists <-  c(NA, t, m, NA, m, NA)
+result <- c(NA, T, T, NA, F, NA)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+
+#Test 11
+#apart -- apart -- NA
+dists <-  c(a, a, NA)
+result <- c(F, F, NA)
+
+together_inner <- dists <= R_inner
+together_outer <- dists <= R_outer
+
+expect_equal(get_together_sticky(together_inner, together_outer), result)
+