Question

考虑Togliatti隐式曲面。我想将其剪切到半径为4.8的以原点为中心的球上。带有misc3d包的解决方案在于使用mask函数的computeContour3d参数，该参数只允许使用满足x^2+y^2+z^2 < 4.8^2的点：

library(misc3d)

# Togliatti surface equation: f(x,y,z) = 0
f <- function(x,y,z){
  w <- 1
  64*(x-w)*
    (x^4-4*x^3*w-10*x^2*y^2-4*x^2*w^2+16*x*w^3-20*x*y^2*w+5*y^4+16*w^4-20*y^2*w^2) - 
    5*sqrt(5-sqrt(5))*(2*z-sqrt(5-sqrt(5))*w)*(4*(x^2+y^2-z^2)+(1+3*sqrt(5))*w^2)^2
}

# make grid
nx <- 220; ny <- 220; nz <- 220
x <- seq(-5, 5, length=nx) 
y <- seq(-5, 5, length=ny)
z <- seq(-4, 4, length=nz) 
g <- expand.grid(x=x, y=y, z=z)

# calculate voxel
voxel <- array(with(g, f(x,y,z)), dim = c(nx,ny,nz))

# mask: keep points satisfying x^2+y^2+z^2 < 4.8^2, in order to 
#       clip the surface to the ball of radius 4.8
mask <- array(with(g, x^2+y^2+z^2 < 4.8^2), dim = c(nx,ny,nz))

# compute isosurface
surf <- computeContour3d(voxel, maxvol=max(voxel), level=0, mask=mask, x=x, y=y, z=z)

# draw isosurface
drawScene.rgl(makeTriangles(surf, smooth=TRUE))

但是最终表面的边界是不规则的：

如何获得规则，平滑的边框？

Answer 1

我找到的解决方案是使用球坐标。它包括根据球坐标f定义函数(ρ, θ, ϕ)，然后计算ρ从0到所需半径的等值面，然后转换结果到笛卡尔坐标：

# Togliatti surface equation with spherical coordinates
f <- function(ρ, θ, ϕ){
  w <- 1
  x <- ρ*cos(θ)*sin(ϕ)
  y <- ρ*sin(θ)*sin(ϕ)
  z <- ρ*cos(ϕ)
  64*(x-w)*
    (x^4-4*x^3*w-10*x^2*y^2-4*x^2*w^2+16*x*w^3-20*x*y^2*w+5*y^4+16*w^4-20*y^2*w^2) - 
    5*sqrt(5-sqrt(5))*(2*z-sqrt(5-sqrt(5))*w)*(4*(x^2+y^2-z^2)+(1+3*sqrt(5))*w^2)^2
}

# make grid
nρ <- 300; nθ <- 400; nϕ <- 300
ρ <- seq(0, 4.8, length = nρ) # ρ runs from 0 to the desired radius
θ <- seq(0, 2*pi, length = nθ)
ϕ <- seq(0, pi, length = nϕ) 
g <- expand.grid(ρ=ρ, θ=θ, ϕ=ϕ)

# calculate voxel
voxel <- array(with(g, f(ρ,θ,ϕ)), dim = c(nρ,nθ,nϕ))

# calculate isosurface
surf <- computeContour3d(voxel, maxvol=max(voxel), level=0, x=ρ, y=θ, z=ϕ)

# transform to Cartesian coordinates
surf <- t(apply(surf, 1, function(rtp){
  ρ <- rtp[1]; θ <- rtp[2]; ϕ <- rtp[3] 
  c(
    ρ*cos(θ)*sin(ϕ),
    ρ*sin(θ)*sin(ϕ),
    ρ*cos(ϕ)
  )
}))

# draw isosurface
drawScene.rgl(makeTriangles(surf, smooth=TRUE, color = "violetred"))

现在生成的表面具有规则的平滑边界：

Answer 2

您的解决方案非常适合您遇到的问题，因为球坐标对于该边界是如此的自然。但是，这是一个更通用的解决方案，适用于其他平滑边界。

