代码之家 › 专栏 › 技术社区 › jay.sf

如何延长刻面网格图中的特定记号?

r-grid facet-wrap axis-labels ggplot2 r

3

jay.sf · 技术社区 · 7 年前

this attempt 并尝试将其调整为平面网格图,如下所示:

range.f <- range(unique(df1$weeks))
minor.f <- 1  # every 1 week, NOTE: range.f[2] should be divisible by minor.f!
major.f <- 5  # every 5 weeks

breaks.f <- seq(range.f[1], range.f[2], minor.f)

every_nth.lt <- function (x, nth) {x[1:nth != 1] <- ""; x}
# (lite version of https://stackoverflow.com/a/34533473/6574038
# works better for me than `insert_minor()`)

labels.f <- every_nth.lt(sequence(range.f[2]), major.f)

n_minor.f <- major.f / minor.f - 1

正常曲线图:

library(ggplot2)
p.f <- ggplot(df1, aes(weeks, births)) +
  geom_bar(stat="identity", fill="#F48024") + theme_bw() +
  scale_x_continuous(breaks=breaks.f, labels=labels.f) +
  coord_cartesian(xlim=range.f) +
  facet_wrap(year ~ .) +
  theme(panel.grid = element_blank(),
        axis.text.x = element_text(margin=margin(t=5, unit="pt")))

操纵图:

g.f <- ggplotGrob(p.f)
xaxis.f <- g.f$grobs[grep("^axis-b", g.f$layout$name)]  # get x-axes
ticks.f <- do.call(c, lapply(lapply(xaxis.f, "["), 
                             function(x) x$children[[2]]))  # get ticks
marks.f <- ticks.f$grobs[[1]]  # get tick marks
# editing y-positions of tick marks
marks.f$y <- unit.c(unit.c(unit(1, "npc") - unit(6, "pt"), 
                           unit(1, "npc"), 
                           rep(unit.c(unit(1, "npc") - unit(3, "pt"), 
                                      unit(1, "npc")), n_minor.f)))

# putting tick marks back into plot
ticks.f$grobs[[1]] <- marks.f
for(i in seq_along(xaxis.f)) {
  xaxis.f[[i]]$children[[2]]$grob <- ticks.f[[i]]
}
g.f$grobs[grep("^axis-b", g.f$layout$name)] <- xaxis.f

library(grid)
grid.newpage()
grid.draw(g.f)

顺从的:

有人知道我做错了什么吗?

或者,也许有另一种方法可以延长带有标签的轴记号的轴记号?

预期产出:

最后,所有三个图的记号应如下所示:

数据:

tmp <- data.frame(date=as.Date(sample(1:1095, 10000, replace=TRUE), 
                               origin="2014-01-01"),
                  births=sample(0:10, 10000, replace=TRUE))
tmp$year <- factor(substr(tmp$date, 1, 4))
df1 <- aggregate(births ~ date + year, tmp, sum)
rm(tmp)  # remove tmp
df1$weeks <- as.integer(strftime(lubridate::floor_date(as.Date(df1$date, 
                                                               format="%m/%d/%Y"), 
                                                       unit="week"), "%W")) + 1

2 回复 | 直到 7 年前

1

3

jay.sf 7 年前

这是我开始时修改过的代码,少了一些 for 循环。

# Defining breaks and labels, minor and major:

range.f <- range(unique(df1$weeks))
minor.f <- 1  # every 1 week, NOTE: range.f[2] should be divisible by minor.f!
major.f <- 5  # every 5 weeks

breaks.f <- seq(range.f[1], range.f[2], minor.f)

every_nth.lt <- function (x, nth) {x[1:nth != 1] <- ""; x}
# (lite version of https://stackoverflow.com/a/34533473/6574038
# works better for me than `insert_minor()`)

labels.f <- every_nth.lt(sequence(range.f[2]), major.f)

n_minor.f <- major.f / minor.f - 1

# Normal plot:

library(ggplot2)
p.f <- ggplot(df1, aes(weeks, births)) +
  geom_bar(stat="identity", fill="#F48024") + theme_bw() +
  scale_x_continuous(breaks=breaks.f, labels=labels.f) +
  coord_cartesian(xlim=range.f) +
  facet_wrap(year ~ .) +
  theme(panel.grid = element_blank(),
        axis.text.x = element_text(margin=margin(t=5, unit="pt")))

# Manipulating plot:

g.f <- ggplotGrob(p.f)
xaxis.f <- g.f$grobs[grep("^axis-b", g.f$layout$name)]  # get x-axes

ticks.f <- lapply(lapply(xaxis.f, "["), 
                   function(x) x$children[[2]])  # get ticks

marks.f <- lapply(lapply(ticks.f, "["), 
                   function(x) x[1]$grobs)  # get ticks

