我有這個資料框：
library(likert)
library(ggplot2)
DF<-data.frame(A=c(1,2,3,4,5),B=c(2,3,4,5,1),C=c(3,1,2,4,5),D=c(2,3,4,5,1),E=c(1,2,4,3,5))
categories<-c("A","B","C","D","E")
我將觀察結果轉換為因子，并使用likert包創建了一個 likert 物件：
DF <- DF %>%
mutate(across(contains(categories), ~ ordered(., levels = c(1,2,3,4,5),labels = c(1,2,3,4,5))))
likert_data<-likert(DF)
likert.plot現在我使用同一個包中的函式創建下圖：
plot(likert_data,plot.percent.neutral=F,center=3.5)
我想做的是根據類別（A，B，C，D，E）更改每個條的顏色，所以得到這樣的東西：
傳說不一定是這樣的。我知道如何更改整個圖形的顏色，但不知道如何更改單個條形的顏色。你有什么建議嗎？謝謝！
uj5u.com熱心網友回復：
根據您的評論，我在最后添加了更多資訊。
原始答案
這使用庫shades、ggplotify、grid、gtable和gridExtra。
我將首先提供代碼。在那之后，我用解釋把它分解了。
library(likert)
library(tidyverse)
library(shades) # for colors
library(ggplotify) # change back to ggplot
library(gtable)
library(grid)
library(gridExtra)
x = plot(likert_data, plot.percent.neutral = F,
center = 3.5, group = categories)
x
xx <- plot(likert_data, plot.percent.neutral = F,
center = 3.5, group = categories)
theme(legend.position = "none") # <------ no legend
y <- ggplotGrob(xx) # make it a grid object
filling <- which(grepl("#5AB4AC", y$grobs)) # returned 6, 15
#------------- modify the plot -------------
for(each in y$grobs[[6]]$children) { # find where fill used
print(each)
print(each$gp$fill)
}
# make color gradients for new color gradients
rainbow <- c(gradient(c("darkred", "mistyrose"), 3),
gradient(c("#FF7F00", "lightgoldenrod"), 3),
gradient(c("darkgreen", "lightgreen"), 3),
gradient(c("darkblue", "lightblue"), 3),
gradient(c("purple4", "plum"), 3))
# light gray, dark gray
greys = c("gray74", "gray40")
# first pallet has those colors left of the 0 line
# get the light values out of the rainbow of colors
whL <- seq(3, length(rainbow), by = 3)
negs <- c(rev(rainbow[whL]), rep(greys, each = 5))
y$grobs[[6]]$children[[4]]$gp$fill <- negs # add to the plot
# get the remaining colors out of the rainbow
rainGp <- c(seq(2, length(rainbow), by = 3), seq(1, length(rainbow), by = 3))
rainbow2 <- rainbow[rainGp] # select only those that apply
y$grobs[[6]]$children[[5]]$gp$fill <- rainbow2 # add to the plot
grid::grid.draw(y) # take a look using grid
(xx <- as.ggplot(y)) # or you can look as ggplot object (it's the same)
#------------- create the legend -------------
x2 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[1:3])), name = "")
redLeg <- gtable_filter(ggplot_gtable(ggplot_build(x2)), "guide-box")
x3 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[4:6])), name = "")
orgLeg <- gtable_filter(ggplot_gtable(ggplot_build(x3)), "guide-box")
x4 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[7:9])), name = "")
grnLeg <- gtable_filter(ggplot_gtable(ggplot_build(x4)), "guide-box")
x5 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[10:12])), name = "")
bluLeg <- gtable_filter(ggplot_gtable(ggplot_build(x5)), "guide-box")
x6 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[13:15])), name = "")
purLeg <- gtable_filter(ggplot_gtable(ggplot_build(x6)), "guide-box")
# get legends' object names
lgs <- grep("Leg", names(.GlobalEnv), value = T)
# fix order <------- order may be different you on your computer
lgs <- lgs[c(4, 3, 2, 5, 1)]
lgs <- lapply(lgs, get) # capture objects instead of strings
legging <- do.call("rbind", lgs) # make this one gtable instead of 5
gb <- textGrob("Response", x = 1, y = .5, just = c("right", "center"))
arr <- arrangeGrob(grobs = list(gb, legging), widths = c(1, 2),
ncol = 2, nrow = 1, padding = 0)
#------------ the plot's ready --------------
# new plot object
grid.arrange(xx, arr, heights = c(7, 3), nrow = 2, ncol = 1)
所有這一切：
除了將李克特圖分配給物件之外，我沒有更改您提供的代碼。
我還創建了另一個沒有圖例的版本。首先，您將使用沒有圖例的情節（以后制作圖例時除外）。
x = plot(likert_data, plot.percent.neutral = F,
center = 3.5, group = categories)
xx <- plot(likert_data, plot.percent.neutral = F,
center = 3.5, group = categories)
theme(legend.position = "none")
使用幫助，我發現李克特圖的頂部默認顏色是#5AB4AC，所以我使用該資訊搜索ggplotGrob.
y <- ggplotGrob(xx)
filling <- which(grepl("#5AB4AC", y$grobs)) # returned 6, 15
這將回傳第 6 個 grob 和第 15 個 grob 包含分配給此顏色的內容。首先是劇情。二是傳說。
改變情節
接下來，我進一步研究了圖中的顏色分配。我需要看看背景中的顏色是如何分解的。
for(each in y$grobs[[6]]$children) {
print(each)
print(each$gp$fill)
}
從for電話中，我發現我需要查看第 6 個 grob 中的第 4 個和第 5 個孩子。
這是從 for 陳述句回傳的內容（截斷僅顯示第 4 個和第 5 個孩子）。
# rect[geom_rect.rect.871]
# [1] "#F2E5CB" "#F2E5CB" "#F2E5CB" "#F2E5CB" "#F2E5CB" "#E5CC98" "#E5CC98"
# [8] "#E5CC98" "#E5CC98" "#E5CC98" "#D8B365" "#D8B365" "#D8B365" "#D8B365"
# [15] "#D8B365"
# rect[geom_rect.rect.873]
# [1] "#ACD9D5" "#ACD9D5" "#ACD9D5" "#ACD9D5" "#ACD9D5" "#5AB4AC" "#5AB4AC"
# [8] "#5AB4AC" "#5AB4AC" "#5AB4AC"
你可以看到我提到的顏色只有第5個孩子。您在這里看到的是，第 4 個孩子的這些值位于垂直線左側的 x 軸上為零。第 5 個孩子有兩個最高的反應；垂直零線右側的兩個。
接下來，我創建了一個調色板來替換這些顏色。
rainbow <- c(gradient(c("darkred", "mistyrose"), 3),
gradient(c("#FF7F00", "lightgoldenrod"), 3),
gradient(c("darkgreen", "lightgreen"), 3),
gradient(c("darkblue", "lightblue"), 3),
gradient(c("purple4", "plum"), 3))
我嘗試了幾種不同的方法來讓它更加動態，但是顏色強度真的不均勻，所以我手動設定它。
接下來是兩種灰色。
# light gray, dark gray
greys = c("gray74", "gray40")
要重置第四個孩子的顏色，我需要替換李克特回應 1、2 和 3 的顏色。所以我需要從rainbow.
whL <- seq(3, length(rainbow), by = 3)
negs <- c(rev(rainbow[whL]), rep(greys, each = 5))
y$grobs[[6]]$children[[4]]$gp$fill <- negs # add to the plot
現在是時候更改 4 和 5 的李克特回應了。
# get the remaining colors out of the rainbow
rainGp <- c(seq(2, length(rainbow), by = 3), seq(1, length(rainbow), by = 3))
rainbow2 <- rainbow[rainGp] # select only those that apply
y$grobs[[6]]$children[[5]]$gp$fill <- rainbow2 # add to the plot
在這一點上，你的情節的顏色都改變了。
grid::grid.draw(y) # take a look using grid
(xx <- as.ggplot(y)) # or you can look as ggplot object (it's the same)
改變傳奇
我沒有重新發明輪子，而是為我ggplot創造了傳奇。本質上，我將繪制五次圖表——每個顏色組一次。每次繪制它時，我都會將所有內容都設為一個顏色組。（例如，第一個僅使用紅色陰影。）創建繪圖后，我使用gtable提取圖例。
x2 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[1:3])), name = "")
x2
redLeg <- gtable_filter(ggplot_gtable(ggplot_build(x2)), "guide-box")
x3 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[4:6])), name = "")
x3
orgLeg <- gtable_filter(ggplot_gtable(ggplot_build(x3)), "guide-box")
x4 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[7:9])), name = "")
x4
grnLeg <- gtable_filter(ggplot_gtable(ggplot_build(x4)), "guide-box")
x5 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[10:12])), name = "")
x5
bluLeg <- gtable_filter(ggplot_gtable(ggplot_build(x5)), "guide-box")
x6 <- x scale_fill_manual(values = c(rev(greys), rev(rainbow[13:15])), name = "")
x6
purLeg <- gtable_filter(ggplot_gtable(ggplot_build(x6)), "guide-box")
我本可以將這些圖例中的每一個都添加到串列中，但我只是將它們稱為串列。由于它會搜索環境，因此不知道您將按什么順序將它們放回原處。我已在此處修復了順序，但在您的設備上可能會有所不同。
在收集他們的名字并將它們按順序排列之后，我get將它們（從字串更改為物件），然后將它們系結到一個gtable.
# get legends' object names
lgs <- grep("Leg", names(.GlobalEnv), value = T)
# fix order <------- order may be different you on your computer
lgs <- lgs[c(4, 3, 2, 5, 1)]
lgs <- lapply(lgs, get) # capture objects instead of strings
legging <- do.call("rbind", lgs) # make this one gtable instead of 5
此時您實際上可以使用grid.draw().
現在我已經有了圖例，我將添加圖例標簽“回應”。（我把它取下來是因為每串顏色看起來很奇怪。）
接下來，將合并的圖例和標簽放在一個物件中。
# legend title
gb <- textGrob("Response", x = 1, y = .5, just = c("right", "center"))
# consolidate legend title and legends
arr <- arrangeGrob(grobs = list(gb, legging), widths = c(1, 2),
ncol = 2, nrow = 1, padding = 0)
接下來，結合顏色變化的情節和顏色變化的圖例。（你完成了！）
# new plot object
grid.arrange(xx, arr, heights = c(6, 4), nrow = 2, ncol = 1)
您可能需要在heights此處進行調整。它不是相對的，因此根據您的使用方式，您可能需要進行調整。
基于您的評論的資訊
我創建了一些函式來完成大部分帶有多個約束的繪圖顏色更改作業。
我還沒有對此進行足夠的測驗，無法說明無論資料如何，它的作業效果如何。
這假設您將使用該論點center = 3.5并使用 1-5 的李克特量表。如果您不知道，對于李克特庫，您必須在每個問題中具有相同數量的級別才能繪制。（保留空白級別。）
library(likert)
library(tidyverse)
library(shades) # for colors
library(ggplotify) # change back to ggplot
library(gtable)
library(grid)
library(gridExtra)
x = plot(likert_data, plot.percent.neutral = F,
center = 3.5, group = categories)
xx <- plot(likert_data, plot.percent.neutral = F,
center = 3.5, group = categories)
theme(legend.position = "none") # <------ no legend
y <- ggplotGrob(xx) # make it a grid object
filling <- which(grepl("#5AB4AC", y$grobs)) # returned 6 (ran without legend)
#-------------- modify the plot ----------------
# this assumes that you have used the parameter center = 3.5 in Likert plot
# this works for 1-5 Likert questions (rows in the plot)
# assumes only 5 levels of Likert
# assumes there is at least 1 neg & 1 pos in each row!
defaultNeg = c("1" = "#D8B365", "2" = "#E5CC98", "3" = "#F2E5CB")
defaultPos = c("4" = "#ACD9D5", "5" = "#5AB4AC")
# make color gradients for new color gradients
grays = c("gray74", "gray40") # light gray, dark gray
rainbow <- c(gradient(c("darkred", "mistyrose"), 3),
gradient(c("#FF7F00", "lightgoldenrod"), 3),
gradient(c("darkgreen", "lightgreen"), 3),
gradient(c("darkblue", "lightblue"), 3),
gradient(c("purple4", "plum"), 3))
# this function is called with collector()
getY <- function(grob_sub, w, freq) {
# grob_sub, w: (wGrob) index of affected child;
# freq: number to filter for
wh <- table(grob_sub[[w]]$y %>% as.numeric()) %>%
as.data.frame() %>% mutate(id = 1:nrow(.)) %>%
filter(Freq < freq) %>% select(id) %>% unlist()
return(wh)
}
# this function is called within replaceFill()
collector <- function(grob_sub, what) { # what: either defaultNeg or defaultPos
idsL <- seq(length(rainbow), 3, by = -3) # set up for light & dark color extract
idsD <- c(seq(2, length(rainbow), by = 3), seq(1, length(rainbow), by = 3))
i = 0
for(each in grob_sub) { # find where fill used in children
i = i 1
if(is.null(each$gp$fill)) {next} # not it
else {
fills = each$gp$fill
if(length(fills) < 2) {next} # not it
if(any(fills %in% what)) {
wGrob = i # if contains the colors
break # no reason to keep looking
}
}
}
wCol <- grob_sub[[wGrob]]$gp$fill # get colors
# if there is a missing level
if(isTRUE(any(length(wCol)/5 != 10 & any(length(wCol)/5 != 15)))) {
# rule out the grey values (if they're missing no special handling needed)
tb <- table(wCol) %>% as.data.frame()
if(nrow(tb %>% filter(wCol == defaultNeg[3], Freq == 5)) > 0) {
break # move on, the item missing is a gray entry
}
if(nrow(tb %>% filter(wCol == defaultNeg[3], Freq < 5)) > 0) {
wh <- getY(grob_sub, wGrob, 3) # if light colors, there's 3 in each row
idsL <- idsL[-wh]
wCol[wCol == defaultNeg[3]] <- rainbow[idsL]
}
if(nrow(tb %>% filter(wCol %in% defaultPos, Freq < 5)) > 0) {
ins <- outs <- FALSE # is it an inner or outer color (or both)?
if(tb[1, "Freq"] < 5) {outs <- TRUE}
if(tb[2, "Freq"] < 5) {ins <- TRUE}
wh <- getY(grob_sub, wGrob, 2) # regardless of path are there three in each row?
if(isTRUE(all(ins, outs))) { # this is not handled at this time
message("Handling not added for multiple positive missing levels.")
} else if(isTRUE(ins)) {
idsD <- idsD[-wh]
wCol[wCol == defaultPos[1] | wCol == defaultPos[2]] <- rainbow[idsD]
} else if(isTRUE(outs)) {
idsD <- idsD[-wh]
wCol[wCol == defaultPos[1] | wCol == defaultPos[2]] <- rainbow[idsD]
}
}
}
else { # there are no missing levels starts here
if(defaultNeg[3] %in% wCol){ # if this one element is in the vector
wCol[wCol == defaultNeg[3]] <- rainbow[idsL] # change light colors
} else if(any(defaultPos %in% wCol)) {
wCol[wCol == defaultPos[1] | wCol == defaultPos[2]] <- rainbow[idsD]
}
} # regardless if something is missing, gray values are the same
if(any(wCol %in% defaultNeg[1:2])) {
wCol <- gsub(defaultNeg[1], grays[2], wCol)
wCol <- gsub(defaultNeg[2], grays[1], wCol)
}
return(list(wCol, wGrob)) # return colors and child indices
}
# grob_sub at plot level here this is y$grobs[[6]]$children
replaceFill <- function(grob_sub) {
negs <- collector(grob_sub, defaultNeg) # call for positives
poss <- collector(grob_sub, defaultPos) # call for negatives
return(list(negs, poss))
}
#--------------- make the legend & combine the plot -------------
makeLegends <- function(xx, x, rainbow) {
# xx is the plot with the fixed colors and no legend
# x is a plot with a legend
# rainbow 15 color array/vector will all of the non-gray colors
# ---
# create sequences for each part of the rainbow
cols <- c("red", "orange", "green", "blue", "purple")
i = 1
lgs = list()
for(each in cols) {
newX <- x
scale_fill_manual(values = c(rev(grays), rev(rainbow[i:(i 2)])), name = "")
lgs[[each]] <- gtable_filter(ggplot_gtable(ggplot_build(newX)), "guide-box")
i = i 3
}
legging <- do.call("rbind", lgs) # combine legends into one legend
# create legend title grob
tg <- textGrob("Response", x = 1, y = .5, just = c("right", "center"))
# assemble legends with legend title
arr <- arrangeGrob(grobs = list(tg, legging), widths = c(1, 2),
ncol = 2, nrow = 1, padding = 0)
result <- grid.arrange(xx, arr, heights = c(7, 3), nrow = 2, ncol = 1)
result
}
要使用這些功能，這是您需要做的。我添加了一個修改過的資料框來顯示當有空級別時會發生什么。
DF <- rbind(DF, DF) %>% mutate(B = ifelse(B == 3, 4, B),
C = ifelse(C == 4, 5, C)) %>%
mutate(across(contains(categories),
~ordered(., levels = c(1, 2, 3, 4, 5),
labels = c(1, 2, 3, 4, 5))))
# call the function to get the colors and ids
np <- replaceFill(y$grobs[[6]]$children)
# change the colors with the ids
y$grobs[[6]]$children[[np[[1]][[2]]]]$gp$fill <- np[[1]][[1]]
y$grobs[[6]]$children[[np[[2]][[2]]]]$gp$fill <- np[[2]][[1]]
#------------------------------ plot color finished
grid::grid.draw(y) # take a look using grid
(xx <- as.ggplot(y)) # or you can look as ggplot object (it's the same)
#------------ see the finished plot --------------
plt <- makeLegends(xx, x, rainbow) # create the finished plot
grid.newpage()
grid.draw(plt)
使用這些函式的修改后的資料產生了這個圖。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/523487.html