该想法是允许输入边界函数，以及当它们过大或过小时都剔除它们。在您的情况下，这将是与原点的平方距离，并且您想剔除值大于4.8 ^ 2的点。但是有时绘制为使表面光滑的三角形仅应部分剔除：将保留一个点并删除两个点，或者保留两个点并删除一个点。如果您剔除会导致原始图上锯齿状边缘的整个三角形。

要解决此问题，可以修改这些点。如果只保留其中一个，则可以将其他两个点向其缩小，直到它们位于边界的近似值上。如果要保留两个，则您希望形状为四边形，那么您将用两个三角形来构建形状。

假设输入surf是computeContour3d的输出，此函数将执行以下操作：

boundSurface <- function(surf, boundFn, bound = 0, greater = TRUE) {
  # Surf is n x 3:  each row is a point, triplets are triangles
  values <- matrix(boundFn(surf) - bound, 3)
  # values is (m = n/3) x 3:  each row is the boundFn value at one point
  # of a triangle
  if (!greater) 
    values <- -values
  keep <- values >= 0
  # counts is m vector counting number of points to keep in each triangle
  counts <- apply(keep, 2, sum)
  # result is initialized to an empty array
  result <- matrix(nrow = 0, ncol = 3)
  # singles is set to all the rows of surf where exactly one
  # point in the triangle is kept, say s x 3
  singles <- surf[rep(counts == 1, each = 3),]
  if (length(singles)) {
    # singleValues is a subset of values where only one vertex is kept
    singleValues <- values[, counts == 1]
    singleIndex <- 3*col(singleValues) + 1:3 - 3
    # good is the index of the vertex to keep, bad are those to fix
    good <- apply(singleValues, 2, function(col) which(col >= 0))
    bad <- apply(singleValues, 2, function(col) which(col < 0))
    for (j in 1:ncol(singleValues)) {
      goodval <- singleValues[good[j], j]
      for (i in 1:2) {
        badval <- singleValues[bad[i,j], j]
        alpha <- goodval/(goodval - badval)
        singles[singleIndex[bad[i,j], j], ] <- 
          (1-alpha)*singles[singleIndex[good[j], j],] +
             alpha *singles[singleIndex[bad[i,j], j],]
      }
    }
    result <- rbind(result, singles)
  }
  doubles <- surf[rep(counts == 2, each = 3),]
  if (length(doubles)) {
    # doubleValues is a subset of values where two vertices are kept
    doubleValues <- values[, counts == 2]
    doubleIndex <- 3*col(doubleValues) + 1:3 - 3
    doubles2 <- doubles
    # good is the index of the vertex to keep, bad are those to fix
    good <- apply(doubleValues, 2, function(col) which(col >= 0))
    bad <- apply(doubleValues, 2, function(col) which(col < 0))
    newvert <- matrix(NA, 2, 3)
    for (j in 1:ncol(doubleValues)) {
      badval <- doubleValues[bad[j], j]
      for (i in 1:2) {
        goodval <- doubleValues[good[i,j], j]
        alpha <- goodval/(goodval - badval)
        newvert[i,] <- 
          (1-alpha)*doubles[doubleIndex[good[i,j], j],] +
             alpha *doubles[doubleIndex[bad[j], j],]
      }
      doubles[doubleIndex[bad[j], j],] <- newvert[1,]
      doubles2[doubleIndex[good[1,j], j],] <- newvert[1,]
      doubles2[doubleIndex[bad[j], j],] <- newvert[2,]
    }
    result <- rbind(result, doubles, doubles2)
  }
  # Finally add all the rows of surf where the whole
  # triangle is kept
  rbind(result, surf[rep(counts == 3, each = 3),])
}

您可以在computeContour3d之后和makeTriangles之前使用它，例如

fn <- function(x) { 
  apply(x^2, 1, sum)
}

drawScene.rgl(makeTriangles(boundSurface(surf, fn, bound = 4.8^2, 
                                         greater = FALSE), 
                            smooth = TRUE))

这是我看到的输出：

它不如您的好，但是可以用于许多不同的边界函数。

如何将等值面修剪到球上？

2 个答案: