diff --git a/R/desplot.R b/R/desplot.R index bb62c83..818b839 100644 --- a/R/desplot.R +++ b/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 } diff --git a/R/ggdesplot.R b/R/ggdesplot.R index 43187ff..f916b80 100644 --- a/R/ggdesplot.R +++ b/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 } diff --git a/test_named_colors.R b/test_named_colors.R new file mode 100644 index 0000000..686ca7c --- /dev/null +++ b/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)