Merge pull request #203 from fdchevalier/pie_circle

Nodes of single population improved
grunwaldlab · May 2, 2019 · 0b8d9ed · 0b8d9ed
2 parents 084ee5e + 1cf5ba9
commit 0b8d9ed
Show file tree

Hide file tree

Showing 4 changed files with 25 additions and 3 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -19,6 +19,8 @@ Authors@R: c(person(c("Zhian", "N."), "Kamvar", role = c("cre", "aut"),
     email = "briank.lists@gmail.com", comment = c(ORCID = "0000-0003-1665-4343")),
     person(c("Patrick", "G."), "Meirmans", role = "ctb",
     email = "p.g.meirmans@uva.nl", comment = c(ORCID = "0000-0002-6395-8107")),
+    person(c("Frédéric", "D."), "Chevalier", role = "ctb",
+    email = "fcheval@txbiomed.org", comment = c(ORCID = "0000-0003-2611-8106")),
     person(c("Niklaus", "J."), "Grunwald", role = "ths",
     email = "grunwaln@science.oregonstate.edu", comment = c(ORCID = "0000-0003-1656-7602")))
 Maintainer: Zhian N. Kamvar <zkamvar@gmail.com>

diff --git a/R/internal.r b/R/internal.r
@@ -1489,6 +1489,13 @@ update_poppr_graph <- function(graphlist, PALETTE){
   if (nrow(lookup) > 1){
     colorlist                    <- V(graphlist$graph)$pie.color
     V(graphlist$graph)$pie.color <- lapply(colorlist, update_colors, lookup)
+    # Update color vector for circles if present
+    pie.single <- lengths(V(graphlist$graph)$pie) == 1
+    if (any(pie.single)) {
+      the_circles <- unlist(V(graphlist$graph)$pie.color[pie.single])
+      V(graphlist$graph)$color[pie.single]        <- the_circles        # set the color palette
+      names(V(graphlist$graph)$color)[pie.single] <- names(the_circles) # set the population names
+    }
   } else {
     colorlist <- V(graphlist$graph)$color
     V(graphlist$graph)$color <- rep(PALETTE(1), length(colorlist))

diff --git a/R/msn_handlers.R b/R/msn_handlers.R
@@ -151,6 +151,17 @@ msn_constructor <-
     mlg.cp <- mlg.cp[rank(cmlg)]  
     # This creates a list of colors corresponding to populations.
     mlg.color <- lapply(mlg.cp, function(x) color[pnames %in% names(x)])
+    # Set shape and circle color vectors
+    mlg.sp        <- rep("pie", length(mlg.cp)) # set shape
+    names(mlg.sp) <- names(mlg.cp)
+    mlg.cc        <- rep(NA, length(mlg.cp)) # set circle color
+    names(mlg.cc) <- names(mlg.cp)
+    # Transform pie made of single population into circle
+    pie.single    <- lengths(mlg.cp) == 1
+    if (any(pie.single)) {
+      mlg.sp[pie.single] <- "circle"
+      mlg.cc[pie.single] <- unlist(mlg.color[pie.single])
+    }
   }
 
 
@@ -194,9 +205,10 @@ msn_constructor <-
         edge.width = E(mst)$width,
         edge.color = E(mst)$color,
         vertex.size = sqrt(mlg.number) * 5,
-        vertex.shape = "pie",
+        vertex.shape = mlg.sp,
         vertex.pie = mlg.cp,
         vertex.pie.color = mlg.color,
+        vertex.color = mlg.cc,
         vertex.label = vlab,
         ...
       )      
@@ -227,9 +239,10 @@ msn_constructor <-
 
   V(mst)$size  <- sqrt(mlg.number)
   if (piece_of_pie){
-    V(mst)$shape     <- "pie"
+    V(mst)$shape     <- mlg.sp
     V(mst)$pie       <- mlg.cp
     V(mst)$pie.color <- mlg.color    
+    V(mst)$color     <- mlg.cc
   } else {
     V(mst)$color     <- color
   }

diff --git a/tests/testthat/test-msn.R b/tests/testthat/test-msn.R
@@ -127,7 +127,7 @@ sbruv_no_ties <- bruvo.msn(gend_single, replen = c(1,1), showplot = FALSE)
 sbruv_ties    <- bruvo.msn(gend_single, replen = c(1,1), showplot = FALSE, include.ties = TRUE)
 spmsn_no_ties <- poppr.msn(gend_single, distmat = gend_bruvo, showplot = FALSE)
 spmsn_ties    <- poppr.msn(gend_single, distmat = gend_bruvo, showplot = FALSE, include.ties = TRUE)
-pienames      <- c("name", "size", "shape", "pie", "pie.color", "label")
+pienames      <- c("name", "size", "shape", "pie", "pie.color", "color", "label")
 nopienames    <- c("name", "size", "color", "label")
 
 context("Input parameter tests")