Question

我创建了金字塔般的情节，我想为情节的每一面添加标签（类似于构面标签）。

我的数据：

dt <- data.frame(Answer = factor(x = rep(x = c(1:3), times = 2), 
                                 labels = c("Yes", "No", "Maybe")), 
                 Gender = factor(x = rep(x = c(1:2), each = 3),
                                 labels = c("Female", "Male")), 
                 Prc = c(74.4, 25.0, 0.6, 61.3, 35.5, 3.2), 
                 label = c("74.4%", "25.0%", "0.6%", "61.3%", "35.5%", "3.2%"))

我的情节：
Pyramid like plot

我的剧情生成代码：

xmi <- -70
xma <- 80

library(ggplot2)
ggplot(data = dt, aes(x = Answer, fill = Gender)) +
    geom_bar(stat = "identity", subset = .(Gender == "Female"), aes(y = Prc)) +
    geom_text(subset = .(Gender == "Female"), aes(y = Prc, label = label), size = 4, hjust = -0.1) +
    geom_bar(stat = "identity", subset = .(Gender == "Male"), aes(y=Prc * (-1)) ) +
    geom_text(subset = .(Gender == "Male"), aes(y = Prc * (-1), label = label), size = 4, hjust = 1) +
    scale_y_continuous(limits = c(xmi, xma), breaks=seq(xmi, xma,10),labels=abs(seq(xmi, xma,10))) + 
    theme(axis.text = element_text(colour = "black"), 
          plot.title = element_text(lineheight=.8) ) + 
    coord_flip() + 
    annotate("text", x = 3.3, y = -50, label = "Male", fontfacet = "bold") + 
    annotate("text", x = 3.3, y = 50, label = "Female", fontfacet = "bold") + 
    ylab("") + xlab("") + guides(fill=FALSE)

rm(xmi, xma)

分面标签标签示例：

Facet plot

问题是：
1.如何将小平面标签添加到金字塔中，如图;
OR
也许有更好的方法让金字塔像地块一样。

Answer 1

一些可能性。前两个从头开始构造条带（即刻面标签）。两者的不同之处在于它们定位带状凹槽的方式。第三个是金字塔图，类似于here构建的图，但稍微整理一下。

library(ggplot2)

dt <- data.frame(Answer = factor(x = rep(x = c(1:3), times = 2), 
                                 labels = c("Yes", "No", "Maybe")), 
                 Gender = factor(x = rep(x = c(1:2), each = 3),
                                 labels = c("Female", "Male")), 
                 Prc = c(74.4, 25.0, 0.6, 61.3, 35.5, 3.2), 
                 label = c("74.4%", "25.0%", "0.6%", "61.3%", "35.5%", "3.2%")) 

xmi <- -100
xma <- 100

p = ggplot(data = dt, aes(x = Answer, fill = Gender)) +
    geom_bar(stat = "identity", data = subset(dt, Gender == "Female"), aes(y = Prc)) +
    geom_text(data = subset(dt, Gender == "Female"), aes(y = Prc, label = label), 
      size = 4, hjust = -0.1) +
    geom_bar(stat = "identity", data = subset(dt, Gender == "Male"), aes(y=Prc * (-1)) ) +
    geom_text(data = subset(dt, Gender == "Male"), aes(y = Prc * (-1), label = label), 
      size = 4, hjust = 1.1) +
    scale_y_continuous(limits = c(xmi, xma), breaks = seq(xmi, xma, 10), labels = abs(seq(xmi, xma, 10))) + 
    theme(axis.text = element_text(colour = "black")) + 
    coord_flip() + 
     ylab("") + xlab("") + guides(fill = FALSE) +
    theme(plot.margin = unit(c(2, 1, 1, 1), "lines"))


## Method 1
# Construct the strip
library(grid)

strip = gTree(name = "Strip", 
   children = gList(
     rectGrob(gp = gpar(col = NA, fill = "grey85")),
     textGrob("Female", x = .75, gp = gpar(fontsize = 8.8, col = "grey10")), 
     textGrob("Male", x = .25, gp = gpar(fontsize = 8.8, col = "grey10")),
     linesGrob(x = .5, gp = gpar(col = "grey95"))))

# Position strip using annotation_custom
p1 = p + annotation_custom(strip, xmin = Inf, xmax = 3.75, ymax = Inf, ymin = -Inf) 

g = ggplotGrob(p1)

# The strip is positioned outside the panel,
# therefore turn off clipping to the panel.
g$layout[g$layout$name=='panel', "clip"] = "off"

# Draw it
grid.newpage()
grid.draw(g)

## Method 2 
# Construct the strip
# Note the viewport; in particular its position and justification 
library(gtable)

fontsize = 8.8
gp = gpar(fontsize = fontsize, col = "grey10")
textGrobF = textGrob("Female", x = .75, gp = gp)
textGrobM =  textGrob("Male", x = .25, gp = gp)

strip = gTree(name = "Strip", 
   vp = viewport(y = 1, just = "bottom", height = unit(2.5, "grobheight", textGrobF)),
   children = gList(
     rectGrob(gp = gpar(col = NA, fill = "grey85")),
     textGrobF, 
     textGrobM,                                         
     linesGrob(x = .5, gp = gpar(col = "grey95"))))

