ggplot2

Question

我使用 ggplot 2.2.0 和 R 版本 3.3.2 w64

根据http://www.cookbook-r.com/Graphs/Facets_(ggplot2)/，我可以指定一个函数来提供构面标签。我绘制了一项研究的患者数据：

我有一个包含 ID 和数据的数据框，还有一个包含一些一般信息（年龄和性别）的数据框

patmeta <- data.frame(
 "pat_id"=c(66, 103, 219, 64, 62, 111, 232),
 "gender"=c("f","f","f", "m","f", "f", "f"), 
 "age"=c(56, 32, 73, 58,37,33,52))

我为我的 pat_id 定义了一个全局标签函数和一个特殊函数（pat_id_fac 与 pat_id 相同，但作为一个因素，pat_id 是数字)

PatIdLabeller <- function(id) {
    res <- sprintf("Pat %s (%i y, %s)", id,
              subset(patmeta, pat_id == id)$age,
              subset(patmeta, pat_id == id)$gender)
    return(res)
}

globalLabeller <- labeller(
    pat_id_fac = PatIdLabeller,
    pat_id = PatIdLabeller,
    .default = label_both
)

测试 PatIdLabeller 函数会给出所需的输出（尽管我认为，使用子集并不是最优雅的方法），例如

> PatIdLabeller('103')
[1] "Pat 103 (32 y, f)"

但是在ggplot中使用它，ID是正确的，但是年龄和性别都是一样的（patmeta的最后一行），就像你在图片中看到的那样。

我的 qdat 的一个子集如下

structure(list(pat_id = c(103L, 103L, 103L, 64L, 64L, 64L, 66L, 
66L, 66L, 219L, 219L, 219L, 62L, 62L, 62L, 111L, 111L, 111L, 
232L, 232L, 232L), pat_id_fac = structure(c(4L, 4L, 4L, 2L, 2L, 
2L, 3L, 3L, 3L, 6L, 6L, 6L, 1L, 1L, 1L, 5L, 5L, 5L, 7L, 7L, 7L
), .Label = c("62", "64", "66", "103", "111", "219", "232"), 
class = c("ordered", "factor")), 
Activity = structure(c(9L, 3L, 9L, 2L, 9L, 9L, 9L, 
2L, 2L, 3L, 8L, 4L, 2L, 2L, 2L, 4L, 4L, 7L, 2L, 2L, 9L), .Label = c("", 
"Anderes", "Essen", "Hausarbeit", "Hobbies", "Körperpflege", 
"Liegen", "Medienkonsum", "Sozialer Kontakt"), class = "factor")), 
.Names = c("pat_id", "pat_id_fac", "Activity"), row.names = c(1L, 2L, 3L,  
128L, 129L, 130L, 199L, 200L, 201L, 217L, 218L, 219L, 343L, 344L, 345L,   
397L, 398L, 399L, 451L, 452L, 453L), class = "data.frame")


g.bar.activities <-
    ggplot(data=qdat, aes(x=Activity)) +
    geom_bar() +
    facet_wrap(~ pat_id_fac, labeller= globalLabeller)

从其他问题和答案中，我知道我可以定义一个字符向量，但我很懒，想更优雅地重用我的 patmeta，因为研究参与者的列表会变得很长，并且会随着时间的推移而演变.

测试数据集较小

t <- data.frame("pat_id"=c(103, 103, 103, 219, 219, 219), 
"Activity" = c("sleep", "sleep", "eat", "eat", "eat", "sleep"))
patmeta <- data.frame("pat_id"=c(103, 219), 
"gender"=c("m","f"), "age"=c(32,52))

ggplot(data=t, aes(x=Activity)) + geom_bar() + 
facet_wrap(~pat_id, labeller=globalLabeller)

我得到了我想要的。我没看出区别。

Answer 1

子集化似乎无法正常工作，可能是因为 == 正试图充当沿所有传入的 id 长度的矢量。那是，它正在检查 patmeta 中的每个 pat_id 以查看它是否与传入的 pat_id 匹配。排序的差异不知何故只留下那个 pat_id 匹配。

如果您尝试以下任一操作，您可以看到实际效果：

PatIdLabeller(c(103, 66))

给出 character(0) 和这个警告：

In pat_id == id : longer object length is not a multiple of shorter object length

因为none行return，而R被迫重复==

中的元素

ggplot(data=head(qdat), aes(x=Activity)) +
  geom_bar() +
  facet_wrap(~ pat_id, labeller= globalLabeller)

再次给出重复的情节age/gender，并且这个警告

In pat_id == id : longer object length is not a multiple of shorter object length

（同上）。

值得注意的是，即使您的数据集较小，如果您颠倒新 patmeta 的行顺序（这样 219 在 103 之前），那么运行您得到的代码

Error in FUN(X[[i]], ...) : Unknown input

因为贴标机正在 return 打空 character()（如上）。

我没有太多使用贴标机的经验（这个答案是探索它们的好机会），但是这个应该通过使用 dplyr 中的 left_join 来工作，而不是尝试使用 ==.

myLabeller <- function(x){
  lapply(x,function(y){
    toLabel <-
      data.frame(pat_id = y) %>%
      left_join(patmeta)

    paste0("Pat ", toLabel$pat_id
           , " (", toLabel$age, "y, "
           , toLabel$gender, ")")
  })
}

并使用给出：

ggplot(data=qdat, aes(x=Activity)) + geom_bar() + 
  facet_wrap(~pat_id, labeller=myLabeller) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

另一种选择是跳过贴标步骤，直接生成您真正想要使用的标签。在这里，只需将元数据与患者数据合并（使用来自 dplyr 的 left_join），然后使用您想要的 format/style 生成一个列（这里，使用来自 mutate dplyr 和 paste0).

forPlotting <-
  qdat %>%
  left_join(patmeta) %>%
  mutate(forFacet = paste0("Pat ", pat_id
                           , " (", age, "y, "
                           , gender, ")"))

然后，使用该数据进行绘图，并使用新列进行分面。

ggplot(forPlotting, aes(x=Activity)) +
  geom_bar() +
  facet_wrap(~forFacet) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

给予

请注意，构面现在按字母顺序排序，但您可以根据需要进行调整，方法是在创建时将列设置为具有明确排序级别的因素。

ggplot2 - 如何使用另一个数据框作为查找更改构面标签文本 table

ggplot2 - How can I change facet label text using another dataframe as lookup table

r

facet-wrap