如何在 ggplot 中使 x 轴限制之外的误差线环绕到绘图的另一侧

Question

我对 R 相当陌生，并且已经广泛搜索 StackOverflow 以寻找解决此问题的方法，但我还不够。我目前正在绘制太阳熊的估计出生日期，并且我希望我的情节在 x 轴上只有 2014 年 4 月至 2015 年 3 月这几个月。我的大部分数据都符合这个要求，但我有一个值，它有一个从 3 月开始到 5 月结束的错误栏(Figure 1)。当我绘制这个时，错误栏要么消失，要么延伸到整个情节(Figure 2)。我想把它包裹起来，这样当错误栏出现在图的右侧时，它就会出现在 2014 年 4 月所在的左侧。具体年份无关紧要（这些值来自许多不同的年份），但任意指定年份是我发现将它们全部放在 x 轴上有一年的图上的最简单方法。任何帮助将不胜感激！

这就是我希望最终数字看起来像。

我的代码如下：

##Import Excel Data
require(xlsx)
require(modeest)
require(ggplot2)
require(ggpubr)
library(scales)

BirthDates300 <- read.xlsx("C:/Users/ZackA/OneDrive - Old Dominion University/frombox/ODU/Sun Bear Weight/Data/data_zd.xlsx", 7)

#Combine Day Month and Year into Date
BirthDates300$MinDate<-as.Date(with(BirthDates300,paste(MinYear,MinMonth,MinDay,sep="-")),"%Y-%m-%d")
BirthDates300$MeanDate<-as.Date(with(BirthDates300,paste(MeanYear,MeanMonth,MeanDay,sep="-")),"%Y-%m-%d")
BirthDates300$MaxDate<-as.Date(with(BirthDates300,paste(MaxYear,MaxMonth,MaxDay,sep="-")),"%Y-%m-%d")
BirthDates300$IndDate<-as.Date(with(BirthDates300,paste(IndYear,IndMonth,IndDay,sep="-")),"%Y-%m-%d")

#Remove unnecessary row 17
BirthDates300 <- BirthDates300[-c(17), ]

#Plotting Range of Birth Dates 300
BirthDatesRange300 <- ggplot()+
  geom_errorbar(data=BirthDates300, mapping=aes(x=MeanDate, xmin=MinDate, xmax=MaxDate, y=CRN), 
                width=0.4, size=1, color="black") +
  geom_point(data=BirthDates300, mapping=aes(x=MeanDate, y=CRN, shape=Sex,), size=4,) +
  geom_point(data=BirthDates300, mapping=aes(x=IndDate, y=CRN, shape=Sex), color="grey", size=4,)+
  labs(title="Sun Bear Estimated Birth Date", subtitle="Assuming 300g at birth")+
  scale_x_date(date_labels="%b",date_breaks  ="1 month",
               limits = as.Date(c('2014-03-25','2015-03-01')))+ 
  scale_y_discrete(limits= c("060-2004", "157-2012", "158-2012", "167-2012", "169-2013", 
                             "202-2017", "207-2019", " ", "002-1999", "058-2004", "073-2006", 
                             "076-2006", "077-2005", "080-2006", "081-2006", "083-2006",
                             "088-2006", "091-2006", "107-2007", "150-2010", "152-2011",
                             "159-2011", "161-2012", "163-2012", "171-2013", "172-2013",
                             "180-2014", "181-2014", "183-2014", "186-2015", "187-2015",
                             "193-2016", "196-2016", "204-2018"))+
  theme(plot.title = element_text(size=16, face="bold", hjust = 0.5),
        plot.subtitle=element_text(size=10, hjust=0.5),
        axis.ticks.y = element_blank(),
        axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        axis.text.x = element_text(face="bold", color="black", size=13, vjust=-0.01),
        axis.text.y = element_text(face="bold", color="black", size=10, angle=0),
        panel.grid.major = element_blank(), panel.grid.minor = element_blank(),
        panel.background = element_blank(), axis.line = element_line(colour = "black"),
        panel.border = element_rect(colour = "black", fill=NA, size=0.5),
        legend.title = element_text(size=15),
        plot.margin = margin(10, 10, 15, 10))+
  geom_hline(yintercept=" ", linetype='dotted', col = 'grey', size=1.5)

