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 \geqslant 1\), the following map: \[ (u, v) \mapsto (x, y, z) = \frac{\Bigl(s\cos\frac{u}{s}, s\sin\frac{u}{s}, \sin v\Bigr)}{\sqrt{s^2+1}-\cos v} \] is a conformal parameterization of the torus (the donut), where \(-s\pi \leqslant u < s\pi\) and \(\pi \leqslant v < \pi\). I found it in this paper by J.M. Sullivan. The number \(s\) is the ratio of the major radius over the minor radius.
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.