Skip to main content

plotting - Plot more points only in specific region of plot


I have the code shown at the bottom of this question which generates a 3D plot. There are locations where the two surfaces you see form cones and touch at infinitesimally small points. These points always occur at z=1 and I have to use many PlotPoints to resolve this touching.


I will be generating thousands of these plots (to form a movie) so need to plot each one as quickly as possible. I would imagine a lot of time would be saved if I used a large number of points only in the regions of interest. Is there a way I can use a large PlotPoints density in a rectangular box that spans the x and y domain but has a small height and is vertically centred around z=1 where I know these points occur (but I don't know their x or y)?




(*The lattice vectors*)
a1 = {Sqrt[3], 0};
a2 = {Sqrt[3]/2, 3/2};

(*Omega/w_0*)
Omega = 0.01;

wp[qx_, qy_, r_] := Module[{},
  q = {qx, qy};


  (*Nearest neighbour vectors*)
  {d1, d2, d3} = # - r & /@ {{0, -1}, {Sqrt[3]/2, 1/2}, {-Sqrt[3]/2, 1/2}};

  (*The c_j's*)
  {theta, phi} = {0, 0};
  {c1, c2, c3} = (1 - 3 Sin[theta]^2 Cos[ArcTan[#[[1]], #[[2]]] - phi + Pi/2]^2)/
      Norm[#]^3 & /@ {d1, d2, d3};

  modfq = 

   Sqrt[c1^2 + c2^2 + c3^2 + 2 c1 c2 Cos[q.(d1 - d2)] + 
     2 c1 c3 Cos[q.(d1 - d3)] +  2 c2 c3 Cos[q.(d2 - d3)]];
  {Sqrt[1 + 2 Omega modfq], Sqrt[1 - 2 Omega modfq]}
  ]

r = {0, 0};

Timing[
 With[{plotopts = {Mesh -> None, PlotStyle -> Opacity[0.7], 
     Ticks -> {{-Pi, 0, Pi}, {-Pi, 0, Pi}, Automatic}, 

     PlotPoints -> 100, ViewPoint -> {1.43, -2.84, 1.13}, 
     ViewVertical -> {0., 0., 1.}}},
  plot1 = 
   Plot3D[wp[qx, qy, r][[1]], {qx, -Pi, Pi}, {qy, -Pi, Pi}, plotopts];
  plot2 = 
   Plot3D[wp[qx, qy, r][[2]], {qx, -Pi, Pi}, {qy, -Pi, Pi}, plotopts];
  ]
 ]
plot = 
 Show[plot1, plot2, PlotRange -> {0.96, 1.04}, 

  Ticks -> {{-Pi, 0, Pi}, {-Pi, 0, Pi}}, LabelStyle -> Medium, 
  BoxRatios -> {2, 2, 3}, BoxStyle -> Opacity[0.4]]

Note: This question could be a duplicate of here, but from what I gathered it was about feeding it a list of points rather than a region? I could be wrong.



Answer



Unfortunately the recursion algorithm fails to increase points near the Dirac points (actually, with a narrow band gap). It seems that it is because $\partial f(x,y)/\partial x,\ \partial f(x,y)/\partial y \ll 1$. However you can scale your function, scale back with a post-processing and obtain a nice plot!


scale = 1000;
postProcess[g_] := 
  g /. GraphicsComplex[pts_, opts___] :> 
     GraphicsComplex[(pts\[Transpose]/{1, 1, scale})\[Transpose], 

      opts] /. (VertexNormals -> 
      n_) :> (VertexNormals -> (n\[Transpose] {1, 1, 
          scale})\[Transpose]);
Timing[With[{plotopts = {Mesh -> None, PlotStyle -> Opacity[0.7], 
     Ticks -> {{-Pi, 0, Pi}, {-Pi, 0, Pi}, Automatic}, 
     PlotPoints -> 10, MaxRecursion -> 4, 
     ViewPoint -> {1.43, -2.84, 1.13}, 
     ViewVertical -> {0., 0., 1.}}},
  plot1 = 
   Plot3D[(wp[qx, qy, r][[1]]) scale, {qx, -Pi, Pi}, {qy, -Pi, Pi}, 

     plotopts] // postProcess;
  plot2 = 
   Plot3D[(wp[qx, qy, r][[2]]) scale, {qx, -Pi, Pi}, {qy, -Pi, Pi}, 
     plotopts] // postProcess;]]
plot = Show[plot1, plot2, PlotRange -> {0.96, 1.04}, 
  Ticks -> {{-Pi, 0, Pi}, {-Pi, 0, Pi}}, LabelStyle -> Medium, 
  BoxRatios -> {2, 2, 3}, BoxStyle -> Opacity[0.4]]

enter image description here


You can see a fine mesh near the Dirac points:



enter image description here


Now you can obtain a considerable speedup by tuning PlotPloits and MaxRecursion.


Comments

Post a Comment

Popular posts from this blog

mathematical optimization - Minimizing using indices, error: Part::pkspec1: The expression cannot be used as a part specification

I want to use Minimize where the variables to minimize are indices pointing into an array. Here a MWE that hopefully shows what my problem is. vars = u@# & /@ Range[3]; cons = Flatten@ { Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; Minimize[{Total@((vec1[[#]] - vec2[[u[#]]])^2 & /@ Range[1, 3]), cons}, vars, Integers] The error I get: Part::pkspec1: The expression u[1] cannot be used as a part specification. >> Answer Ok, it seems that one can get around Mathematica trying to evaluate vec2[[u[1]]] too early by using the function Indexed[vec2,u[1]] . The working MWE would then look like the following: vars = u@# & /@ Range[3]; cons = Flatten@{ Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; NMinimize[ {Total@((vec1[[#]] - Indexed[vec2, u[#]])^2 & /@ R...
Post a Comment
Read more

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more

What is and isn't a valid variable specification for Manipulate?

I have an expression whose terms have arguments (representing subscripts), like this: myExpr = A[0] + V[1,T] I would like to put it inside a Manipulate to see its value as I move around the parameters. (The goal is eventually to plot it wrt one of the variables inside.) However, Mathematica complains when I set V[1,T] as a manipulated variable: Manipulate[Evaluate[myExpr], {A[0], 0, 1}, {V[1, T], 0, 1}] (*Manipulate::vsform: Manipulate argument {V[1,T],0,1} does not have the correct form for a variable specification. >> *) As a workaround, if I get rid of the symbol T inside the argument, it works fine: Manipulate[ Evaluate[myExpr /. T -> 15], {A[0], 0, 1}, {V[1, 15], 0, 1}] Why this behavior? Can anyone point me to the documentation that says what counts as a valid variable? And is there a way to get Manpiulate to accept an expression with a symbolic argument as a variable? Investigations I've done so far: I tried using variableQ from this answer , but it says V[1...
Post a Comment
Read more