R+RGL：球体和线段图，线段未正确缩放
R+RGL: plot of spheres and segments, segments do not zoom properly
请考虑以下代码段。
它绘制了一组由一些线段连接的球体。
绘制光滑球体的函数来自
的讨论
令我困惑的是：当我缩放 in/out RGL 图时，球体和线段的行为不同。特别是，如果我放大，这些片段相对于球体看起来相当细，而当我缩小时它们看起来非常宽。
有没有办法纠正这种行为，以便无论缩放级别如何，始终遵守球体和线段之间的比例？
非常感谢
library(rgl)
library(tidyverse)
## a function to plot good-looking spheres
sphere1.f <- function(x0 = 0, y0 = 0, z0 = 0, r = 1, n = 101, ...){
f <- function(s,t){
cbind( r * cos(t)*cos(s) + x0,
r * sin(s) + y0,
r * sin(t)*cos(s) + z0)
}
persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, ...)
}
## a set of 3D coordinates for my spheres
agg <- structure(list(X1 = c(-0.308421860438279, -1.42503395393061,
1.10667871416591, -0.41759848570565, 0.523721760757519, 0.520653825151111,
4.54213267745731, 2.96469370222004, 6.32495200153492, 3.78715565912871,
5.35968114482443), X2 = c(0.183223776337368, 1.69719822686475,
-0.992839275466541, 2.22182475540691, -0.705817674534376, -2.40358980860811,
-0.565561169031234, -0.362260309907445, 0.326094711744554, 0.60340188259578,
-0.00167511540165435), X3 = c(-0.712687792799106, -0.0336746884947792,
0.0711272759107127, 1.6126544944538, -2.29999319137504, 1.36257390230441,
-1.52942342176029, -0.316841449239697, -1.69222713171002, 1.23000775530984,
2.30848424740017)), class = c("spec_tbl_df", "tbl_df", "tbl",
"data.frame"), row.names = c(NA, -11L), spec = structure(list(
cols = list(X1 = structure(list(), class = c("collector_double",
"collector")), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
##coordinares of the segments (bonds) connecting the spheres
bond_segments <- structure(list(X1 = c(-1.42503395393061, -0.308421860438279,
1.10667871416591, -0.308421860438279, 0.523721760757519, -0.308421860438279,
-0.41759848570565, -1.42503395393061, 0.520653825151111, 1.10667871416591,
2.96469370222004, 1.10667871416591, 2.96469370222004, 4.54213267745731,
6.32495200153492, 4.54213267745731, 3.78715565912871, 2.96469370222004,
5.35968114482443, 3.78715565912871), X2 = c(1.69719822686475,
0.183223776337368, -0.992839275466541, 0.183223776337368, -0.705817674534376,
0.183223776337368, 2.22182475540691, 1.69719822686475, -2.40358980860811,
-0.992839275466541, -0.362260309907445, -0.992839275466541, -0.362260309907445,
-0.565561169031234, 0.326094711744554, -0.565561169031234, 0.60340188259578,
-0.362260309907445, -0.00167511540165435, 0.60340188259578),
X3 = c(-0.0336746884947792, -0.712687792799106, 0.0711272759107127,
-0.712687792799106, -2.29999319137504, -0.712687792799106,
1.6126544944538, -0.0336746884947792, 1.36257390230441, 0.0711272759107127,
-0.316841449239697, 0.0711272759107127, -0.316841449239697,
-1.52942342176029, -1.69222713171002, -1.52942342176029,
1.23000775530984, -0.316841449239697, 2.30848424740017, 1.23000775530984
)), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"
), row.names = c(NA, -20L), spec = structure(list(cols = list(
X1 = structure(list(), class = c("collector_double", "collector"
)), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
open3d()
#> glX
#> 1
##material and light effects for the spheres
material3d(ambient = "black", specular = "grey60", emission = "black", shininess = 30.0)
clear3d(type = "lights")
light3d(theta = -30, phi = 60, viewpoint.rel = TRUE, ambient = "#FFFFFF", diffuse = "#FFFFFF", specular = "#FFFFFF", x = NULL, y = NULL, z = NULL)
light3d(theta = -0, phi = 0, viewpoint.rel = TRUE, diffuse = "gray20", specular = "gray25", ambient = "gray80", x = NULL, y = NULL, z = NULL)
## plot the spheres
agg %>%
rowwise() %>%
mutate(spheres = sphere1.f(X1, X2, X3, r=0.5))
#> # A tibble: 11 × 4
#> # Rowwise:
#> X1 X2 X3 spheres
#> <dbl> <dbl> <dbl> <rglLwlvl>
#> 1 -0.308 0.183 -0.713 15
#> 2 -1.43 1.70 -0.0337 16
#> 3 1.11 -0.993 0.0711 17
#> 4 -0.418 2.22 1.61 18
#> 5 0.524 -0.706 -2.30 19
#> 6 0.521 -2.40 1.36 20
#> 7 4.54 -0.566 -1.53 21
#> 8 2.96 -0.362 -0.317 22
#> 9 6.32 0.326 -1.69 23
#> 10 3.79 0.603 1.23 24
#> 11 5.36 -0.00168 2.31 25
## add the segments
segments3d(bond_segments, lwd=8, color="black")
sessionInfo()
#> R version 4.1.2 (2021-11-01)
#> Platform: x86_64-pc-linux-gnu (64-bit)
#> Running under: Debian GNU/Linux 11 (bullseye)
#>
#> Matrix products: default
#> BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0
#> LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
#>
#> locale:
#> [1] LC_CTYPE=en_GB.UTF-8 LC_NUMERIC=C
#> [3] LC_TIME=en_GB.UTF-8 LC_COLLATE=en_GB.UTF-8
#> [5] LC_MONETARY=en_GB.UTF-8 LC_MESSAGES=en_GB.UTF-8
#> [7] LC_PAPER=en_GB.UTF-8 LC_NAME=C
#> [9] LC_ADDRESS=C LC_TELEPHONE=C
#> [11] LC_MEASUREMENT=en_GB.UTF-8 LC_IDENTIFICATION=C
#>
#> attached base packages:
#> [1] stats graphics grDevices utils datasets methods base
#>
#> other attached packages:
#> [1] forcats_0.5.1 stringr_1.4.0 dplyr_1.0.8 purrr_0.3.4
#> [5] readr_2.1.1 tidyr_1.2.0 tibble_3.1.6 ggplot2_3.3.5
#> [9] tidyverse_1.3.1 rgl_0.108.3
#>
#> loaded via a namespace (and not attached):
#> [1] Rcpp_1.0.7 lubridate_1.8.0 assertthat_0.2.1 digest_0.6.29
#> [5] utf8_1.2.2 R6_2.5.1 cellranger_1.1.0 backports_1.4.1
#> [9] reprex_2.0.1 evaluate_0.14 httr_1.4.2 highr_0.9
#> [13] pillar_1.6.4 rlang_1.0.1 readxl_1.3.1 R.utils_2.11.0
#> [17] R.oo_1.24.0 rmarkdown_2.11 styler_1.6.2 htmlwidgets_1.5.4
#> [21] munsell_0.5.0 broom_0.7.10 compiler_4.1.2 modelr_0.1.8
#> [25] xfun_0.29 pkgconfig_2.0.3 htmltools_0.5.2 tidyselect_1.1.1
#> [29] fansi_0.5.0 crayon_1.4.2 tzdb_0.2.0 dbplyr_2.1.1
#> [33] withr_2.4.3 R.methodsS3_1.8.1 grid_4.1.2 jsonlite_1.7.2
#> [37] gtable_0.3.0 lifecycle_1.0.1 DBI_1.1.2 magrittr_2.0.1
#> [41] scales_1.1.1 cli_3.1.0 stringi_1.7.6 fs_1.5.2
#> [45] xml2_1.3.3 ellipsis_0.3.2 generics_0.1.1 vctrs_0.3.8
#> [49] tools_4.1.2 R.cache_0.15.0 glue_1.6.0 hms_1.1.1
#> [53] fastmap_1.1.0 yaml_2.2.1 colorspace_2.0-2 rvest_1.0.2
#> [57] knitr_1.37 haven_2.4.3
由 reprex package (v2.0.1)
创建于 2022-03-06
感谢您提出宝贵建议。
求助于气缸完成了工作。关于圆柱体的设置，我真的复制粘贴了这里讨论的一部分
https://r-help.stat.math.ethz.narkive.com/9X5yGnh0/r-joining-two-points-in-rgl
library(rgl)
library(tidyverse)
## a function to plot good-looking spheres
sphere1.f <- function(x0 = 0, y0 = 0, z0 = 0, r = 1, n = 101, ...){
f <- function(s,t){
cbind( r * cos(t)*cos(s) + x0,
r * sin(s) + y0,
r * sin(t)*cos(s) + z0)
}
persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, ...)
}
## a set of 3D coordinates for my spheres
agg <- structure(list(X1 = c(-0.308421860438279, -1.42503395393061,
1.10667871416591, -0.41759848570565, 0.523721760757519, 0.520653825151111,
4.54213267745731, 2.96469370222004, 6.32495200153492, 3.78715565912871,
5.35968114482443), X2 = c(0.183223776337368, 1.69719822686475,
-0.992839275466541, 2.22182475540691, -0.705817674534376, -2.40358980860811,
-0.565561169031234, -0.362260309907445, 0.326094711744554, 0.60340188259578,
-0.00167511540165435), X3 = c(-0.712687792799106, -0.0336746884947792,
0.0711272759107127, 1.6126544944538, -2.29999319137504, 1.36257390230441,
-1.52942342176029, -0.316841449239697, -1.69222713171002, 1.23000775530984,
2.30848424740017)), class = c("spec_tbl_df", "tbl_df", "tbl",
"data.frame"), row.names = c(NA, -11L), spec = structure(list(
cols = list(X1 = structure(list(), class = c("collector_double",
"collector")), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
##coordinares of the segments (bonds) connecting the spheres
bond_segments <- structure(list(X1 = c(-1.42503395393061, -0.308421860438279,
1.10667871416591, -0.308421860438279, 0.523721760757519, -0.308421860438279,
-0.41759848570565, -1.42503395393061, 0.520653825151111, 1.10667871416591,
2.96469370222004, 1.10667871416591, 2.96469370222004, 4.54213267745731,
6.32495200153492, 4.54213267745731, 3.78715565912871, 2.96469370222004,
5.35968114482443, 3.78715565912871), X2 = c(1.69719822686475,
0.183223776337368, -0.992839275466541, 0.183223776337368, -0.705817674534376,
0.183223776337368, 2.22182475540691, 1.69719822686475, -2.40358980860811,
-0.992839275466541, -0.362260309907445, -0.992839275466541, -0.362260309907445,
-0.565561169031234, 0.326094711744554, -0.565561169031234, 0.60340188259578,
-0.362260309907445, -0.00167511540165435, 0.60340188259578),
X3 = c(-0.0336746884947792, -0.712687792799106, 0.0711272759107127,
-0.712687792799106, -2.29999319137504, -0.712687792799106,
1.6126544944538, -0.0336746884947792, 1.36257390230441, 0.0711272759107127,
-0.316841449239697, 0.0711272759107127, -0.316841449239697,
-1.52942342176029, -1.69222713171002, -1.52942342176029,
1.23000775530984, -0.316841449239697, 2.30848424740017, 1.23000775530984
)), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"
), row.names = c(NA, -20L), spec = structure(list(cols = list(
X1 = structure(list(), class = c("collector_double", "collector"
)), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
lb <- nrow(bond_segments)/2
open3d()
#> glX
#> 1
par3d(skipRedraw=TRUE)
##material and light effects for the spheres
material3d(ambient = "black", specular = "grey60", emission = "black", shininess = 30.0)
clear3d(type = "lights")
light3d(theta = -30, phi = 60, viewpoint.rel = TRUE, ambient = "#FFFFFF", diffuse = "#FFFFFF", specular = "#FFFFFF", x = NULL, y = NULL, z = NULL)
light3d(theta = -0, phi = 0, viewpoint.rel = TRUE, diffuse = "gray20", specular = "gray25", ambient = "gray80", x = NULL, y = NULL, z = NULL)
## plot the spheres
agg %>%
rowwise() %>%
mutate(spheres = sphere1.f(X1, X2, X3, r=0.5))
#> # A tibble: 11 × 4
#> # Rowwise:
#> X1 X2 X3 spheres
#> <dbl> <dbl> <dbl> <rglLwlvl>
#> 1 -0.308 0.183 -0.713 15
#> 2 -1.43 1.70 -0.0337 16
#> 3 1.11 -0.993 0.0711 17
#> 4 -0.418 2.22 1.61 18
#> 5 0.524 -0.706 -2.30 19
#> 6 0.521 -2.40 1.36 20
#> 7 4.54 -0.566 -1.53 21
#> 8 2.96 -0.362 -0.317 22
#> 9 6.32 0.326 -1.69 23
#> 10 3.79 0.603 1.23 24
#> 11 5.36 -0.00168 2.31 25
### This is the bit of the code which I replaced. I now use cylinders instead
## of segments
## add the segments
## segments3d(bond_segments, lwd=8, color="black")
for (i in 1:lb){
pts <- bond_segments[(2*i-1):(2*i),]
## for the details of this, see the discussion at
## https://r-help.stat.math.ethz.narkive.com/9X5yGnh0/r-joining-two-points-in-rgl
shade3d(cylinder3d(pts, radius=0.1, e2=rbind(c(1,0,0),c(1,0,0))), col="black")
}
par3d(skipRedraw=F)
sessionInfo()
#> R version 4.1.2 (2021-11-01)
#> Platform: x86_64-pc-linux-gnu (64-bit)
#> Running under: Debian GNU/Linux 11 (bullseye)
#>
#> Matrix products: default
#> BLAS: /usr/lib/x86_64-linux-gnu/openblas-pthread/libblas.so.3
#> LAPACK: /usr/lib/x86_64-linux-gnu/openblas-pthread/libopenblasp-r0.3.13.so
#>
#> locale:
#> [1] LC_CTYPE=en_GB.UTF-8 LC_NUMERIC=C
#> [3] LC_TIME=en_GB.UTF-8 LC_COLLATE=en_GB.UTF-8
#> [5] LC_MONETARY=en_GB.UTF-8 LC_MESSAGES=en_GB.UTF-8
#> [7] LC_PAPER=en_GB.UTF-8 LC_NAME=C
#> [9] LC_ADDRESS=C LC_TELEPHONE=C
#> [11] LC_MEASUREMENT=en_GB.UTF-8 LC_IDENTIFICATION=C
#>
#> attached base packages:
#> [1] stats graphics grDevices utils datasets methods base
#>
#> other attached packages:
#> [1] forcats_0.5.1 stringr_1.4.0 dplyr_1.0.8 purrr_0.3.4
#> [5] readr_2.1.0 tidyr_1.1.4 tibble_3.1.6 ggplot2_3.3.5
#> [9] tidyverse_1.3.1 rgl_0.107.14
#>
#> loaded via a namespace (and not attached):
#> [1] Rcpp_1.0.7 lubridate_1.8.0 assertthat_0.2.1 digest_0.6.28
#> [5] utf8_1.2.2 R6_2.5.1 cellranger_1.1.0 backports_1.3.0
#> [9] reprex_2.0.1 evaluate_0.14 httr_1.4.2 highr_0.9
#> [13] pillar_1.6.4 rlang_1.0.1 readxl_1.3.1 R.utils_2.11.0
#> [17] R.oo_1.24.0 rmarkdown_2.11 styler_1.6.2 htmlwidgets_1.5.4
#> [21] munsell_0.5.0 broom_0.7.10 compiler_4.1.2 modelr_0.1.8
#> [25] xfun_0.28 pkgconfig_2.0.3 htmltools_0.5.2 tidyselect_1.1.1
#> [29] fansi_0.5.0 crayon_1.4.2 tzdb_0.2.0 dbplyr_2.1.1
#> [33] withr_2.4.2 R.methodsS3_1.8.1 grid_4.1.2 jsonlite_1.7.2
#> [37] gtable_0.3.0 lifecycle_1.0.1 DBI_1.1.1 magrittr_2.0.1
#> [41] scales_1.1.1 cli_3.1.0 stringi_1.7.5 fs_1.5.0
#> [45] xml2_1.3.2 ellipsis_0.3.2 generics_0.1.1 vctrs_0.3.8
#> [49] tools_4.1.2 R.cache_0.15.0 glue_1.5.0 hms_1.1.1
#> [53] fastmap_1.1.0 yaml_2.2.1 colorspace_2.0-2 rvest_1.0.2
#> [57] knitr_1.36 haven_2.4.3
由 reprex package (v2.0.1)
创建于 2022-03-07
前面的回答已经很接近解决问题了，但是还有一些小问题：
有些球体之间的连接有点扁平，因为在cylinder3d中指定e2参数意味着旋转对称横截面不垂直于圆柱体。将其保留可解决此问题。
您可以看到圆柱体上的刻面（默认情况下为 6 面）。由于这些应该被解释为随场景调整大小的线条，因此使用 lit = FALSE material 属性 抑制照明使它们看起来更像粗线条。
sphere1.f 函数在曲面的边缘连接处有一个明显的接缝，因为 persp3d 使用内点估计法线。明确指定法线可以解决此问题。它们被指定为类似 f 的函数，但给出了表面的单位法线，即
sphere1.f <- function(x0 = 0, y0 = 0, z0 = 0, r = 1, n = 101, ...){
f <- function(s,t){
cbind( r * cos(t)*cos(s) + x0,
r * sin(s) + y0,
r * sin(t)*cos(s) + z0)
}
g <- function(s,t){
cbind( cos(t)*cos(s),
sin(s),
sin(t)*cos(s))
}
persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, normal = g, ...)
}
sphere1.f绘制的每个球体都有 101^2 个顶点。 rgl 可以解决这个问题，但效率很低。由于它们都是相同的，因此 sprites3d 函数可用于在所有不同位置复制单个球体。执行此操作的适当代码是
## plot the spheres
agg %>%
rowwise() %>%
mutate(x = X1, y = X2, z = X3) %>%
sprites3d(shapes = sphere1.f(r = 0.5))
其中在每个计算位置重新绘制以 (0, 0, 0) 为中心的单个球体。这看起来与 R 中的原始文件相同，但会使 rglwidget() 的输出小得多。 （我注意到照明代码中似乎有一个错误，所以 rglwidget() 中的阴影看起来不对
指定的灯。注释掉照明代码可以修复它，但这不是必需的。）
请考虑以下代码段。 它绘制了一组由一些线段连接的球体。 绘制光滑球体的函数来自
的讨论令我困惑的是：当我缩放 in/out RGL 图时，球体和线段的行为不同。特别是，如果我放大，这些片段相对于球体看起来相当细，而当我缩小时它们看起来非常宽。
有没有办法纠正这种行为，以便无论缩放级别如何，始终遵守球体和线段之间的比例？ 非常感谢
library(rgl)
library(tidyverse)
## a function to plot good-looking spheres
sphere1.f <- function(x0 = 0, y0 = 0, z0 = 0, r = 1, n = 101, ...){
f <- function(s,t){
cbind( r * cos(t)*cos(s) + x0,
r * sin(s) + y0,
r * sin(t)*cos(s) + z0)
}
persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, ...)
}
## a set of 3D coordinates for my spheres
agg <- structure(list(X1 = c(-0.308421860438279, -1.42503395393061,
1.10667871416591, -0.41759848570565, 0.523721760757519, 0.520653825151111,
4.54213267745731, 2.96469370222004, 6.32495200153492, 3.78715565912871,
5.35968114482443), X2 = c(0.183223776337368, 1.69719822686475,
-0.992839275466541, 2.22182475540691, -0.705817674534376, -2.40358980860811,
-0.565561169031234, -0.362260309907445, 0.326094711744554, 0.60340188259578,
-0.00167511540165435), X3 = c(-0.712687792799106, -0.0336746884947792,
0.0711272759107127, 1.6126544944538, -2.29999319137504, 1.36257390230441,
-1.52942342176029, -0.316841449239697, -1.69222713171002, 1.23000775530984,
2.30848424740017)), class = c("spec_tbl_df", "tbl_df", "tbl",
"data.frame"), row.names = c(NA, -11L), spec = structure(list(
cols = list(X1 = structure(list(), class = c("collector_double",
"collector")), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
##coordinares of the segments (bonds) connecting the spheres
bond_segments <- structure(list(X1 = c(-1.42503395393061, -0.308421860438279,
1.10667871416591, -0.308421860438279, 0.523721760757519, -0.308421860438279,
-0.41759848570565, -1.42503395393061, 0.520653825151111, 1.10667871416591,
2.96469370222004, 1.10667871416591, 2.96469370222004, 4.54213267745731,
6.32495200153492, 4.54213267745731, 3.78715565912871, 2.96469370222004,
5.35968114482443, 3.78715565912871), X2 = c(1.69719822686475,
0.183223776337368, -0.992839275466541, 0.183223776337368, -0.705817674534376,
0.183223776337368, 2.22182475540691, 1.69719822686475, -2.40358980860811,
-0.992839275466541, -0.362260309907445, -0.992839275466541, -0.362260309907445,
-0.565561169031234, 0.326094711744554, -0.565561169031234, 0.60340188259578,
-0.362260309907445, -0.00167511540165435, 0.60340188259578),
X3 = c(-0.0336746884947792, -0.712687792799106, 0.0711272759107127,
-0.712687792799106, -2.29999319137504, -0.712687792799106,
1.6126544944538, -0.0336746884947792, 1.36257390230441, 0.0711272759107127,
-0.316841449239697, 0.0711272759107127, -0.316841449239697,
-1.52942342176029, -1.69222713171002, -1.52942342176029,
1.23000775530984, -0.316841449239697, 2.30848424740017, 1.23000775530984
)), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"
), row.names = c(NA, -20L), spec = structure(list(cols = list(
X1 = structure(list(), class = c("collector_double", "collector"
)), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
open3d()
#> glX
#> 1
##material and light effects for the spheres
material3d(ambient = "black", specular = "grey60", emission = "black", shininess = 30.0)
clear3d(type = "lights")
light3d(theta = -30, phi = 60, viewpoint.rel = TRUE, ambient = "#FFFFFF", diffuse = "#FFFFFF", specular = "#FFFFFF", x = NULL, y = NULL, z = NULL)
light3d(theta = -0, phi = 0, viewpoint.rel = TRUE, diffuse = "gray20", specular = "gray25", ambient = "gray80", x = NULL, y = NULL, z = NULL)
## plot the spheres
agg %>%
rowwise() %>%
mutate(spheres = sphere1.f(X1, X2, X3, r=0.5))
#> # A tibble: 11 × 4
#> # Rowwise:
#> X1 X2 X3 spheres
#> <dbl> <dbl> <dbl> <rglLwlvl>
#> 1 -0.308 0.183 -0.713 15
#> 2 -1.43 1.70 -0.0337 16
#> 3 1.11 -0.993 0.0711 17
#> 4 -0.418 2.22 1.61 18
#> 5 0.524 -0.706 -2.30 19
#> 6 0.521 -2.40 1.36 20
#> 7 4.54 -0.566 -1.53 21
#> 8 2.96 -0.362 -0.317 22
#> 9 6.32 0.326 -1.69 23
#> 10 3.79 0.603 1.23 24
#> 11 5.36 -0.00168 2.31 25
## add the segments
segments3d(bond_segments, lwd=8, color="black")
sessionInfo()
#> R version 4.1.2 (2021-11-01)
#> Platform: x86_64-pc-linux-gnu (64-bit)
#> Running under: Debian GNU/Linux 11 (bullseye)
#>
#> Matrix products: default
#> BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0
#> LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
#>
#> locale:
#> [1] LC_CTYPE=en_GB.UTF-8 LC_NUMERIC=C
#> [3] LC_TIME=en_GB.UTF-8 LC_COLLATE=en_GB.UTF-8
#> [5] LC_MONETARY=en_GB.UTF-8 LC_MESSAGES=en_GB.UTF-8
#> [7] LC_PAPER=en_GB.UTF-8 LC_NAME=C
#> [9] LC_ADDRESS=C LC_TELEPHONE=C
#> [11] LC_MEASUREMENT=en_GB.UTF-8 LC_IDENTIFICATION=C
#>
#> attached base packages:
#> [1] stats graphics grDevices utils datasets methods base
#>
#> other attached packages:
#> [1] forcats_0.5.1 stringr_1.4.0 dplyr_1.0.8 purrr_0.3.4
#> [5] readr_2.1.1 tidyr_1.2.0 tibble_3.1.6 ggplot2_3.3.5
#> [9] tidyverse_1.3.1 rgl_0.108.3
#>
#> loaded via a namespace (and not attached):
#> [1] Rcpp_1.0.7 lubridate_1.8.0 assertthat_0.2.1 digest_0.6.29
#> [5] utf8_1.2.2 R6_2.5.1 cellranger_1.1.0 backports_1.4.1
#> [9] reprex_2.0.1 evaluate_0.14 httr_1.4.2 highr_0.9
#> [13] pillar_1.6.4 rlang_1.0.1 readxl_1.3.1 R.utils_2.11.0
#> [17] R.oo_1.24.0 rmarkdown_2.11 styler_1.6.2 htmlwidgets_1.5.4
#> [21] munsell_0.5.0 broom_0.7.10 compiler_4.1.2 modelr_0.1.8
#> [25] xfun_0.29 pkgconfig_2.0.3 htmltools_0.5.2 tidyselect_1.1.1
#> [29] fansi_0.5.0 crayon_1.4.2 tzdb_0.2.0 dbplyr_2.1.1
#> [33] withr_2.4.3 R.methodsS3_1.8.1 grid_4.1.2 jsonlite_1.7.2
#> [37] gtable_0.3.0 lifecycle_1.0.1 DBI_1.1.2 magrittr_2.0.1
#> [41] scales_1.1.1 cli_3.1.0 stringi_1.7.6 fs_1.5.2
#> [45] xml2_1.3.3 ellipsis_0.3.2 generics_0.1.1 vctrs_0.3.8
#> [49] tools_4.1.2 R.cache_0.15.0 glue_1.6.0 hms_1.1.1
#> [53] fastmap_1.1.0 yaml_2.2.1 colorspace_2.0-2 rvest_1.0.2
#> [57] knitr_1.37 haven_2.4.3
由 reprex package (v2.0.1)
创建于 2022-03-06感谢您提出宝贵建议。 求助于气缸完成了工作。关于圆柱体的设置，我真的复制粘贴了这里讨论的一部分
https://r-help.stat.math.ethz.narkive.com/9X5yGnh0/r-joining-two-points-in-rgl
library(rgl)
library(tidyverse)
## a function to plot good-looking spheres
sphere1.f <- function(x0 = 0, y0 = 0, z0 = 0, r = 1, n = 101, ...){
f <- function(s,t){
cbind( r * cos(t)*cos(s) + x0,
r * sin(s) + y0,
r * sin(t)*cos(s) + z0)
}
persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, ...)
}
## a set of 3D coordinates for my spheres
agg <- structure(list(X1 = c(-0.308421860438279, -1.42503395393061,
1.10667871416591, -0.41759848570565, 0.523721760757519, 0.520653825151111,
4.54213267745731, 2.96469370222004, 6.32495200153492, 3.78715565912871,
5.35968114482443), X2 = c(0.183223776337368, 1.69719822686475,
-0.992839275466541, 2.22182475540691, -0.705817674534376, -2.40358980860811,
-0.565561169031234, -0.362260309907445, 0.326094711744554, 0.60340188259578,
-0.00167511540165435), X3 = c(-0.712687792799106, -0.0336746884947792,
0.0711272759107127, 1.6126544944538, -2.29999319137504, 1.36257390230441,
-1.52942342176029, -0.316841449239697, -1.69222713171002, 1.23000775530984,
2.30848424740017)), class = c("spec_tbl_df", "tbl_df", "tbl",
"data.frame"), row.names = c(NA, -11L), spec = structure(list(
cols = list(X1 = structure(list(), class = c("collector_double",
"collector")), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
##coordinares of the segments (bonds) connecting the spheres
bond_segments <- structure(list(X1 = c(-1.42503395393061, -0.308421860438279,
1.10667871416591, -0.308421860438279, 0.523721760757519, -0.308421860438279,
-0.41759848570565, -1.42503395393061, 0.520653825151111, 1.10667871416591,
2.96469370222004, 1.10667871416591, 2.96469370222004, 4.54213267745731,
6.32495200153492, 4.54213267745731, 3.78715565912871, 2.96469370222004,
5.35968114482443, 3.78715565912871), X2 = c(1.69719822686475,
0.183223776337368, -0.992839275466541, 0.183223776337368, -0.705817674534376,
0.183223776337368, 2.22182475540691, 1.69719822686475, -2.40358980860811,
-0.992839275466541, -0.362260309907445, -0.992839275466541, -0.362260309907445,
-0.565561169031234, 0.326094711744554, -0.565561169031234, 0.60340188259578,
-0.362260309907445, -0.00167511540165435, 0.60340188259578),
X3 = c(-0.0336746884947792, -0.712687792799106, 0.0711272759107127,
-0.712687792799106, -2.29999319137504, -0.712687792799106,
1.6126544944538, -0.0336746884947792, 1.36257390230441, 0.0711272759107127,
-0.316841449239697, 0.0711272759107127, -0.316841449239697,
-1.52942342176029, -1.69222713171002, -1.52942342176029,
1.23000775530984, -0.316841449239697, 2.30848424740017, 1.23000775530984
)), class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"
), row.names = c(NA, -20L), spec = structure(list(cols = list(
X1 = structure(list(), class = c("collector_double", "collector"
)), X2 = structure(list(), class = c("collector_double",
"collector")), X3 = structure(list(), class = c("collector_double",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), skip = 0), class = "col_spec"))
lb <- nrow(bond_segments)/2
open3d()
#> glX
#> 1
par3d(skipRedraw=TRUE)
##material and light effects for the spheres
material3d(ambient = "black", specular = "grey60", emission = "black", shininess = 30.0)
clear3d(type = "lights")
light3d(theta = -30, phi = 60, viewpoint.rel = TRUE, ambient = "#FFFFFF", diffuse = "#FFFFFF", specular = "#FFFFFF", x = NULL, y = NULL, z = NULL)
light3d(theta = -0, phi = 0, viewpoint.rel = TRUE, diffuse = "gray20", specular = "gray25", ambient = "gray80", x = NULL, y = NULL, z = NULL)
## plot the spheres
agg %>%
rowwise() %>%
mutate(spheres = sphere1.f(X1, X2, X3, r=0.5))
#> # A tibble: 11 × 4
#> # Rowwise:
#> X1 X2 X3 spheres
#> <dbl> <dbl> <dbl> <rglLwlvl>
#> 1 -0.308 0.183 -0.713 15
#> 2 -1.43 1.70 -0.0337 16
#> 3 1.11 -0.993 0.0711 17
#> 4 -0.418 2.22 1.61 18
#> 5 0.524 -0.706 -2.30 19
#> 6 0.521 -2.40 1.36 20
#> 7 4.54 -0.566 -1.53 21
#> 8 2.96 -0.362 -0.317 22
#> 9 6.32 0.326 -1.69 23
#> 10 3.79 0.603 1.23 24
#> 11 5.36 -0.00168 2.31 25
### This is the bit of the code which I replaced. I now use cylinders instead
## of segments
## add the segments
## segments3d(bond_segments, lwd=8, color="black")
for (i in 1:lb){
pts <- bond_segments[(2*i-1):(2*i),]
## for the details of this, see the discussion at
## https://r-help.stat.math.ethz.narkive.com/9X5yGnh0/r-joining-two-points-in-rgl
shade3d(cylinder3d(pts, radius=0.1, e2=rbind(c(1,0,0),c(1,0,0))), col="black")
}
par3d(skipRedraw=F)
sessionInfo()
#> R version 4.1.2 (2021-11-01)
#> Platform: x86_64-pc-linux-gnu (64-bit)
#> Running under: Debian GNU/Linux 11 (bullseye)
#>
#> Matrix products: default
#> BLAS: /usr/lib/x86_64-linux-gnu/openblas-pthread/libblas.so.3
#> LAPACK: /usr/lib/x86_64-linux-gnu/openblas-pthread/libopenblasp-r0.3.13.so
#>
#> locale:
#> [1] LC_CTYPE=en_GB.UTF-8 LC_NUMERIC=C
#> [3] LC_TIME=en_GB.UTF-8 LC_COLLATE=en_GB.UTF-8
#> [5] LC_MONETARY=en_GB.UTF-8 LC_MESSAGES=en_GB.UTF-8
#> [7] LC_PAPER=en_GB.UTF-8 LC_NAME=C
#> [9] LC_ADDRESS=C LC_TELEPHONE=C
#> [11] LC_MEASUREMENT=en_GB.UTF-8 LC_IDENTIFICATION=C
#>
#> attached base packages:
#> [1] stats graphics grDevices utils datasets methods base
#>
#> other attached packages:
#> [1] forcats_0.5.1 stringr_1.4.0 dplyr_1.0.8 purrr_0.3.4
#> [5] readr_2.1.0 tidyr_1.1.4 tibble_3.1.6 ggplot2_3.3.5
#> [9] tidyverse_1.3.1 rgl_0.107.14
#>
#> loaded via a namespace (and not attached):
#> [1] Rcpp_1.0.7 lubridate_1.8.0 assertthat_0.2.1 digest_0.6.28
#> [5] utf8_1.2.2 R6_2.5.1 cellranger_1.1.0 backports_1.3.0
#> [9] reprex_2.0.1 evaluate_0.14 httr_1.4.2 highr_0.9
#> [13] pillar_1.6.4 rlang_1.0.1 readxl_1.3.1 R.utils_2.11.0
#> [17] R.oo_1.24.0 rmarkdown_2.11 styler_1.6.2 htmlwidgets_1.5.4
#> [21] munsell_0.5.0 broom_0.7.10 compiler_4.1.2 modelr_0.1.8
#> [25] xfun_0.28 pkgconfig_2.0.3 htmltools_0.5.2 tidyselect_1.1.1
#> [29] fansi_0.5.0 crayon_1.4.2 tzdb_0.2.0 dbplyr_2.1.1
#> [33] withr_2.4.2 R.methodsS3_1.8.1 grid_4.1.2 jsonlite_1.7.2
#> [37] gtable_0.3.0 lifecycle_1.0.1 DBI_1.1.1 magrittr_2.0.1
#> [41] scales_1.1.1 cli_3.1.0 stringi_1.7.5 fs_1.5.0
#> [45] xml2_1.3.2 ellipsis_0.3.2 generics_0.1.1 vctrs_0.3.8
#> [49] tools_4.1.2 R.cache_0.15.0 glue_1.5.0 hms_1.1.1
#> [53] fastmap_1.1.0 yaml_2.2.1 colorspace_2.0-2 rvest_1.0.2
#> [57] knitr_1.36 haven_2.4.3
由 reprex package (v2.0.1)
创建于 2022-03-07前面的回答
有些球体之间的连接有点扁平，因为在
cylinder3d中指定e2参数意味着旋转对称横截面不垂直于圆柱体。将其保留可解决此问题。您可以看到圆柱体上的刻面（默认情况下为 6 面）。由于这些应该被解释为随场景调整大小的线条，因此使用
lit = FALSEmaterial 属性 抑制照明使它们看起来更像粗线条。sphere1.f函数在曲面的边缘连接处有一个明显的接缝，因为persp3d使用内点估计法线。明确指定法线可以解决此问题。它们被指定为类似f的函数，但给出了表面的单位法线，即sphere1.f <- function(x0 = 0, y0 = 0, z0 = 0, r = 1, n = 101, ...){ f <- function(s,t){ cbind( r * cos(t)*cos(s) + x0, r * sin(s) + y0, r * sin(t)*cos(s) + z0) } g <- function(s,t){ cbind( cos(t)*cos(s), sin(s), sin(t)*cos(s)) } persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, normal = g, ...) }sphere1.f绘制的每个球体都有 101^2 个顶点。rgl可以解决这个问题，但效率很低。由于它们都是相同的，因此sprites3d函数可用于在所有不同位置复制单个球体。执行此操作的适当代码是## plot the spheres agg %>% rowwise() %>% mutate(x = X1, y = X2, z = X3) %>% sprites3d(shapes = sphere1.f(r = 0.5))
其中在每个计算位置重新绘制以 (0, 0, 0) 为中心的单个球体。这看起来与 R 中的原始文件相同，但会使 rglwidget() 的输出小得多。 （我注意到照明代码中似乎有一个错误，所以 rglwidget() 中的阴影看起来不对
指定的灯。注释掉照明代码可以修复它，但这不是必需的。）