Named vector color support for desplot & ggdesplot

R/desplot.R

@@ -410,7 +410,23 @@ desplot <- function(data,
                        "#9980FF","#E680FF","#D0D192","#59FF9C","#FFA24D",
                        "#FBFF4D","#4D9FFF","#704DFF","#DB4DFF","#808080",
                        "#9FFF40","#C9CC3D")
-    col.regions <- rep(col.regions, length=fill.n)
+    # Handle named vectors for col.regions
+    if(!is.null(names(col.regions))) {
+      fill.levels <- levels(fill.val)
+      matched_colors <- col.regions[fill.levels]
+      # Check if all levels were matched
+      if(any(is.na(matched_colors))) {
+        missing_levels <- fill.levels[is.na(matched_colors)]
+        warning("col.regions: Not all factor levels found in provided names. ",
+                "Missing: ", paste(missing_levels, collapse=", "),
+                ". Falling back to positional matching.")
+        col.regions <- rep(col.regions, length=fill.n)
+      } else {
+        col.regions <- as.vector(matched_colors)
+      }
+    } else {
+      col.regions <- rep(col.regions, length=fill.n)
+    }
     at <- c((0:fill.n)+.5)
   } else if(fill.type=="num") {
     if(missing(at) && is.null(midpoint)){
@@ -546,7 +562,22 @@ desplot <- function(data,
     col.n <- length(lt.col)
     lr <- lr + 2 + col.n
     lt <- c(lt, lt.col)
-    if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
+    # Handle named vectors for col.text
+    if(!is.null(names(col.text))) {
+      matched_colors <- col.text[lt.col]
+      # Check if all levels were matched
+      if(any(is.na(matched_colors))) {
+        missing_levels <- lt.col[is.na(matched_colors)]
+        warning("col.text: Not all factor levels found in provided names. ",
+                "Missing: ", paste(missing_levels, collapse=", "),
+                ". Falling back to positional matching.")
+        if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
+      } else {
+        col.text <- as.vector(matched_colors)
+      }
+    } else {
+      if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
+    }
   } else {
     col.val <- rep(1, nrow(data)) # No color specified, use black by default
   }

R/ggdesplot.R

@@ -259,7 +259,23 @@ ggdesplot <- function(data,
                        "#9980FF","#E680FF","#D0D192","#59FF9C","#FFA24D",
                        "#FBFF4D","#4D9FFF","#704DFF","#DB4DFF","#808080",
                        "#9FFF40","#C9CC3D")
-    col.regions <- rep(col.regions, length=fill.n)
+    # Handle named vectors for col.regions
+    if(!is.null(names(col.regions))) {
+      fill.levels <- levels(fill.val)
+      matched_colors <- col.regions[fill.levels]
+      # Check if all levels were matched
+      if(any(is.na(matched_colors))) {
+        missing_levels <- fill.levels[is.na(matched_colors)]
+        warning("col.regions: Not all factor levels found in provided names. ",
+                "Missing: ", paste(missing_levels, collapse=", "),
+                ". Falling back to positional matching.")
+        col.regions <- rep(col.regions, length=fill.n)
+      } else {
+        col.regions <- as.vector(matched_colors)
+      }
+    } else {
+      col.regions <- rep(col.regions, length=fill.n)
+    }
     at <- c((0:fill.n)+.5)
   } else if(fill.type=="num") {
     if(missing(at) && is.null(midpoint)){
@@ -388,7 +404,22 @@ ggdesplot <- function(data,
     col.n <- length(lt.col)
     lr <- lr + 2 + col.n
     lt <- c(lt, lt.col)
-    if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
+    # Handle named vectors for col.text
+    if(!is.null(names(col.text))) {
+      matched_colors <- col.text[lt.col]
+      # Check if all levels were matched
+      if(any(is.na(matched_colors))) {
+        missing_levels <- lt.col[is.na(matched_colors)]
+        warning("col.text: Not all factor levels found in provided names. ",
+                "Missing: ", paste(missing_levels, collapse=", "),
+                ". Falling back to positional matching.")
+        if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
+      } else {
+        col.text <- as.vector(matched_colors)
+      }
+    } else {
+      if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
+    }
   } else {
     col.val <- rep(1, nrow(data)) # No color specified, use black by default
   }

test_named_colors.R

@@ -0,0 +1,44 @@
+# Test Script for Named Vector Color Support - Issue #10
+library(desplot)
+
+# Simple test data: 2 rows x 3 columns, 3 factor levels
+test_data <- data.frame(
+  row = rep(1:2, each=3),
+  col = rep(1:3, times=2),
+  treat = factor(rep(c("A", "B", "C"), length.out=6))
+)
+
+# TEST 1: Named vector - forward order
+my_colors <- c("skyblue", "pink", "lightgreen")
+names(my_colors) <- c("A", "B", "C")
+desplot(test_data, treat ~ col*row, col.regions=my_colors, main="Test 1: Named forward", gg=FALSE)
+desplot(test_data, treat ~ col*row, col.regions=my_colors, main="Test 1: Named forward (gg)", gg=TRUE)
+
+# TEST 2: Named vector - reversed order (KEY TEST from issue #10)
+my_colors_rev <- c("skyblue", "pink", "lightgreen")
+names(my_colors_rev) <- c("C", "B", "A")  # REVERSED!
+desplot(test_data, treat ~ col*row, col.regions=my_colors_rev, main="Test 2: Named reversed", gg=FALSE)
+desplot(test_data, treat ~ col*row, col.regions=my_colors_rev, main="Test 2: Named reversed (gg)", gg=TRUE)
+
+# TEST 3: Partial names (should warn and fallback)
+partial_colors <- c("red", "blue")
+names(partial_colors) <- c("A", "B")  # Missing C
+desplot(test_data, treat ~ col*row, col.regions=partial_colors, main="Test 3: Partial names", gg=FALSE)
+desplot(test_data, treat ~ col*row, col.regions=partial_colors, main="Test 3: Partial names (gg)", gg=TRUE)
+
+# TEST 4: Extra names (should work, extras ignored)
+extra_colors <- c("purple", "orange", "brown", "yellow")
+names(extra_colors) <- c("A", "B", "C", "D")  # D doesn't exist
+desplot(test_data, treat ~ col*row, col.regions=extra_colors, main="Test 4: Extra names", gg=FALSE)
+desplot(test_data, treat ~ col*row, col.regions=extra_colors, main="Test 4: Extra names (gg)", gg=TRUE)
+
+# TEST 5: Unnamed vector (backward compatibility)
+unnamed_colors <- c("coral", "cyan", "gold")
+desplot(test_data, treat ~ col*row, col.regions=unnamed_colors, main="Test 5: Unnamed", gg=FALSE)
+desplot(test_data, treat ~ col*row, col.regions=unnamed_colors, main="Test 5: Unnamed (gg)", gg=TRUE)
+
+# TEST 6: Named col.text (outline colors)
+text_colors <- c("red", "blue", "green")
+names(text_colors) <- c("C", "B", "A")  # Reversed
+desplot(test_data, treat ~ col*row, col=treat, col.text=text_colors, main="Test 6: Named col.text", gg=FALSE)
+desplot(test_data, treat ~ col*row, col=treat, col.text=text_colors, main="Test 6: Named col.text (gg)", gg=TRUE)