BirthDatesRange300

Answer 1

@Brian 在 cmets 中推荐的一种有点老套的方法是将所有数据复制到另一年。

以下是使用 tidyr::complete 和 fill 的方法：

library(tidyverse)
TargetMinDate <- as.Date("2014-03-25")
TargetMaxDate <- as.Date("2015-03-01")

BirthDates300 %>%
  group_by(CRN, MeanYear) %>% #Group by individual and year
  complete(MeanYear = c(2014,2015)) %>% #Complete the year
  group_by(CRN) %>% #go back to grouping only by individual
  fill(MeanYear:Sex, .direction = "updown") %>% #Fill the other variables from the original row
  mutate(across(contains("Date"), #Fill in the missing date variables
                ~ case_when(is.na(.) & #is NA from the complete operation
                            (MinDate[!is.na(MinDate)][1] < TargetMinDate | #MinDate is less than the target MinDate
                            MaxDate[!is.na(MaxDate)][1] > TargetMaxDate) #or MaxDate is greater than the target MaxDate
                            ~ as.Date(str_replace(.[!is.na(.)][1],"20\\d{2}",as.character(MeanYear))), #Then replace the year with the year we filled earlier
                            TRUE ~ .))) -> BirthDates300Duplicate #Otherwise, no change, then assign to variable

从这里我们只需要将 xlimit 移动到coord_cartesian 并设置clip = off：

ggplot()+
  geom_errorbar(data=BirthDates300Duplicate, mapping=aes(x=MeanDate, xmin=MinDate, xmax=MaxDate, y=CRN), 
                width=0.4, size=1, color="black") +
  geom_point(data=BirthDates300Duplicate, mapping=aes(x=MeanDate, y=CRN, shape=Sex,), size=4,) +
  geom_point(data=BirthDates300Duplicate, mapping=aes(x=IndDate, y=CRN, shape=Sex), color="grey", size=4,)+
  labs(title="Sun Bear Estimated Birth Date", subtitle="Assuming 300g at birth")+
  coord_cartesian(xlim = as.Date(c(TargetMinDate,TargetMaxDate))) +
  scale_x_date(date_labels="%b",date_breaks  ="1 month")+ 
  scale_y_discrete(limits= c("060-2004", "157-2012", "158-2012", "167-2012", "169-2013", 
                             "202-2017", "207-2019", " ", "002-1999", "058-2004", "073-2006", 
                             "076-2006", "077-2005", "080-2006", "081-2006", "083-2006",
                             "088-2006", "091-2006", "107-2007", "150-2010", "152-2011",
                             "159-2011", "161-2012", "163-2012", "171-2013", "172-2013",
                             "180-2014", "181-2014", "183-2014", "186-2015", "187-2015",
                             "193-2016", "196-2016", "204-2018"))+
  theme(plot.title = element_text(size=16, face="bold", hjust = 0.5),
        plot.subtitle=element_text(size=10, hjust=0.5),
        axis.ticks.y = element_blank(),
        axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        axis.text.x = element_text(face="bold", color="black", size=13, vjust=-0.01),
        axis.text.y = element_text(face="bold", color="black", size=10, angle=0),
        panel.grid.major = element_blank(), panel.grid.minor = element_blank(),
        panel.background = element_blank(), axis.line = element_line(colour = "black"),
        panel.border = element_rect(colour = "black", fill=NA, size=0.5),
        legend.title = element_text(size=15),
        plot.margin = margin(10, 10, 15, 10))+
  geom_hline(yintercept=" ", linetype='dotted', col = 'grey', size=1.5)  

我怀疑你会这样，我对更强大的方法感兴趣。

Answer 2

这是另一种方法，但使用基本图形。

这里的关键是在plot() 中使用xaxs = "i"，这将删除第一个和最后一个x 轴刻度与绘图区域之间的默认6% 缓冲区。我将您的数据绘制为 x 轴上的儒略日，并将月份标签放置在每个月的 15 号左右。

