R可视化 | 三维散点图

雨点打透心脏的1/2处 2022-12-24 11:53 286阅读 0赞

![format_png][]

上期我们说了[气泡图][Link 1]。如果我们将气泡图的三维数据绘制到三维坐标系\[1\]中，通常称其为**三维散点图**，即用在三维X-Y-Z图上针对一个或多个数据序列绘出三个度量的一种图表。

有关散点图前几部分系列可见：

*  趋势显示的二维散点图
 *  分布显示的二维散点图
 *  气泡图

R 中`scatterplot3d`包的`scatterplot3d()`函数、`rgl`包的plot3d()\[2\]函数、`plot3D`包的`scatter3D()`函数等都可以绘制三维散点图。

下面将从两个包的两个函数（`scatter3D()`,`plot3d()`）入手，一步步带你完成三维散点图的绘制。本文内容丰富，希望大家都能学到自己想要的内容，学习不易，欢迎反馈建议。

## 本文框架 ##

![format_png 1][]

## 数据介绍 ##

数据集鸢尾花数据（`iris`），具体变量的参相信大家再熟悉不过了，我这里就展示前几行数据：

![format_png 2][]

## plot3D包scatter3D() ##

scatter3D (x, y, z, ..., colvar = z, phi = 40, theta = 40,
               col = NULL, breaks = NULL,
               colkey = NULL, panel.first = NULL, 
               clim = NULL, clab = NULL, 
               bty = "b", CI = NULL, surf = NULL, 
               add = FALSE, plot = TRUE)

#### 简单绘制教程 ####

先通过该函数进行一个简单三维散点图的构建：以Sepal.Length为x轴，Sepal.Width为y轴，Petal.Length为z轴。绘制箱子型`box = TRUE`;旋转角度为`theta = 60, phi = 20`;透视转换强度的值为3`d=3`;按照2D图绘制正常刻度`ticktype = "detailed"`;散点图的颜色设置`bg="#F57446"`。

pmar <- par(mar = c(5.1, 4.1, 4.1, 6.1)) #改版画布版式大小
    with(iris, scatter3D(x = Sepal.Length, y = Sepal.Width, z = Petal.Length,
      pch = 21, cex = 1.5,col="black",bg="#F57446",
                       xlab = "Sepal.Length",
                       ylab = "Sepal.Width",
                       zlab = "Petal.Length", 
                       ticktype = "detailed",bty = "f",box = TRUE,
                       theta = 60, phi = 20, d=3,
                       colkey = FALSE)
    )

![format_png 3][]

#### 加入第四个变量 ####

上图可以看出三者之间的关系，但是如果要加入第四个变量（`Petal.Width`）该怎么绘制到三维散点图中？

> **方法一:***可以将变量`Petal.Width`映射到数据点颜色中。该变量是连续性，如果想将数据按从小到大分成n类，则可以使用dplyr包中的`ntile()`函数，然后依次设置不同组的颜色`bg=colormap[iris$quan]`，并根据映射的数值添加图例颜色条（`colkey()`）。*

这里我们将第四个变量划分成6类，使用颜色条图例进行展示。

library(tidyverse)
    iris = iris %>% mutate(quan = ntile(Petal.Width,6))
    colormap <- colorRampPalette(rev(brewer.pal(11,'RdYlGn')))(6)#legend颜色配置
    pmar <- par(mar = c(5.1, 4.1, 4.1, 6.1))
    # 绘图
    with(iris, scatter3D(x = Sepal.Length, y = Sepal.Width, z = Petal.Length,pch = 21, cex = 1.5,col="black",bg=colormap[iris$quan],
         xlab = "Sepal.Length",
         ylab = "Sepal.Width",
         zlab = "Petal.Length", 
         ticktype = "detailed",bty = "f",box = TRUE,
         theta = 60, phi = 20, d=3,
         colkey = FALSE)
    )
    colkey (col=colormap,clim=range(iris$quan),clab = "Petal.Width", add=TRUE, length=0.4,side = 4)

![format_png 4][]

> **方法二:***将第四维数据映射到数据点的大小上(`cex = rescale(iris$quan, c(.5, 4))`)*这里我还“得寸进尺”的将颜色也来反应第四维变量，当然你也可以用颜色反应第五维变量。

