Skip to content

Commit f6c3f4d

Browse files
kwstatkwstat
authored
Merge pull request #16
Named vector color support for desplot & ggdesplot
2 parents 01934c5 + 788bca5 commit f6c3f4d

3 files changed

Lines changed: 110 additions & 4 deletions

File tree

‎R/desplot.R‎

Lines changed: 33 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -410,7 +410,23 @@ desplot <- function(data,
410410
"#9980FF","#E680FF","#D0D192","#59FF9C","#FFA24D",
411411
"#FBFF4D","#4D9FFF","#704DFF","#DB4DFF","#808080",
412412
"#9FFF40","#C9CC3D")
413-
col.regions <- rep(col.regions, length=fill.n)
413+
# Handle named vectors for col.regions
414+
if(!is.null(names(col.regions))) {
415+
fill.levels <- levels(fill.val)
416+
matched_colors <- col.regions[fill.levels]
417+
# Check if all levels were matched
418+
if(any(is.na(matched_colors))) {
419+
missing_levels <- fill.levels[is.na(matched_colors)]
420+
warning("col.regions: Not all factor levels found in provided names. ",
421+
"Missing: ", paste(missing_levels, collapse=", "),
422+
". Falling back to positional matching.")
423+
col.regions <- rep(col.regions, length=fill.n)
424+
} else {
425+
col.regions <- as.vector(matched_colors)
426+
}
427+
} else {
428+
col.regions <- rep(col.regions, length=fill.n)
429+
}
414430
at <- c((0:fill.n)+.5)
415431
} else if(fill.type=="num") {
416432
if(missing(at) && is.null(midpoint)){
@@ -546,7 +562,22 @@ desplot <- function(data,
546562
col.n <- length(lt.col)
547563
lr <- lr + 2 + col.n
548564
lt <- c(lt, lt.col)
549-
if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
565+
# Handle named vectors for col.text
566+
if(!is.null(names(col.text))) {
567+
matched_colors <- col.text[lt.col]
568+
# Check if all levels were matched
569+
if(any(is.na(matched_colors))) {
570+
missing_levels <- lt.col[is.na(matched_colors)]
571+
warning("col.text: Not all factor levels found in provided names. ",
572+
"Missing: ", paste(missing_levels, collapse=", "),
573+
". Falling back to positional matching.")
574+
if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
575+
} else {
576+
col.text <- as.vector(matched_colors)
577+
}
578+
} else {
579+
if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
580+
}
550581
} else {
551582
col.val <- rep(1, nrow(data)) # No color specified, use black by default
552583
}

‎R/ggdesplot.R‎

Lines changed: 33 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -259,7 +259,23 @@ ggdesplot <- function(data,
259259
"#9980FF","#E680FF","#D0D192","#59FF9C","#FFA24D",
260260
"#FBFF4D","#4D9FFF","#704DFF","#DB4DFF","#808080",
261261
"#9FFF40","#C9CC3D")
262-
col.regions <- rep(col.regions, length=fill.n)
262+
# Handle named vectors for col.regions
263+
if(!is.null(names(col.regions))) {
264+
fill.levels <- levels(fill.val)
265+
matched_colors <- col.regions[fill.levels]
266+
# Check if all levels were matched
267+
if(any(is.na(matched_colors))) {
268+
missing_levels <- fill.levels[is.na(matched_colors)]
269+
warning("col.regions: Not all factor levels found in provided names. ",
270+
"Missing: ", paste(missing_levels, collapse=", "),
271+
". Falling back to positional matching.")
272+
col.regions <- rep(col.regions, length=fill.n)
273+
} else {
274+
col.regions <- as.vector(matched_colors)
275+
}
276+
} else {
277+
col.regions <- rep(col.regions, length=fill.n)
278+
}
263279
at <- c((0:fill.n)+.5)
264280
} else if(fill.type=="num") {
265281
if(missing(at) && is.null(midpoint)){
@@ -388,7 +404,22 @@ ggdesplot <- function(data,
388404
col.n <- length(lt.col)
389405
lr <- lr + 2 + col.n
390406
lt <- c(lt, lt.col)
391-
if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
407+
# Handle named vectors for col.text
408+
if(!is.null(names(col.text))) {
409+
matched_colors <- col.text[lt.col]
410+
# Check if all levels were matched
411+
if(any(is.na(matched_colors))) {
412+
missing_levels <- lt.col[is.na(matched_colors)]
413+
warning("col.text: Not all factor levels found in provided names. ",
414+
"Missing: ", paste(missing_levels, collapse=", "),
415+
". Falling back to positional matching.")
416+
if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
417+
} else {
418+
col.text <- as.vector(matched_colors)
419+
}
420+
} else {
421+
if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n)
422+
}
392423
} else {
393424
col.val <- rep(1, nrow(data)) # No color specified, use black by default
394425
}

‎test_named_colors.R‎

Lines changed: 44 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
# Test Script for Named Vector Color Support - Issue #10
2+
library(desplot)
3+
4+
# Simple test data: 2 rows x 3 columns, 3 factor levels
5+
test_data <- data.frame(
6+
row = rep(1:2, each=3),
7+
col = rep(1:3, times=2),
8+
treat = factor(rep(c("A", "B", "C"), length.out=6))
9+
)
10+
11+
# TEST 1: Named vector - forward order
12+
my_colors <- c("skyblue", "pink", "lightgreen")
13+
names(my_colors) <- c("A", "B", "C")
14+
desplot(test_data, treat ~ col*row, col.regions=my_colors, main="Test 1: Named forward", gg=FALSE)
15+
desplot(test_data, treat ~ col*row, col.regions=my_colors, main="Test 1: Named forward (gg)", gg=TRUE)
16+
17+
# TEST 2: Named vector - reversed order (KEY TEST from issue #10)
18+
my_colors_rev <- c("skyblue", "pink", "lightgreen")
19+
names(my_colors_rev) <- c("C", "B", "A") # REVERSED!
20+
desplot(test_data, treat ~ col*row, col.regions=my_colors_rev, main="Test 2: Named reversed", gg=FALSE)
21+
desplot(test_data, treat ~ col*row, col.regions=my_colors_rev, main="Test 2: Named reversed (gg)", gg=TRUE)
22+
23+
# TEST 3: Partial names (should warn and fallback)
24+
partial_colors <- c("red", "blue")
25+
names(partial_colors) <- c("A", "B") # Missing C
26+
desplot(test_data, treat ~ col*row, col.regions=partial_colors, main="Test 3: Partial names", gg=FALSE)
27+
desplot(test_data, treat ~ col*row, col.regions=partial_colors, main="Test 3: Partial names (gg)", gg=TRUE)
28+
29+
# TEST 4: Extra names (should work, extras ignored)
30+
extra_colors <- c("purple", "orange", "brown", "yellow")
31+
names(extra_colors) <- c("A", "B", "C", "D") # D doesn't exist
32+
desplot(test_data, treat ~ col*row, col.regions=extra_colors, main="Test 4: Extra names", gg=FALSE)
33+
desplot(test_data, treat ~ col*row, col.regions=extra_colors, main="Test 4: Extra names (gg)", gg=TRUE)
34+
35+
# TEST 5: Unnamed vector (backward compatibility)
36+
unnamed_colors <- c("coral", "cyan", "gold")
37+
desplot(test_data, treat ~ col*row, col.regions=unnamed_colors, main="Test 5: Unnamed", gg=FALSE)
38+
desplot(test_data, treat ~ col*row, col.regions=unnamed_colors, main="Test 5: Unnamed (gg)", gg=TRUE)
39+
40+
# TEST 6: Named col.text (outline colors)
41+
text_colors <- c("red", "blue", "green")
42+
names(text_colors) <- c("C", "B", "A") # Reversed
43+
desplot(test_data, treat ~ col*row, col=treat, col.text=text_colors, main="Test 6: Named col.text", gg=FALSE)
44+
desplot(test_data, treat ~ col*row, col=treat, col.text=text_colors, main="Test 6: Named col.text (gg)", gg=TRUE)

0 commit comments

Comments
 (0)