Mapping a picture on a donut or a Hopf torus
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
The donut torus
Given a number s⩾1, the
following map:
(u,v)↦(x,y,z)=(scosus,ssinus,sinv)√s2+1−cosv
The conformality of the map has the following consequence: you can easily map a doubly periodic image on the torus in such a way that it will perfectly fit on the torus.
Mapping a checkerboard
Let me show what I mean. The code below generates a mesh of the torus with a checkerboard mapped on its surface:
library(rgl) library(Rvcg) # to use vcgUpdateNormals() torusMesh <- function(s, nu, nv){ nu <- as.integer(nu) nv <- as.integer(nv) nunv <- nu * nv vs <- matrix(NA_real_, nrow = 3L, ncol = nunv) tris1 <- matrix(NA_integer_, nrow = 3L, ncol = nunv) tris2 <- matrix(NA_integer_, nrow = 3L, ncol = nunv) u_ <- seq(-pi*s, pi*s, length.out = nu + 1L)[-1L] v_ <- seq(-pi, pi, length.out = nv + 1L)[-1L] scosu_ <- s * cos(u_ / s) ssinu_ <- s * sin(u_ / s) sinv_ <- sin(v_) w <- sqrt(s*s + 1) - cos(v_) jp1_ <- c(2L:nv, 1L) j_ <- 1L:nv color <- NULL for(i in 1L:(nu-1L)){ i_nv <- i*nv rg <- (i_nv - nv + 1L):i_nv vs[, rg] <- rbind( scosu_[i] / w, ssinu_[i] / w, sinv_ / w ) color <- c( color, if(mod(floor(5 * u_[i] / (pi*s)), 2) == 0){ ifelse( floor(5 * v_ / pi) %% 2 == 0, "yellow", "navy" ) }else{ ifelse( floor(5 * v_ / pi) %% 2 == 0, "navy", "yellow" ) } ) k1 <- i_nv - nv k_ <- k1 + j_ l_ <- k1 + jp1_ m_ <- i_nv + j_ tris1[, k_] <- rbind(m_, l_, k_) tris2[, k_] <- rbind(m_, i_nv + jp1_, l_) } i_nv <- nunv rg <- (i_nv - nv + 1L):i_nv vs[, rg] <- rbind( scosu_[nu] / w, ssinu_[nu] / w, sinv_ / w ) color <- c( color, ifelse( floor(5 * v_ / pi) %% 2 == 0, "yellow", "navy" ) ) k1 <- i_nv - nv l_ <- k1 + jp1_ k_ <- k1 + j_ tris1[, k_] <- rbind(j_, l_, k_) tris2[, k_] <- rbind(j_, jp1_, l_) tmesh <- tmesh3d( vertices = vs, indices = cbind(tris1, tris2), homogeneous = FALSE, material = list("color" = color) ) vcgUpdateNormals(tmesh) }
Let’s see:
mesh <- torusMesh(s = sqrt(2), nu = 500, nv = 500) open3d(windowRect = c(50, 50, 562, 562), zoom = 0.85) bg3d("gainsboro") shade3d(mesh)
Now you surely see what I mean.
Mapping a Gray-Scott picture
I am a fan of the Fronkonstin blog. Maybe you already see this article about the Gray-Scott reaction-diffusion model (it appeared on R-bloggers). It shows how to generate some beautiful pictures which are doubly periodic. So let’s map such a picture on the donut:
...... fcolor <- colorRamp(viridisLite::magma(255L)) getColors <- function(B){ rgbs <- fcolor(B) rgb(rgbs[, 1L], rgbs[, 2L], rgbs[, 3L], maxColorValue = 255) } X <- iterate_Gray_Scott(X, L, DA, DB, 500) Colors <- getColors(c(X[,,2L])) mesh <- torusMesh(s = sqrt(2), nu = 600, nv = 600) mesh[["material"]] <- list("color" = Colors) open3d(windowRect = c(50, 50, 562, 562), zoom = 0.85) bg3d("gainsboro") shade3d(mesh)
Beautiful!
The Hopf torus
We can similarly map a picture on a Hopf torus, with this conformal parameterization:
HT <- function(h, nlobes, t, phi){ # the spherical curve p1 <- sin(h * cos(nlobes*t)) p2 <- cos(t) * cos(h * cos(nlobes*t)) p3 <- sin(t) * cos(h * cos(nlobes*t)) # parameterization yden <- sqrt(2*(1+p1)) y1 <- (1+p1)/yden y2 <- p2/yden y3 <- p3/yden cosphi <- cos(phi) sinphi <- sin(phi) x1 <- cosphi*y1 x2 <- sinphi*y1 x3 <- cosphi*y2 - sinphi*y3 x4 <- cosphi*y3 + sinphi*y2 return(rbind(x1/(1-x4), x2/(1-x4), x3/(1-x4))) }
Checkerboard
The code to construct the mesh with the checkerboard is similar to the one for the donut torus:
HopfTorusMesh <- function(h, nlobes, nu, nv){ nu <- as.integer(nu) nv <- as.integer(nv) vs <- matrix(NA_real_, nrow = 3L, ncol = nu*nv) tris1 <- matrix(NA_integer_, nrow = 3L, ncol = nu*nv) tris2 <- matrix(NA_integer_, nrow = 3L, ncol = nu*nv) u_ <- seq(-pi, pi, length.out = nu + 1L)[-1L] v_ <- seq(-pi, pi, length.out = nv + 1L)[-1L] jp1_ <- c(2L:nv, 1L) j_ <- 1L:nv color <- NULL for(i in 1L:(nu-1L)){ i_nv <- i*nv vs[, (i_nv - nv + 1L):i_nv] <- HT(h, nlobes, u_[i], v_) color <- c( color, if(mod(floor(10 * u_[i] / pi), 2) == 0){ ifelse( floor(10 * v_ / pi) %% 2 == 0, "yellow", "navy" ) }else{ ifelse( floor(10 * v_ / pi) %% 2 == 0, "navy", "yellow" ) } ) k1 <- i_nv - nv k_ <- k1 + j_ l_ <- k1 + jp1_ m_ <- i_nv + j_ tris1[, k_] <- rbind(k_, l_, m_) tris2[, k_] <- rbind(l_, i_nv + jp1_, m_) } i_nv <- nu*nv vs[, (i_nv - nv + 1L):i_nv] <- HT(h, nlobes, pi, v_) color <- c( color, ifelse( floor(10 * v_ / pi) %% 2 == 0, "yellow", "navy" ) ) k1 <- i_nv - nv k_ <- k1 + j_ l_ <- k1 + jp1_ tris1[, k_] <- rbind(k_, l_, j_) tris2[, k_] <- rbind(l_, jp1_, j_) vcgUpdateNormals(tmesh3d( vertices = vs, indices = cbind(tris1, tris2), homogeneous = FALSE, material = list("color" = color) )) } mesh <- HopfTorusMesh(h = 0.4, nlobes = 4, nu = 500, nv = 500) open3d(windowRect = c(50, 50, 562, 562), zoom = 0.85) bg3d("gainsboro") shade3d(mesh)
I really like it.
Gray-Scott picture
To map the Gray-Scott picture, we proceed as for the donut torus. Here is the result:
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.