g = ggplotGrob(p)

# Position strip using the gtable function, gtable_add_grob
# Strip is positioned in the plot panel,
# but because of the justification of strip's viewport,
# the strip is drawn outside the panel

# First, get the panel's position in the layout
pos = g$layout[grepl("panel", g$layout$name), c("t","l")]

g = gtable_add_grob(g, strip, t = pos$t, l = pos$l, clip = "off")

grid.newpage()
grid.draw(g)

## Method 3
# Pyramid plot
library(ggplot2)
library(scales)
library(stringr)
library(gtable)
library(grid)

df = dt

# Common theme
theme = theme(panel.grid.minor = element_blank(),
         panel.grid.major = element_blank(), 
         axis.text.y = element_blank(), 
         axis.title.y = element_blank(),
         plot.title = element_text(size = 10, hjust=0.5))


#### 1. "male" plot - to appear on the right
ggM <- ggplot(data = subset(df, Gender == 'Male'), aes(x = Answer)) +
   geom_bar(aes(y = .01*Prc), stat = "identity", fill = "skyblue", width = .5) +
    geom_text(data = subset(dt, Gender == "Male"), aes(y = .01*Prc, label = label), hjust = -.1, size = 4) +
   scale_y_continuous('', limits = c(0, 1), expand = c(0, 0), labels = percent) + 
   labs(x = NULL) +
   ggtitle("Male") +
   coord_flip() + theme +
   theme(plot.margin= unit(c(1, 1, 0, 0), "lines"))

# get ggplot grob
gtM <- ggplotGrob(ggM)


#### 2. "female" plot - to appear on the left - 
# reverse the 'Percent' axis using trans = "reverse"
ggF <- ggplot(data = subset(df, Gender == 'Female'), aes(x = Answer)) +
   geom_bar(aes(y = .01*Prc), stat = "identity", fill = "salmon", width = .5) +
   geom_text(data = subset(dt, Gender == "Female"), aes(y = .01*Prc, label = label), hjust = 1.1, size = 4) +
   scale_y_continuous('', limits = c(1, 0), trans = "reverse", expand = c(0, 0), labels = percent) + 
   labs(x = NULL) +
   ggtitle("Female") +
   coord_flip() + theme +
   theme(plot.margin= unit(c(1, 0, 0, 1), "lines"))

# get ggplot grob
gtF <- ggplotGrob(ggF)

## Swap the tick marks to the right side of the plot panel
# Get the row number of the left axis in the layout
rn <- which(gtF$layout$name == "axis-l")

# Extract the axis (tick marks and axis text)
axis.grob <- gtF$grobs[[rn]]
axisl <- axis.grob$children[[2]]  # Two children - get the second
# axisl  # Note: two grobs -  text and tick marks

# Get the tick marks - NOTE: tick marks are second
yaxis = axisl$grobs[[2]] 
yaxis$x = yaxis$x - unit(1, "npc") + unit(2.75, "pt") # Reverse them

# Add them to the right side of the panel
# Add a column to the gtable
gtF <- gtable_add_cols(gtF, gtF$widths[3], length(gtF$widths) - 1)
# Add the grob
pos = gtF$layout[grepl("panel", gtF$layout$name), "t"]
gtF <-  gtable_add_grob(gtF, yaxis, t = pos, length(gtF$widths) - 1)

# Remove original left axis
gtF = gtF[,-c(2,3)] 


#### 3. Answer labels - create a plot using geom_text - to appear down the middle
fontsize = 3
ggC <- ggplot(data = subset(df, Gender == 'Male'), aes(x=Answer)) +
   geom_bar(stat = "identity", aes(y = 0)) +
   geom_text(aes(y = 0,  label = Answer), size = fontsize) +
   ggtitle("Answer") +
   coord_flip() + theme_bw() + theme +
   theme(panel.border = element_rect(colour = NA))

# get ggplot grob
gtC <- ggplotGrob(ggC)

# Get the title
Title = gtC$grobs[[which(gtC$layout$name == "title")]]

# Get the plot panel
gtC = gtC$grobs[[which(gtC$layout$name == "panel")]]


#### 4. Arrange the components
## First, combine "female" and "male" plots
gt = cbind(gtF, gtM, size = "first")

## Second, add the labels (gtC) down the middle
# Add column to gtable
maxlab = df$Answer[which(str_length(df$Answer) == max(str_length(df$Answer)))]
gt = gtable_add_cols(gt, sum(unit(1, "grobwidth", textGrob(maxlab, gp = gpar(fontsize = fontsize*72.27/25.4))), unit(5, "mm")), 
           pos = length(gtF$widths))

# Add the Answer grob
gt = gtable_add_grob(gt, gtC, t = pos, l = length(gtF$widths) + 1)

# Add the title; ie the label 'Answer' 
gt = gtable_add_grob(gt, Title, t = 3, l = length(gtF$widths) + 1)


### 5. Draw the plot
grid.newpage()
grid.draw(gt)

R如何在ggplot2中为金字塔添加facet标签

1 个答案: