使用 ggplot2 绘制时间线

Question

我有类似的数据

data = as.data.frame(  rbind(   c("1492", "Columbus sailed the ocean blue"),
                                c("1976", "Americans listened to Styx"),
                                c("2008", "financial meltdown. great.")
                                ))

我想在ggplot2 中构建一个绘图，它将显示时间箭头aes(x=$V1) 和aes(label=$V2) 文本。在我尝试绘制之前，这听起来很简单。

更新：不是我写的，但是你需要as.Date("1492", format="%Y")才能正确重现。

注意：下面给出的解决方案只处理发生在特定日期的事件，而不是带有“时期”或“时代”的时间线。

Answer 1

有时最简单的图形在 ggplot2 中是最难创建的，但它是可能的（而且很漂亮）。

data =data.frame( V1=c(1492,1976,2008),V2=c("Columbus sailed the ocean blue","Americans listened to Styx","financial meltdown"),disloc=c(-1,1,-.5))
dev.new()
ggplot() +
    geom_segment(aes(x = V1,y = disloc,xend = V1),data=data,yend = 0) +
    geom_segment(aes(x = 900,y = 0,xend = 2050,yend = 0),data=data,arrow = arrow(length = unit(x = 0.2,units = 'cm'),type = 'closed')) +
    geom_text(aes(x = V1,y = disloc,label = V2),data=data,hjust = 1.0,vjust = 1.0,parse = FALSE) +
    geom_point(aes(x = V1,y = disloc),data=data) +
    scale_x_continuous(breaks = c(1492,1976,2008),labels = c("1492","1976","2008")) +
    theme_bw() +
    opts(axis.text.x = theme_text(size = 12.0,angle = 90.0),axis.text.y = theme_blank(),axis.ticks = theme_blank(),axis.title.x = theme_blank(),axis.title.y = theme_blank())

注意：此图完全在 Deducer 的 ggplot2 Plot Builder 中生成

Answer 2

上面的ggplot2 版本的一个小变化，使用ggalt 中的geom_lollipop 并使用cowplot 作为漂亮的背景主题。将图形高度设置为漂亮且小且宽度较长很重要（在我的 RMarkdown 块中，我有 fig.height = 3 和 fig.width = 10）

我还使用了来自this question 的（稍作修改）函数，它有助于移动 x 轴（修改后的函数使用 annotate 而不是 geom_hline。这允许我添加一个箭头）。

抱歉，为简洁起见，我在这里使用了自己的数据。我得回去工作了！！

library(ggplot2)
library(dplyr)
library(ggalt)
library(cowplot)
library(tibble)
library(lubridate)

#Create data to plot
data <- tribble( ~start_date, ~event, ~displ,
                ymd(20160201), "Initial meeting with Renfrewshire", 1,
                ymd(20160430), "UBDC RAC submission", 0.7,
                ymd(20160524), "College Ethics Approval", 0.5,
                ymd(20160601), "UBDC RAC approval", -0.5,
                ymd(20161101), "Agreeement in Principal", 0.3,
                ymd(20170906), "DSA signed", 0.5,
                ymd(20170921), "Data transferred", -0.5,
                ymd(20180221), "Analysis complete", 0.5)


#Function to shift x-axis to 0 adapted from link shown above

shift_axis <- function(p, xmin, xmax, y=0){
      g <- ggplotGrob(p)
      dummy <- data.frame(y=y)
      ax <- g[["grobs"]][g$layout$name == "axis-b"][[1]]
      p + annotation_custom(grid::grobTree(ax, vp = grid::viewport(y=1, height=sum(ax$height))), 
                            ymax=y, ymin=y) +
        annotate("segment", y = 0, yend = 0, x = xmin, xend = xmax, 
                 arrow = arrow(length = unit(0.1, "inches"))) +
        theme(axis.text.x = element_blank(), 
              axis.ticks.x=element_blank())

    }


#Conditionally set whether text will be above or below the point
vjust = ifelse(data$displ > 0, -1, 1.5)

#plot
p1 <- data %>% 
  ggplot(aes(start_date, displ)) +
  geom_lollipop(point.size = 1) +
  geom_text(aes(x = start_date, y = displ, label = event), data = data,
            hjust = 0, vjust = vjust, size = 2.5) +
  theme(axis.title = element_blank(),
        axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        axis.line = element_blank(),
        axis.text.x = element_text(size = 8)) +
  expand_limits(x = c(ymd(20151201), ymd(20180501)), y = 1.2) +
  scale_x_date(breaks = scales::pretty_breaks(n = 9))

#and run the function from above
timeline <- shift_axis(p1, ymd(20151201), ymd(20180501))

生产....

Answer 3

这看起来不错...

dislocations <- c(-1,1,-.5)
ggplot( data )
+ geom_text( aes(x = V1, y=dislocations, label = V2), position="jitter" )
+ geom_hline( yintercept=0, size=1, scale="date" )
+ geom_segment(  aes(x = V1, y=dislocations, xend=V1, yend=0, alpha=.7 ))

但它仍然缺少正确的“时间箭头”，背景看起来不正确，并且它在y 轴上标记值。

Answer 4

这对于 R 的基础图形来说似乎是一个更好的工作（实际上，这种东西可能更适合 Illustrator 之类的工具）。

dat = as.data.frame(rbind(c("1492", "Columbus sailed the ocean blue"),
                       c("1976", "Americans listened to Styx"),
                       c("2008", "Financial meltdown")))
dat$V1 <- as.Date(dat$V1,"%Y")
dat$val <- c(-1,1,-0.5)

plot(dat$V1,dislocations, type = "n",xaxt = "n",bty = "n", 
     xlab = "Time", ylab = "Dislocations")
u <- par("usr")
arrows(u[1], 0, u[2], 0, xpd = TRUE)
points(dat$V1,dat$val,pch = 20)
segments(dat$V1,c(0,0,0),dat$V1,dat$val)
text(x=dat$V1,y=dat$val,labels=dat$V2,pos=c(4,2,2))

产生这样的东西：