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

前面的回答已经很接近解决问题了,但是还有一些小问题:

  1. 有些球体之间的连接有点扁平,因为在cylinder3d中指定e2参数意味着旋转对称横截面不垂直于圆柱体。将其保留可解决此问题。

  2. 您可以看到圆柱体上的刻面(默认情况下为 6 面)。由于这些应该被解释为随场景调整大小的线条,因此使用 lit = FALSE material 属性 抑制照明使它们看起来更像粗线条。

  3. 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, ...)
    }
    
  4. 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() 中的阴影看起来不对 指定的灯。注释掉照明代码可以修复它,但这不是必需的。)