Можно ли создать полярный CountourPlot/ListCountourPlot/DensityPlot в Mathematica?

Я хочу нарисовать что-то вроде режимов шепчущей галереи - двумерный цилиндрически симметричный график в полярных координатах. Что-то вроде этого:

Я нашел следующий фрагмент кода в путеводителе по символике Тротта. Пробовал работать с очень маленьким набором данных; он съел 4 ГБ памяти и запустил мое ядро:

(* add points to get smooth curves *)
addPoints[lp_][points_, \[Delta]\[CurlyEpsilon]_] := 
Module[{n, l}, Join @@ (Function[pair,
       If[(* additional points needed? *)
          (l = Sqrt[#. #]&[Subtract @@ pair]) < \[Delta]\[CurlyEpsilon], pair, 
          n = Floor[l/\[Delta]\[CurlyEpsilon]] + 1; 
          Table[# + i/n (#2 - #1), {i, 0, n - 1}]& @@ pair]] /@ 
          Partition[If[lp === Polygon, 
                       Append[#, First[#]], #]&[points], 2, 1])]

(* Make the plot circular *)
With[{\[Delta]\[CurlyEpsilon] = 0.1, R = 10}, 
 Show[{gr /. (lp : (Polygon | Line))[l_] :> 
     lp[{#2 Cos[#1], #2 Sin[#1]} & @@@(* add points *)
       addPoints[lp][l, \[Delta]\[CurlyEpsilon]]], 
   Graphics[{Thickness[0.01], GrayLevel[0], Circle[{0, 0}, R]}]}, 
  DisplayFunction -> $DisplayFunction, Frame -> False]]

Здесь gr представляет собой прямоугольный 2D ListContourPlot, созданный с использованием чего-то вроде этого (например):

data = With[{eth = 2, er = 2, wc = 1, m = 4}, 
   Table[Re[
     BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[
       I m phi]], {r, 0, 10, .2}, {phi, 0, 2 Pi, 0.1}]];
gr = ListContourPlot[data, Contours -> 50, ContourLines -> False, 
  DataRange -> {{0, 2 Pi}, {0, 10}}, DisplayFunction -> Identity, 
  ContourStyle -> {Thickness[0.002]}, PlotRange -> All, 
  ColorFunctionScaling -> False]

Есть ли простой способ делать такие цилиндрические графики?.. Мне трудно поверить, что мне придется обратиться к Matlab для моих криволинейных координат:)

Ответ 1

Предыдущие фрагменты удалены, так как это, безусловно, лучший ответ, который я придумал:

With[{eth = 2, er = 2, wc = 1, m = 4}, 
 ContourPlot[
  Re[BesselJ[(Sqrt[eth] m)/Sqrt[er], Sqrt[eth] r wc] Exp[I phi m]]/. 
                                         {r ->Norm[{x, y}], phi ->ArcTan[x, y]}, 
  {x, -10, 10}, {y, -10, 10}, 
  Contours -> 50, ContourLines -> False, 
  RegionFunction -> (#1^2 + #2^2 < 100 &), 
  ColorFunction -> "SunsetColors"
 ]
]

Edit

Замена ContourPlot на Plot3D и удаление неподдерживаемых параметров:

Ответ 2

Это относительно простая проблема. Ключ в том, что если вы можете параметризовать его, вы можете построить его. В соответствии с документацией ListContourPlot и ListDensityPlot принимать данные в двух формах: массив значений высоты или список координат плюс значение функции ({{x, y, f} ..}). Вторая форма легче справиться, так что даже если ваши данные находятся в первой форме, мы преобразуем ее во вторую форму.

Просто, чтобы преобразовать данные формы {{r, t, f} ..} в данные формы {{x, y, f} ..}, вы делаете N[{#[[1]] Cos[ #[[2]] ], #[[1]] Sin[ #[[2]] ], #[[3]]}]& /@ data, когда применяется к данным, взятым из BesselJ[1, r/2] Cos[3 t], вы получаете

Как насчет того, когда у вас есть только массив данных, например этот парень? В этом случае у вас есть 2D-массив, в котором каждая точка в массиве имеет известное местоположение, и для его построения вам нужно превратить его во вторую форму. Я неравнодушен к MapIndexed, но есть и другие способы сделать это. Скажем, ваши данные хранятся в массиве, где строки соответствуют радиальной координате, а столбцы - это координата angular. Затем, чтобы преобразовать его, я использовал бы

R = 0.01;    (*radial increment*)
T = 0.05 Pi; (*angular increment*)
xformed = MapIndexed[ 
   With[{r = #2[[1]]*R, t = #2[[1]]*t, f = #1},
   {r Cos[t], r Sin[t], f}]&, data, {2}]//Flatten[#,1]&

который дает тот же результат.

Если у вас есть аналитическое решение, вам нужно преобразовать его в декартовы координаты, как указано выше, но вместо этого вы используете правила замены. Например,

ContourPlot[ Evaluate[
    BesselJ[1, r/2]*Cos[3 t ] /. {r -> Sqrt[x^2 + y^2], t -> ArcTan[x, y]}], 
   {x, -5, 5}, {y, -5, 5}, PlotPoints -> 50, 
   ColorFunction -> ColorData["DarkRainbow"], Contours -> 25]

дает

Следует отметить две вещи: 1) Evaluate необходим, чтобы гарантировать, что замена выполнена правильно, и 2) ArcTan[x, y] учитывает квадрант, в котором находится точка {x,y}.