ggparty包：构建个性化树状图形-阿里云开发者社区

ggparty包：构建个性化树状图形

2023-05-25 149

版权

本文内容由阿里云实名注册用户自发贡献，版权归原作者所有，阿里云开发者社区不拥有其著作权，亦不承担相应法律责任。具体规则请查看《阿里云开发者社区用户服务协议》和《阿里云开发者社区知识产权保护指引》。如果您发现本社区中有涉嫌抄袭的内容，填写侵权投诉表单进行举报，一经查实，本社区将立刻删除涉嫌侵权内容。

简介： ggparty包：构建个性化树状图形

简介

最近看到了一个有趣的 R 包：ggparty^[1]，可以绘制出以下图形：

该包旨在将 ggplot2 功能扩展到 partykit^[2] 软件包中。它可以为聚类的对象创建清晰结构化且高度可定制的可视化图形。

本文目的：解读上图是细节代码，注意这不算是一个入门级教程。该包的入门教程可见 ggparty: Graphic Partying^[3]。

教程

安装

通过 GitHub 安装：

devtools::install_github("martin-borkovec/ggparty", 
                         dependencies = TRUE)

数据介绍

加载相关 R 包，使用 ARE 包中的 TeachingRatings 数据。数据预览如下：

library(ggparty)
library(ARE)
data("TeachingRatings", package = "AER")

模型拟合

tr <- subset(TeachingRatings, credits == "more")
tr_tree <- lmtree(eval ~ beauty | minority + age + gender + division + native +
                    tenure, data = tr, weights = students, caseweights = FALSE)

这里使用 credits == "more" 的数据集作为例子。并使用 lmtree() 函数来拟合用于拟合条件推断树模型，该函数来自于 partykit 包。具体来说，该模型用来预测响应变量 eval（即教学评估）的值，其解释变量包括 beauty（外貌吸引力）、minority（是否为少数族裔）、age（年龄）、gender（性别）、division（所在学院）和 native（出生地），还有 tenure（职业资历）。

在该模型中， minority、age、gender、division、native 和 tenure 是条件变量，它们的取值会影响到 beauty 对 eval 的影响。同时，模型使用了 students 权重来调整样本中不同学生的权重，以更准确地估计模型的系数。

基于拟合结果，绘制对应图形。这时候需要使用 ggparty 包中的 ggparty()。最终代码将会在文末给出，这里先带读者解读代码的含义。

具体来说，这段代码绘制了一个节点表示模型的每个内部节点和叶子节点，并用边连接它们。此外，该代码也添加了其他几个元素，如节点标签、节点样式、节点尺寸、节点形状和节点颜色。

可视化：构建边

p = ggparty(tr_tree,
        terminal_space = 0.5,
        add_vars = list(p.value = "$node$info$p.value")) +
  geom_edge(size = 1.5) +
  geom_edge_label(colour = "grey", size = 6)
p

各个参数的具体含义为：

terminal_space = 0.5：表示绘制叶子节点时，每个节点之间的水平空间大小。
add_vars = list(p.value = "$node$info$p.value")：表示添加 p.value 到节点标签中，即每个节点上的显著性检验的 p 值。
geom_edge(size = 1.5)：表示定义边的样式和宽度。
geom_edge_label(colour = "grey", size = 6)：表示定义边标签的颜色和大小。

可视化：构建节点

在构建完树的边后，添加节点。各个参数的具体含义为：

geom_node_plot：表示为节点添加一个 ggplot2 对象，包含点和点属性。这里的 gglist 参数表示添加到节点中的点图层的列表。scales = "fixed" 表示 x 和 y 轴使用相同的尺度。id = "terminal" 表示这个点图层是在终端节点上绘制的。shared_axis_labels = T 和 shared_legend = T 分别表示共享坐标轴标签和图例。legend_separator = T 表示为图例添加分隔符。
predict_gpar = list(col = "blue", size = 1.2)：表示定义预测线的颜色和大小。
geom_node_label：表示为节点添加文本标签。第一个 geom_node_label 函数用于添加内部节点标签。其中 line_list 参数是一个包含每行标签的列表，分别代表节点 ID、拆分变量和 p 值。line_gpar 参数是一个包含每行标签样式的列表。ids = "inner" 表示这个文本标签是在内部节点上绘制的。第二个 geom_node_label 函数用于添加叶子节点标签。size = 5 表示文本大小，nudge_y = 0.01 表示在 y 方向上微调文本位置。

p + geom_node_plot(gglist = list(geom_point(aes(x = beauty,
                                              y = eval,
                                              col = tenure,
                                              shape = minority),
                                          alpha = 0.8),
                               theme_bw(base_size = 15)),
                 scales = "fixed",
                 id = "terminal",
                 shared_axis_labels = T,
                 shared_legend = T,
                 legend_separator = T,
                 predict = "beauty",
                 predict_gpar = list(col = "blue",
                                     size = 1.2)
  ) +
  geom_node_label(aes(col = splitvar),
                  line_list = list(aes(label = paste("Node", id)),
                                   aes(label = splitvar),
                                   aes(label = paste("p =", formatC(p.value, format = "e", digits = 2)))),
                  line_gpar = list(list(size = 12, col = "black", fontface = "bold"),
                                   list(size = 20),
                                   list(size = 12)),
                  ids = "inner") +
  geom_node_label(aes(label = paste0("Node ", id, ", N = ", nodesize)),
                  fontface = "bold",
                  ids = "terminal",
                  size = 5, 
                  nudge_y = 0.01) +
  theme(legend.position = "none")

此时，即可得到原文最前面的图形了。

完整代码

library(ggparty)
library(ARE)
data("TeachingRatings", package = "AER")
str(TeachingRatings)
tr <- subset(TeachingRatings, credits == "more")
tr_tree <- lmtree(eval ~ beauty | minority + age + gender + division + native +
                    tenure, data = tr, weights = students, caseweights = FALSE)
ggparty(tr_tree,
        terminal_space = 0.5,
        add_vars = list(p.value = "$node$info$p.value")) +
  geom_edge(size = 1.5) +
  geom_edge_label(colour = "grey", size = 6) +
  geom_node_plot(gglist = list(geom_point(aes(x = beauty,
                                              y = eval,
                                              col = tenure,
                                              shape = minority),
                                          alpha = 0.8),
                               theme_bw(base_size = 15)),
                 scales = "fixed",
                 id = "terminal",
                 shared_axis_labels = T,
                 shared_legend = T,
                 legend_separator = T,
                 predict = "beauty",
                 predict_gpar = list(col = "blue",
                                     size = 1.2)
  ) +
  geom_node_label(aes(col = splitvar),
                  line_list = list(aes(label = paste("Node", id)),
                                   aes(label = splitvar),
                                   aes(label = paste("p =", formatC(p.value, format = "e", digits = 2)))),
                  line_gpar = list(list(size = 12, col = "black", fontface = "bold"),
                                   list(size = 20),
                                   list(size = 12)),
                  ids = "inner") +
  geom_node_label(aes(label = paste0("Node ", id, ", N = ", nodesize)),
                  fontface = "bold",
                  ids = "terminal",
                  size = 5, 
                  nudge_y = 0.01) +
  theme(legend.position = "none")