ListPlot3D包含在「不規則」區域中的「常規」晶格上的數據

Question

在嘗試繪製Mathematica中的某些3D數據時，我遇到以下問題。該數據最初計算定期晶格，即我計算

data = Flatten[Table[{x,y,f[x,y]},{x,x0,x1,dx},{y,y0,y1,dy}],1] 

的問題是，僅f在非凸子集U在飛機上取實數值。 U實際上是相當討厭的：一個「三角形」的區域，所有的角落都是cuspy（想象一下三個相同的圓之間的區域，其中任何兩個相切）。當我嘗試繪製data和ListPlot3D時，後者繪製了U的凸包上的表面。

我想知道是否有辦法告訴Mathematica只能在U之內限制自己。我在想，既然我的觀點已經在「常規」格上了，這應該不會太困難，但我還沒有找到解決方案。

我知道RegionFunction選項，但它在我的情況下計算是非常昂貴的，所以我試圖找出一種方法，只使用data中已經計算的點。

Answer 1

要生成一個非常好的圖片，而不使用無數的點，您可能需要使用包含所需區域邊界的點的非均勻分佈。這裏有一個有點像你所描述的例子。我們從三個相切的圓開始。

circPic = Graphics[{Circle[{0, Sqrt[3]}, 1], 
    Circle[{-1, 0}, 1], Circle[{1, 0}, 1]}] 

我們寫一個布爾函數，其確定是否在該矩形的一個點{-1/2,1/2}由{0，的Sqrt [3]/2}在於所有的外圓圈並使用它在感興趣的區域生成一些點。

inRegionQ[p:{x_, y_}] := Norm[p - {1, 0}] > 1 && 
    Norm[p + {1, 0}] > 1 && Norm[p - {0, Sqrt[3]}] > 1; 
rectPoints = N[Flatten[Table[{x, y}, 
    {x, -1/2, 1/2, 0.02}, {y, 0.05, Sqrt[3]/2, 0.02}], 1]]; 
regionPoints = Select[rectPoints, inRegionQ]; 

現在我們生成邊界。參數n確定我們在邊界上放置多少個點。

n = 120; 
boundary = N[Join[ 
    Table[{1 - Cos[t], Sin[t]}, {t, Pi/n, Pi/3, Pi/n}], 
    Table[{Cos[t], Sqrt[3] - Sin[t]}, {t, Pi/3 + Pi/n, 2 Pi/3, Pi/n}], 
    Table[{Cos[t] - 1, Sin[t]}, {t, Pi/3 - Pi/n, 0, -Pi/n}]]]; 
points = Join[boundary, regionPoints]; 

讓我們來看看。

Show[circPic, Graphics[Point[points]], 
    PlotRange -> {{-3/4, 3/4}, {-0.3, 1.3}}] 

現在，我們定義一個函數，並使用ListPlot3D嘗試繪製。

f[x_, y_] := -(1 - Norm[{x - 1, y}]) (1 - Norm[{x + 1, y}])* 
    (1 - Norm[{x, y - Sqrt[3]}]); 
points3D = {#[[1]], #[[2]], f[#[[1]], #[[2]]]} & /@ points; 
pic = ListPlot3D[points3D, Mesh -> All] 

不知怎的，我們必須刪除的東西，處於區域之外。在這個特定的例子中，我們可以使用邊界上的函數爲零的事實。

DeleteCases[Normal[pic], Polygon[{ 
    {x1_, y1_, z1_?(Abs[#] < 1/10.0^6 &)}, 
    {x2_, y2_, z2_?(Abs[#] < 1/10.0^6 &)}, 
    {x3_, y3_, z3_?(Abs[#] < 1/10.0^6 &)}}, ___], 
    Infinity] 

還不錯，但也有一對夫婦的尖點附近的問題，它絕對不是非常普遍的，因爲它使用的功能的特定屬性。如果您檢查圖片的結構，您會發現它包含GraphicsComplex，並且該GraphicsComplex的第一個參數中的前n個點恰好是邊界。這裏是證明：

Most /@ pic[[1, 1, 1 ;; n]] == boundary 

現在的邊界有三種成分，我們要刪除由從這些組件的只是一個選擇點形成的任何三角形。以下代碼執行此操作。請注意，boundaryComponents包含那些形成邊界的點的索引，如果A是任何一個Bs的子集，則someSubsetQ [A，Bs]返回true。我們想要刪除多邊形中作爲boundaryComponents之一的子集的三角形索引。這是通過DeleteCases命令在以下代碼中完成的。

哦，我們來添加一些裝飾吧。

subsetQ[A_, B_] := Complement[A, B] == {}; 
someSubsetQ[A_, Bs_] := Or @@ Map[subsetQ[A, #] &, Bs]; 
boundaryComponents = Partition[Prepend[Range[n], n], 1 + n/3, n/3]; 
Show[pic /. Polygon[triangles_] :> {EdgeForm[Opacity[0.3]], 
    Polygon[DeleteCases[triangles, _?(someSubsetQ[#, boundaryComponents] &)]]}, 
Graphics3D[{Thick, Line[Table[Append[pt, 0], 
    {pt, Prepend[boundary, Last[boundary]]}]]}]] 

Answer 2

這可能不是最佳解決方案，所以如果有人有更好的主意，我會保持開放。

這是我如何解決我在我的問題中描述的問題。首先，我用data代替點{x,y,f[x,y]}，其中​​由{x,y,None}複雜。然後下面的函數從我的數據點中創建一個3D表面。這裏注意，data是

data = Table[{x,y,f[x,y]},{x,x0,x1,dx},{y,y0,y1,dy}] 

的結果是，沒有平坦（這適用於以下幾種功能更好）。功能是：

makeSurface[data_] := Module[{len1, len2, polys, a, b, c, d, p}, 
    len1 = Length[data]; 
    len2 = Length[data[[1]]]; 
    polys = Table[ 
    a = data[[i, j]]; 
    b = data[[i + 1, j]]; 
    c = data[[i + 1, j + 1]]; 
    d = data[[i, j + 1]]; 
    p = Select[{a, b, c, d}, #[[3]] =!= None &]; 
    If[Length[p] >= 2, Polygon[p], None], 
    {i, 1, len1 - 1}, {j, 1, len2 - 1}]; 
    Graphics3D[Join[{EdgeForm[None],FaceForm[Directive[GrayLevel[0.5]]]}, 
    Select[Flatten[polys, 1], # =!= None &]]]] 

上面的代碼可能可能被優化，但它對我來說足夠好用了。