如果您愿意，我可以编辑以显示如何将 x 轴上的日期移动到映射到 4 月 - 3 月。

# Get fields of interest
foi <- c("CRN", "Sex", "MinDate", "MaxDate", "MeanDate", "IndDate")
dat <- original.data[!is.na(original.data$MinDate), foi]

# Format fields
dat[,3:6] <- lapply(dat[,3:6], as.Date, format = "%Y-%m-%d")
dat$start <- as.numeric(format(dat$MinDate, "%j"))
dat$end <- as.numeric(format(dat$MaxDate, "%j"))
dat$mid <- as.numeric(format(dat$MeanDate, "%j"))
dat$ind <- as.numeric(format(dat$IndDate, "%j"))
dat$CRN <- paste(dat$CRN)
dat$Sex <- paste(dat$Sex)

# Order CRN to match example in question
crn.order <- c("060-2004", "157-2012", "158-2012", "167-2012", "169-2013", 
               "202-2017", "207-2019", "002-1999", "058-2004", "073-2006", 
               "076-2006", "077-2005", "080-2006", "081-2006", "083-2006",
               "088-2006", "091-2006", "107-2007", "150-2010", "152-2011",
               "159-2011", "161-2012", "163-2012", "171-2013", "172-2013",
               "180-2014", "181-2014", "183-2014", "186-2015", "187-2015",
               "193-2016", "196-2016", "204-2018")
dat <- dat[order(match(dat$CRN,crn.order)),]
dat$bear_id <- 1:nrow(dat)

# Make timeseries; assume 366 julian days per year
ts <- data.frame(matrix(NA, nrow = 366, ncol = nrow(dat)))
names(ts) <- 1:32
jdays <- 1:366
for(i in 1:nrow(dat)){
  if(dat[i,"start"] < dat[i,"end"]){
    birthmos <- jdays[jdays >= dat[i,"start"] & jdays <= dat[i,"end"]]
  } else if(dat[i, "start"] > dat[i, "end"]){
    jdays1 <- jdays[jdays >= dat[i, "start"]]
    jdays2 <- jdays[jdays <= dat[i, "end"]]
    birthmos <- c(jdays1, jdays2)
  } else if(dat[i, "start"] == dat[i, "end"]){
    birthmos <- dat[i,"start"]
  }
  ts[,i] <- ifelse(jdays %in% birthmos, i, NA)
}

mat <- as.matrix(ts)
mat

# Plot settings
shapes <- ifelse(dat$Sex == "F", 16,
                 ifelse(dat$Sex == "M", 17,
                        ifelse(dat$Sex == "NA", 15, 1)))
month.abb <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun",
               "Jul", "Aug", "Sept", "Oct", "Nov", "Dec")
# 15th date of each month in julian day
jday.15 <- c(15, 46, 74, 105, 135, 166, 196, 227, 258, 288, 319, 349) 

par(mar = c(5,5,5,8))
plot(1, type = "n", xlim = c(1, 366), ylim = c(1, 32),
     yaxt = "n", xaxt = "n", xaxs = "i", ann = FALSE)
matlines(y = mat, x = 1:nrow(mat), lty = 1, col = "black", lwd = 2)
points(x = dat$mid, y = dat$bear_id, pch = shapes, col = "black", cex = 1.5)
points(x = dat$ind, y = dat$bear_id, pch = shapes, col = "grey40", cex = 1.5)
lines(y = c(4.5,4.5), x = c(0, 366), col = "grey40", lty = 2)
axis(1, at = jday.15, labels = month.abb, font = 2)
axis(2, at = 1:32, labels = dat$CRN, las = 2,
     cex.axis = 0.8, lwd.ticks = 0, font = 2)
title(main = "Sun Bear Estimated Birth Date")
mtext(side=3, at = 366/2, line=0.5, cex=0.8, "Assuming 300g at birth")
legend(380, 25, title = "Sex", legend = c("F", "M", "NA"), col = "grey40",
       bty = "n", pch = c(16, 17, 15), xpd = TRUE, cex = 1)