--- author: Stéphane Laurent date: '2022-01-29' highlighter: 'pandoc-solarized' output: html_document: highlight: kate keep_md: no md_document: preserve_yaml: True variant: markdown rbloggers: yes tags: 'R, rgl, misc3d, graphics' title: Hopf torus with dynamic colors --- In a [recent post](https://laustep.github.io/stlahblog/posts/PyVistaDynamicCmap.html) I explained how to decorate a surface with moving colors with the Python library **PyVista**. Here I expose this method for the R package **rgl**. I will take a Hopf torus with fives lobes for the illustration. The following R function is a slight modification of the parametric3d function of the **misc3d** package. It is more efficient for the Hopf torus parameterization and it returns a **rgl** object of class mesh3d.  {.r} library(misc3d) library(rgl) parametricMesh3d <- function( Fxyz, umin, umax, vmin, vmax, nu, nv ){ u <- seq(umin, umax, length.out = nu) v <- seq(vmin, vmax, length.out = nv) tg <- misc3d:::expandTriangleGrid(u, v) f <- function(uv) Fxyz(uv[, 1L], uv[, 2L]) v1 <- f(tg$v1) v2 <- f(tg$v2) v3 <- f(tg$v3) tris <- makeTriangles(v1, v2, v3) mesh0 <- misc3d:::t2ve(tris) addNormals( tmesh3d( vertices = mesh0$vb, indices = mesh0$ib ) ) }  The R function below is the parameterization of the Hopf torus.  {.r} HTxyz <- function(u, v, nlobes = 5, A = 0.38){ C <- pi/2 - (pi/2-A)*cos(u*nlobes) sinC <- sin(C) D <- u + A*sin(2*u*nlobes) p1 <- cos(C) + 1 p2 <- sinC * cos(D) p3 <- sinC * sin(D) cos_v <- cos(v) sin_v <- sin(v) x1 <- cos_v*p3 + sin_v*p2 x2 <- cos_v*p2 - sin_v*p3 x3 <- sin_v * p1 xden <- sqrt(2*p1) - cos_v*p1 cbind(x1/xden, x2/xden, x3/xden) }  Let's make the Hopf torus mesh now.  {.r} mesh <- parametricMesh3d( HTxyz, umin = 0, umax = 2*pi, vmin = -pi, vmax = pi, nu = 600, nv = 400 )  We will assign a color to each point on the surface, according to the distance from the point to the origin. We calculate these distances below, and we linearly map them to the interval$[0, 2\pi]$.  {.r} d <- sqrt(apply(mesh$vb[-4L, ], 2L, crossprod)) d <- 2*pi * (d - min(d)) / diff(range(d))  Now we introduce a color palette function. The **trekcolors** package has nice color palettes. I'm taking the dominion palette.  {.r} library(trekcolors) fpalette <- colorRamp( trek_pal("dominion"), bias = 0.6, interpolate = "spline" )  This function fpalette assign a color, given by its RGB values, to each number between $0$ and $1$. As in Python, we will calculate $\sin(d -t)$ to move the colors, with $t$ varying from $0$ to $2\pi$. The sine function takes its values in $[-1, 1]$ so we will map this interval to $[0,1]$ with the affine function $x \mapsto \frac{x+1}{2}$ in order to apply the fpalette function. We will also rotate the Hopf torus around the $z$-axis. By the symmetry of the Hopf torus, it suffices to make the rotation with an angle varying from $0$ to $2\pi/5$.  {.r} t_ <- seq(0, 2*pi, length.out = 73)[-1L] angle_ <- seq(0, 2*pi/5, length.out = 73)[-1L] for(i in seq_along(t_)){ RGB <- fpalette( (sin(d-t_[i])+1)/2 ) mesh[["material"]] <- list(color = rgb(RGB[, 1L], RGB[, 2L], RGB[, 3L], maxColorValue = 255)) rmesh <- rotate3d(mesh, angle_[i], 0, 0, 1) open3d(windowRect = c(50, 50, 562, 562)) view3d(0, 0, zoom = 0.55) spheres3d(0, 0, 0, radius = 11, color = "white", alpha = 0) # to fix the view shade3d(rmesh) rgl.snapshot(sprintf("pic%03d.png", i)) close3d() }  This code generates a series of png files pic001.png, ..., pic072.png. Using **ImageMagick** or **gifski**, we obtain this gif animation from these files: ![](figures/HTdominion.gif) Very well. But these are not my favorite colors. And I prefer the Hopf torus with three lobes. Below it is, decorated with the klingon color palette of **trekcolors**; I prefer this one. ![](figures/HTklingon2.gif)