pmar <- par(mar = c(5.1, 4.1, 4.1, 6.1))
    with(iris, scatter3D(x = Sepal.Length, y = Sepal.Width, z = Petal.Length,pch = 21, 
                         cex = rescale(iris$quan, c(.5, 4)),col="black",bg=colormap[iris$quan],
                         xlab = "Sepal.Length",
                         ylab = "Sepal.Width",
                         zlab = "Petal.Length", 
                         ticktype = "detailed",bty = "f",box = TRUE,
                         theta = 30, phi = 15, d=2,
                         colkey = FALSE)
    )
    breaks =1:6
    legend("right",title =  "Weight",legend=breaks,pch=21,
           pt.cex=rescale(breaks, c(.5, 4)),y.intersp=1.6,
           pt.bg = colormap[1:6],bg="white",bty="n")

![format_png 5][]

同理，我们绘制出以鸢尾花不同类别作为第四个变量的三维散点图。通过该图可以清晰看到不同类别的鸢尾花特征非常不同。

library(wesanderson)
    pmar <- par(mar = c(5.1, 4.1, 4.1, 7.1))
    colors0 <-  wes_palette(n=3, name="Darjeeling1")
    colors <- colors0[as.numeric(iris$Species)]
    with(iris, scatter3D(x = Sepal.Length, y = Sepal.Width, z = Petal.Length, #bgvar = mag,
                       pch = 21, cex = 1.5,col="black",bg=colors,
                       xlab = "longitude", ylab = "latitude",
                       zlab = "depth, km", 
                       ticktype = "detailed",bty = "f",box = TRUE,
                       #panel.first = panelfirst,
                       theta = 140, phi = 20, d=3,
                       colkey = FALSE)#list(length = 0.5, width = 0.5, cex.clab = 0.75))
    )
    
    legend("right",title =  "Species",legend=c("setosa", "versicolor", "virginica"),pch=21,
           cex=1,y.intersp=1,pt.bg = colors0,bg="white",bty="n")

![format_png 6][]

## rgl包 plot3d() ##

接下来看看另一个包—rgl包\[3\]。函数及其参数如下：

plot3d(x, y, z,  
          xlab, ylab, zlab, type = "p", col,  
          size, lwd, radius,
          add = FALSE, aspect = !add, 
          xlim = NULL, ylim = NULL, zlim = NULL, 
          forceClipregion = FALSE, ...)

#### 简单绘制 ####

library(rgl)
    #数据
    mycolors <- c('royalblue1', 'darkcyan', 'oldlace')
    iris$color <- mycolors[ as.numeric(iris$Species) ]
    #绘制
    plot3d( 
      x=iris$`Sepal.Length`, y=iris$`Sepal.Width`, z=iris$`Petal.Length`, 
      col = iris$color, 
      type = 's', 
      radius = .1,
      xlab="Sepal Length", ylab="Sepal Width", zlab="Petal Length")

![format_png 7][]

可使用：`writeWebGL( filename="3dscatter.html" , width=600, height=600)`将其进行保存html格式或者其他格式。然后打开这个html，可以进行互动。

![format_png 8][]

## 动态3D图 ##

rgl包还提供了plot3d()和play3d()函数，允许将3d图表动画化，并最终以.gif格式导出结果，具体可看Animated 3d chart with R.\[4\]

> **流程**：*先构建静态图`plot3d()`，然后用`play3d()`进行坐标轴旋转50次`duration = 50`，最后使用`movie3d()`进行动图保存。*

library(rgl)
    library(magick)
    
    colors <- c("royalblue1", "darkcyan", "oldlace")
    iris$color <- colors[ as.numeric( as.factor(iris$Species) ) ]
    #静态图
    plot3d( iris[,1], iris[,2], iris[,3], col = iris$color, type = "s", radius = .2 )
    #动态图
    play3d( spin3d( axis = c(0, 0, 1), rpm = 20), duration = 50 
    #保存动态图
    movie3d(
      movie="3dAnimatedScatterplot",
      spin3d( axis = c(0, 0, 1), rpm = 7),
      duration = 10,
      dir = "~/Desktop",
      type = "gif",
      clean = TRUE
    )

![format_png 9][]

### 参考资料 ###

\[1\]

R语言数据可视化之美: *https://github.com/EasyChart/Beautiful-Visualization-with-R*

\[2\]

plot3d(): *http://www.rforscience.com/rpackages/visualisation/oceanview/*

\[3\]

rgl包: *https://www.rdocumentation.org/packages/rgl/versions/0.100.54*

\[4\]

Animated 3d chart with R.: *https://www.r-graph-gallery.com/3-r-animated-cube.html*

![format_png 10][]

[format_png]: /images/20221120/d00bb92672e34af3825de140728db2e7.png
[Link 1]: http://mp.weixin.qq.com/s?__biz=MzU5Nzg5ODQ3NQ%3D%3D&chksm=fe4eda28c939533ebba965b58ac9dd87835b007194c9546c2fca0116f9e751d58a4632cb432b&idx=4&mid=2247499692&scene=21&sn=158a844f9eadce04ece657a1019d1c3f#wechat_redirect
[format_png 1]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6X3BuZy90WFlpY3Q0MHhmTGhxYU92TWlhZW04V2dYa2djTWJtU2liNENyVnJ5N00waFJRUlhQRkR1TGZvNHJTeDBLTkRCUG5kUWNURjB4N0VKOUZqcFR5Snk1TkJIUS82NDA?x-oss-process=image/format,png
[format_png 2]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6L3RYWWljdDQweGZMaHFhT3ZNaWFlbThXZ1hrZ2NNYm1TaWI0dzJrRjZ2Y3lpY2ljN2lidlptZXlBTFd1dDlhWWo5dHpEWW1oSnVpYTM4VU9pY3ZBTEtveHhmeXFWQ1EvNjQw?x-oss-process=image/format,png
[format_png 3]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6L3RYWWljdDQweGZMaHFhT3ZNaWFlbThXZ1hrZ2NNYm1TaWI0WFQwc3A2TnZUcWtqVzBPUThobUs3OEQzUXFTbWliV0hISEx2bUFTajhRd1haT3lkZXJrOElSQS82NDA?x-oss-process=image/format,png
[format_png 4]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6L3RYWWljdDQweGZMaHFhT3ZNaWFlbThXZ1hrZ2NNYm1TaWI0bGpvMWE0Y2YyQXVFd0ZZMFZ2R2NFZUNFc0NNbEJqRk9KZXNOdU96MDJ0RmZTa2xwUTJRNkx3LzY0MA?x-oss-process=image/format,png
[format_png 5]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6L3RYWWljdDQweGZMaHFhT3ZNaWFlbThXZ1hrZ2NNYm1TaWI0MlB5d2sxaWNFNUt5SWduRWFidDN4OUcwRkcyWnRpYlBmWUZDcmx3eGdlbzZEaWJ6OGFkdWFsa1hnLzY0MA?x-oss-process=image/format,png
[format_png 6]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6L3RYWWljdDQweGZMaHFhT3ZNaWFlbThXZ1hrZ2NNYm1TaWI0VVdJVW9ESnpsZXgyaWF3aWNUTG9uMERZa3hqTW9xS2ROM214N1RhbkJVYjk0ZVVlUHpkOGFYeGcvNjQw?x-oss-process=image/format,png
[format_png 7]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6L3RYWWljdDQweGZMaHFhT3ZNaWFlbThXZ1hrZ2NNYm1TaWI0R3ZYVHloT3dsN09XMU1IV1ZMS1NDNndhazUySjhDblVHN01MNXZPckpKZnUzM1BGZjZtcldBLzY0MA?x-oss-process=image/format,png
[format_png 8]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6X2dpZi90WFlpY3Q0MHhmTGhxYU92TWlhZW04V2dYa2djTWJtU2liNDNjakh5VW42eFM3NUFlOWFQUVlnRG9pYkxCQzNQWTZvM28zaWN4VzZwdW1OZk4xU1dZdVFrTmJnLzY0MA?x-oss-process=image/format,png
[format_png 9]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6X2dpZi90WFlpY3Q0MHhmTGhxYU92TWlhZW04V2dYa2djTWJtU2liNDBPaEQ0WnhTbFNOdHdMWHRYdGlhRWJMNFlCUmljU2R6bGppYnc4ZkRsVnQwd0NpYlNlemhiRTJBQUEvNjQw?x-oss-process=image/format,png
[format_png 10]: https://imgconvert.csdnimg.cn/aHR0cHM6Ly9tbWJpei5xcGljLmNuL21tYml6X2dpZi90WFlpY3Q0MHhmTGhwZjNzcEJTbkx2Zk56WklaNkVLb0JBYmsxd1d4TTFqaWNZVTQ0clF2c2FvUmN6VHRpYlJTOFVtbWI3Vk1hTldvM1M3cjRnMVlETnduQS82NDA?x-oss-process=image/format,png