merged subset_by_id fix / updated print.rds for newer version of outb…

…reaks / updated deprecated test

R/subset_clusters_by_id.R

@@ -33,32 +33,27 @@
 
 subset_clusters_by_id <- function(x, id){
 
-    # Convert epicontacts object to igraph and get linelist + contacts dataframes
-    net <- as.igraph.epicontacts(x)
-    net_linelist <- igraph::as_data_frame(net, "vertices")
-    net_contacts <- igraph::as_data_frame(net, "edges")
-
-    # Get cluster information for each node/case
-    cs <- igraph::clusters(net)
-    net_nodes <- data.frame(nodes =igraph::V(net)$id,
-                            cs_member = cs$membership,
-                            stringsAsFactors = FALSE)
-
-    # Identify cluster containing nodes/cases of interest
-    cluster_to_subset <- unique(net_nodes$cs_member[which(net_nodes$nodes %in% id)])
-
-    # Identify members of cluster belonging to nodes/cases of interest
-    id_to_subset <- net_nodes$nodes[ which(net_nodes$cs_member %in% cluster_to_subset)]
-    # Create new epicontacts object with cluster members
-    new_linelist <- net_linelist[ net_linelist$name %in% id_to_subset, ]
-    new_contacts <- net_contacts[ net_contacts$from %in% id_to_subset |
-                                  net_contacts$to %in% id_to_subset, ]
-
-    # Return new epicontacts object
-    epi_subset <- make_epicontacts(new_linelist, new_contacts, directed = x$directed)
-
-    return(epi_subset)
+  ## Convert epicontacts object to igraph and get linelist + contacts dataframes
+  net <- as.igraph.epicontacts(x)
+
+  ## Get cluster information for each node/case
+  cs <- igraph::clusters(net)
+  net_nodes <- data.frame(nodes =igraph::V(net)$id,
+                          cs_member = cs$membership,
+                          stringsAsFactors = FALSE)
+
+  ## Identify cluster containing nodes/cases of interest
+  cluster_to_subset <- unique(net_nodes$cs_member[which(net_nodes$nodes %in% id)])
+
+  ## Identify members of cluster belonging to nodes/cases of interest
+  id_to_subset <- net_nodes$nodes[ which(net_nodes$cs_member %in% cluster_to_subset)]
+
+  ## Subset linelist and contacts by ids - use 'either' so that all contacts of
+  ## interest are returned, these can be removed using thin if need be later
+  epi_subset <- x[i = id_to_subset,
+                  j = id_to_subset,
+                  contacts = 'either']
+
+  return(epi_subset)
+
 }
-
-
-

tests/testthat/test_get_pairwise.R

@@ -28,8 +28,8 @@ test_that("provide false characters", {
                            directed = TRUE)
 
     expect_error(get_pairwise(x, "gende"))
-    expect_that(length(table(get_pairwise(x, "gender", hard_NA = FALSE))) >
-                length(table(get_pairwise(x, "gender", hard_NA = TRUE))), expect_true())
+    expect_true(length(table(get_pairwise(x, "gender", hard_NA = FALSE))) >
+                length(table(get_pairwise(x, "gender", hard_NA = TRUE))))
 
 })
 

tests/testthat/test_subset.epicontacts.R

@@ -110,14 +110,44 @@ test_that("Returns epicontacts object subsetted correctly", {
 
 
     id <- names(which.max(get_degree(x, "out")))
+
+    ## check subset with thinning
+    ## check that all ids in contact and linelist are in the same cluster as id,
+    ## and check that no ids from other clusters are in contact or linelist.
+    ## with thinning this means all cases must also be in the linelist
     z <- thin(subset(x, cluster_id = id), 2)
+    clust <- get_clusters(x, output = "data.frame")
+    clust_id <- clust$cluster_member[match(id, clust$id)]
+    are_in_clust_cont <- sort(unique(unlist(z$contacts[1:2],
+                                            use.names = FALSE)))
+    are_in_clust_ll <- sort(z$linelist$id)
+    should_in_clust <- sort(clust$id[clust$cluster_member == clust_id])
+    should_in_clust <- should_in_clust[should_in_clust %in% x$linelist$id]
+    expect_equal(should_in_clust, are_in_clust_cont)
+    expect_equal(should_in_clust, are_in_clust_ll)
+
+    ## check without thinning
+    ## in this case there can be cases in the contacts and not in the linelist
+    w <- subset(x, cluster_id = id)
+    should_in_clust <- sort(clust$id[clust$cluster_member == clust_id])
+    are_in_clust <- sort(unique(unlist(w$contacts[1:2], use.names = FALSE)))
+    expect_equal(should_in_clust, are_in_clust)
+
+    ## check k subsetting
     nocoords <- grep("(lat|lon)", names(z$linelist), perl = TRUE, invert = TRUE) - 1
-    expect_equal_to_reference(z[k = nocoords], file = "rds/z.rds")
+    k_sub <- z[k = nocoords]
+
+    ## check correct columns have been subsetted
+    expect_equal(names(z$linelist)[nocoords + 1], names(k_sub$linelist))
 
+    ## check contacts haven't been changed
+    expect_equal(z$contacts, k_sub$contacts)
 
+    ## compare to reference
+    expect_equal_to_reference(k_sub, file = "rds/z.rds")
+
     zz <- subset(x, cs = 10)
     expect_equal_to_reference(zz[k = nocoords], file = "rds/zz.rds")
     expect_true(all(get_clusters(zz, "data.frame")$cluster_size == 10L))
 
-
 })