Mapping a picture on a donut or a Hopf torus

[This article was first published on Saturn Elephant, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
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 s1, the following map: (u,v)(x,y,z)=(scosus,ssinus,sinv)s2+1cosv

is a conformal parameterization of the torus (the donut), where sπu<sπ and πv<π. 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:

To leave a comment for the author, please follow the link and comment on their blog: Saturn Elephant.

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.

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)