# editing y-positions of tick marks
library(grid)
marks.f <- lapply(marks.f, function(x) {
  x[[1]]$y <- unit.c(unit.c(unit(1, "npc") - unit(6, "pt"), 
                            unit(1, "npc"),
                            rep(unit.c(unit(1, "npc") - unit(3, "pt"), 
                                       unit(1, "npc")), n_minor.f)))
  x
  })

# putting tick marks back into plot
for(i in seq_along(ticks.f)) {
  ticks.f[[i]]$grobs[[1]] <- marks.f[[i]][[1]]
}

for(i in seq_along(xaxis.f)) {
  xaxis.f[[i]]$children[[2]] <- ticks.f[[i]]
}

g.f$grobs[grep("^axis-b", g.f$layout$name)] <- xaxis.f

# Drawing the plot:

grid.newpage()
grid.draw(g.f)

数据

tmp <- data.frame(date=as.Date(sample(1:1095, 10000, replace=TRUE), 
                               origin="2014-01-01"),
                  births=sample(0:10, 10000, replace=TRUE))
tmp$year <- factor(substr(tmp$date, 1, 4))
df1 <- aggregate(births ~ date + year, tmp, sum)
rm(tmp)  # remove tmp
df1$weeks <- as.integer(strftime(lubridate::floor_date(as.Date(df1$date, 
                                                               format="%m/%d/%Y"), 
                                                       unit="week"), "%W")) + 1

2

1

Anonymous coward 7 年前

我相信你可以在这方面有所改进。我只是完成了它,把东西正确地拔出来,然后放回去。主要是将它与一个单独的情节进行比较,然后让它在一个grob列表上循环。

范围和间隔可能需要更改,因为在这里它们都是相同的,但具有不同的属性 x-axes 您可以适当地自定义中断。

tmp <- data.frame(date=as.Date(sample(1:1095, 10000, replace=TRUE), 
                               origin="2014-01-01"),
                  births=sample(0:10, 10000, replace=TRUE))
tmp$year <- factor(substr(tmp$date, 1, 4))
df1 <- aggregate(births ~ date + year, tmp, sum)
rm(tmp)  # remove tmp
df1$weeks <- as.integer(strftime(lubridate::floor_date(as.Date(df1$date, 
                                                               format="%m/%d/%Y"), 
                                                       unit="week"), "%W")) + 1

# breaks and labels, minor and major
range.f <- 1:(max(unique(df1$weeks)))
minor.f <- 1  # every 1 week, NOTE: range.f[2] should be divisible by minor.f!
major.f <- 5  # every 5 weeks

breaks.f <- seq(min(range.f), max(range.f), minor.f)

every_nth.lt <- function (x, nth) {x[1:nth != 1] <- ""; x}
# (lite version of https://stackoverflow.com/a/34533473/6574038)

labels.f <- every_nth.lt(range.f, major.f)

n_minor.f <- major.f / minor.f - 1

# plot
library(ggplot2)
library(grid)
p.f <- ggplot(df1, aes(weeks, births)) +
  geom_bar(stat="identity", fill="#F48024") + theme_bw() +
  scale_x_continuous(breaks=breaks.f, labels=labels.f) +
  coord_cartesian(xlim=range.f) +
  facet_wrap(year ~ .) +
  theme(panel.grid = element_blank(),
        axis.text.x = element_text(margin=margin(t=5, unit="pt")))

# manipulating plot
g.f <- ggplotGrob(p.f)
xaxis.f <- g.f$grobs[grep("^axis-b", g.f$layout$name)]  # get x-axes


ticks.f <- c()
for(i in seq_along(xaxis.f)) {
  ticks.f[[i]] <- xaxis.f[[i]]$children[[2]]
}


marks.f <- c()
for(i in seq_along(ticks.f)) {
  marks.f[[i]] <- ticks.f[[i]][1]$grobs
}



# editing y-positions of tick marks
for(i in seq_along(marks.f)) {
  marks.f[[i]][[1]]$y <- unit.c(unit.c(unit(1, "npc") - unit(6, "pt"), 
                                       unit(1, "npc"), 
                                       rep(unit.c(unit(1, "npc") - unit(3, "pt"), 
                                                  unit(1, "npc")), n_minor.f)))
}
# putting tick marks back into plot
for(i in seq_along(ticks.f)) {
  ticks.f[[i]]$grobs[[1]] <- marks.f[[i]][[1]]
}

for(i in seq_along(xaxis.f)) {
  xaxis.f[[i]]$children[[2]] <- ticks.f[[i]]
}

g.f$grobs[grep("^axis-b", g.f$layout$name)] <- xaxis.f

# plot
grid.newpage()
grid.draw(g.f)