tips for creating Graph diagrams - wolfram-mathematica

I'd like to programmatically create diagrams like this
(source: yaroslavvb.com)
I imagine I should use GraphPlot with VertexCoordinateRules, VertexRenderingFunction and EdgeRenderingFunction for the graphs. What should I use for colored beveled backgrounds?
Edit
Using mainly Simon's ideas, here's a simplified "less robust" version I ended up using
Needs["GraphUtilities`"];
GraphPlotHighlight[edges_, verts_, color_] := Module[{},
vpos = Position[VertexList[edges], Alternatives ## verts];
coords = Extract[GraphCoordinates[edges], vpos];
(* add .002 because end-cap disappears when segments are almost colinear *)
AppendTo[coords, First[coords] + .002];
Show[Graphics[{color, CapForm["Round"], JoinForm["Round"],
Thickness[.2], Line[coords], Polygon[coords]}],
GraphPlot[edges], ImageSize -> 150]
]
SetOptions[GraphPlot,
VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .15],
Black, Text[#2, #1]} &),
EdgeRenderingFunction -> ({Black, Line[#]} &)];
edges = GraphData[{"Grid", {3, 3}}, "EdgeRules"];
colors = {LightBlue, LightGreen, LightRed, LightMagenta};
vsets = {{8, 5, 2}, {7, 5, 8}, {9, 6, 3}, {8, 1, 2}};
MapThread[GraphPlotHighlight[edges, #1, #2] &, {vsets, colors}]
(source: yaroslavvb.com)

Generalising Samsdram's answer a bit, I get
GraphPlotHighlight[edges:{((_->_)|{_->_,_})..},hl:{___}:{},opts:OptionsPattern[]]:=Module[{verts,coords,g,sub},
verts=Flatten[edges/.Rule->List]//.{a___,b_,c___,b_,d___}:>{a,b,c,d};
g=GraphPlot[edges,FilterRules[{opts}, Options[GraphPlot]]];
coords=VertexCoordinateRules/.Cases[g,HoldPattern[VertexCoordinateRules->_],2];
sub=Flatten[Position[verts,_?(MemberQ[hl,#]&)]];
coords=coords[[sub]];
Show[Graphics[{OptionValue[HighlightColor],CapForm["Round"],JoinForm["Round"],Thickness[OptionValue[HighlightThickness]],Line[AppendTo[coords,First[coords]]],Polygon[coords]}],g]
]
Protect[HighlightColor,HighlightThickness];
Options[GraphPlotHighlight]=Join[Options[GraphPlot],{HighlightColor->LightBlue,HighlightThickness->.15}];
Some of the code above could be made a little more robust, but it works:
GraphPlotHighlight[{b->c,a->b,c->a,e->c},{b,c,e},VertexLabeling->True,HighlightColor->LightRed,HighlightThickness->.1,VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .06],
Black, Text[#2, #1]} &)]
EDIT #1:
A cleaned up version of this code can be found at http://gist.github.com/663438
EDIT #2:
As discussed in the comments below, the pattern that my edges must match is a list of edge rules with optional labels. This is slightly less general than what is used by the GraphPlot function (and by the version in the above gist) where the edge rules are also allowed to be wrapped in a Tooltip.
To find the exact pattern used by GraphPlot I repeatedly used Unprotect[fn];ClearAttributes[fn,ReadProtected];Information[fn] where fn is the object of interest until I found that it used the following (cleaned up) function:
Network`GraphPlot`RuleListGraphQ[x_] :=
ListQ[x] && Length[x] > 0 &&
And##Map[Head[#1] === Rule
|| (ListQ[#1] && Length[#1] == 2 && Head[#1[[1]]] === Rule)
|| (Head[#1] === Tooltip && Length[#1] == 2 && Head[#1[[1]]] === Rule)&,
x, {1}]
I think that my edges:{((_ -> _) | (List|Tooltip)[_ -> _, _])..} pattern is equivalent and more concise...

For simple examples where you are only connecting two nodes (like your example on the far right), you can draw lines with capped end points like this.
vertices = {a, b};
Coordinates = {{0, 0}, {1, 1}};
GraphPlot[{a -> b}, VertexLabeling -> True,
VertexCoordinateRules ->
MapThread[#1 -> #2 &, {vertices, Coordinates}],
Prolog -> {Blue, CapForm["Round"], Thickness[.1], Line[Coordinates]}]
For more complex examples (like second from the right) I would recommend drawing a polygon using the vertex coordinates and then tracing the edge of the polygon with a capped line. I couldn't find a way to add a beveled edge directly to a polygon. When tracing the perimeter of the polygon you need to add the coordinate of the first vertex to the end of the line segment that the line makes the complete perimeter of the polygon. Also, there are two separate graphics directives for lines CapForm, which dictates whether to bevel the ends of the line, and JoinForm, which dictates whether to bevel the intermediate points of the line.
vertices = {a, b, c};
Coordinates = {{0, 0}, {1, 1}, {1, -1}};
GraphPlot[{a -> b, b -> c, c -> a}, VertexLabeling -> True,
VertexCoordinateRules ->
MapThread[#1 -> #2 &, {vertices, Coordinates}],
Prolog -> {Blue, CapForm["Round"], JoinForm["Round"], Thickness[.15],
Line[AppendTo[Coordinates, First[Coordinates]]],
Polygon[Coordinates]}]

JoinForm["Round"] will round the joins of line segments.
You'll want a filled polygon around the centers of the vertices in the colored region, then a JoinForm["Round"], ..., Line[{...}] to get the rounded corners.
Consider
foo = GraphPlot[{a -> b, a -> c, b -> d, b -> e, b -> f, c -> e, e -> f},
VertexRenderingFunction ->
({White, EdgeForm[Black], Disk[#, .1], Black, Text[#2, #1]} &)]
Show[
Graphics[{
RGBColor[0.6, 0.8, 1, 1],
Polygon[foo[[1, 1, 1, 1, 1, {2, 5, 6, 2}]]],
JoinForm["Round"], Thickness[0.2],
Line[foo[[1, 1, 1, 1, 1, {2, 5, 6, 2}]]]
}],
foo
]
where foo[[1,1,1,1,1]] is the list of vertex centers and {2,5,6} pulls out the {b,e,f} vertices. ({2,5,6,2} closes the line back at its starting point.)
There's plenty of room for prettifying, but I think this covers the ingredient you didn't mention above.

Related

How to get array of deleted walls from maze generation code Mathematica

I am trying to get out an array of all the deleted walls from this maze generation code. Can't seem to make it work, when I ask it to print it will only give me the entire maze grid, and not the specific walls I'm asking for.
MazeGen2[m_, n_] :=
Block[{$RecursionLimit = Infinity,
unvisited = Tuples[Range /# {m, n}], maze, mazearray = {},
mazeA},
(*unvisited=Delete[unvisited,{{1},{2},{Length[
unvisited]-1},{Length[unvisited]}}];*)
(*Print[unvisited];*)
maze = {{{{#, # - {0, 1}}, {#, # - {1, 0}}}} & /#
unvisited, {{{0, n - 1}, {0, 0}, {m - 1,
0}}}};(*This generates the grid*)
Print[maze];
{unvisited = DeleteCases[unvisited, #];
(*Print[unvisited];*)
Do[
If[MemberQ[unvisited, neighbor],
maze = DeleteCases[
maze, {#, neighbor - {1, 1}} | {neighbor, # - {1, 1}}, {5}]
(*mazeA=Flatten[AppendTo[mazearray,
maze]];*)
; #0#neighbor],
{neighbor,
RandomSample#{# + {0, 1}, # - {0, 1}, # + {1, 0}, # - {1,
0}}}
]
} &#RandomChoice#unvisited;
Flatten[maze]
];
I tracked down your code to the Rosetta Code site, and - by way of thanks for that! - here's how to use the graph-based alternative for maze generation. This is courtesy of user AlephAlpha:
MazeGraph[m_, n_] :=
Block[{$RecursionLimit = Infinity, grid = GridGraph[{m, n}],
visited = {}},
Graph[Range[m n],
Reap[{AppendTo[visited, #];
Do[
If[FreeQ[visited, neighbor],
Sow[# <-> neighbor]; #0#neighbor],
{neighbor, RandomSample#AdjacencyList[grid, #]}]} & #
RandomChoice#VertexList#grid][[2, 1]],
GraphLayout -> {"GridEmbedding", "Dimension" -> {m, n}},
EdgeStyle -> Directive[Opacity[1], AbsoluteThickness[12], Purple],
VertexShapeFunction -> None,
VertexLabels -> "Name",
VertexLabelStyle -> White,
Background -> LightGray,
ImageSize -> 300]];
width = height = 8;
maze = MazeGraph[width, height]
Solutions are easy now that the maze is a graph:
path = FindShortestPath[maze, 1, Last[VertexList[maze]]];
solution = Show[
maze,
HighlightGraph[
maze,
PathGraph[path],
EdgeStyle -> Directive[AbsoluteThickness[5], White],
GraphHighlightStyle -> None]
];
and also easy is to find the deleted walls - here, it's the GraphDifference between the original GridGraph and the maze:
hg = HighlightGraph[
GridGraph[{width, height},
EdgeStyle ->
Directive[Opacity[0.2], Blue, AbsoluteThickness[1]]],
EdgeList[GraphDifference[GridGraph[{width, height}], maze]],
Background -> LightGray,
ImageSize -> 300,
GraphHighlightStyle -> {"Thick"}];
Showing all three:
Row[{Labeled[maze, "maze"], Spacer[12], Labeled[hg, "deleted walls"],
Labeled[solution, "solution"]}]
Apologies for the styling issues - this is the hard part of using graphs... :)

Modifying a Graphics3D object generated by ParametricPlot3D

Here is a set of structured 3D points. Now we can form a BSpline using these points as knots.
dat=Import["3DFoil.mat", "Data"]
fu=BSplineFunction[dat]
Here we can do a ParametricPlot3D with these points.
pic=ParametricPlot3D[fu[u,v],{u, 0, 1}, {v, 0, 1}, Mesh -> All, AspectRatio ->
Automatic,PlotPoints->10,Boxed-> False,Axes-> False]
Question
If we carefully look at the 3D geometry coming out of the spline we can see that it is a hollow structure. This hole appears in both side of the symmetric profile. How can we perfectly (not visually!) fill up this hole and create a unified Graphics3D object where holes in both sides are patched.
What I am able to get so far is the following. Holes are not fully patched.
I am asking too many questions recently and I am sorry for that. But if any of you get interested I hope you will help.
Update
Here is the problem with belisarius method.
It generates triangles with almost negligible areas.
dat = Import[NotebookDirectory[] <> "/3DFoil.mat", "Data"];
(*With your points in "dat"*)
fd = First#Dimensions#dat;
check = ParametricPlot3D[{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}][u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]}, {u, 0,
1}, {v, 0, 1}, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
output is here
Export[NotebookDirectory[]<>"myres.obj",check];
cd=Import[NotebookDirectory[]<>"myres.obj"];
middle=
check[[1]][[2]][[1]][[1(* Here are the numbers of different Graphics group*)]][[2,1,1,1]];
sidePatch1=check[[1]][[2]][[1]][[2]][[2,1,1,1]];
sidePatch2=check[[1]][[2]][[1]][[3]][[2,1,1,1]];
There are three Graphics groups rest are empty. Now lets see the area of the triangles in those groups.
polygonArea[pts_List?
(Length[#]==3&)]:=Norm[Cross[pts[[2]]-pts[[1]],pts[[3]]-pts[[1]]]]/2
TriangleMaker[{a_,b_,c_}]:={vertices[[a]],vertices[[b]],vertices[[c]]}
tring=Map[polygonArea[TriangleMaker[#]]&,middle];
tring//Min
For the middle large group output is
0.000228007
This is therefore a permissible triangulation. But for the side patches we get zero areas.
Map[polygonArea[TriangleMaker[#]] &, sidePatch1] // Min
Map[polygonArea[TriangleMaker[#]] &, sidePatch2] // Min
Any way out here belisarius ?
My partial solution
First download the package for simplifying complex polygon from Wolfram archive.
fu = BSplineFunction[dat];
pic =(*ParametricPlot3D[fu[u,v],{u,0,1},{v,0,1},Mesh->None,
AspectRatio->Automatic,PlotPoints->25,Boxed->False,Axes->False,
BoundaryStyle->Red]*)
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Black];
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity];
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1];
nf = Nearest[bound -> Automatic]; {a1, a2} =
Union#Flatten#(nf /# corners);
sets = {bound[[2 ;; a1]], bound[[a1 ;; a2]],bound[[a2 ;; a2 + a1]]};
CorrectOneNodeNumber = Polygon[sets[[{1, 3}]]][[1]][[1]] // Length;
CorrectOneNodes1 =
Polygon[sets[[{1, 3}]]][[1]][[1]]; CorrectOneNodes2 =
Take[Polygon[sets[[{1, 3}]]][[1]][[2]], CorrectOneNodeNumber];
<< PolygonTriangulation`SimplePolygonTriangulation`
ver1 = CorrectOneNodes1;
ver2 = CorrectOneNodes2;
triang1 = SimplePolygonTriangulation3D[ver1];
triang2 = SimplePolygonTriangulation3D[ver2];
Show[Graphics3D[{PointSize[Large], Point[CorrectOneNodes1]},Boxed -> False,
BoxRatios -> 1], Graphics3D[{PointSize[Large], Point[CorrectOneNodes2]},
Boxed -> False, BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver1, Polygon[triang1]], Boxed -> False,
BoxRatios -> 1],
Graphics3D[GraphicsComplex[ver2, Polygon[triang2]], Boxed -> False,
BoxRatios -> 1]]
We get nice triangles here.
picfin=ParametricPlot3D[fu[u,v],{u,0,1}, {v,0,1},Mesh->All,AspectRatio->Automatic,PlotPoints->10,Boxed->False,Axes->False,BoundaryStyle->None];pic3D=Show[Graphics3D[GraphicsComplex[ver1,Polygon[triang1]]],picfin,Graphics3D[GraphicsComplex[ver2,Polygon[triang2]]],Boxed->False,Axes->False]
Now this has just one problem. Here irrespective of the PlotPoints there are four triangles always appearing that just shares only one edge with any other neighboring triangle. But we expect all of the triangles to share at least two edges with other trangles. That happens if we use belisarius method. But it creates too small triangles that my panel solver rejects as tingles with zero area.
One can check here the problem of my method. Here we will use the method from the solution by Sjoerd.
Export[NotebookDirectory[]<>"myres.obj",pic3D];
cd=Import[NotebookDirectory[]<>"myres.obj"];
polygons=(cd[[1]][[2]]/.GraphicsComplex-> List)[[2]][[1]][[1,1]];
pt=(cd[[1]][[2]]/.GraphicsComplex-> List)[[1]];
vertices=pt;
(*Split every triangle in 3 edges,with nodes in each edge sorted*)
triangleEdges=(Sort/#Subsets[#,{2}])&/#polygons;
(*Generate a list of edges*)
singleEdges=Union[Flatten[triangleEdges,1]];
(*Define a function which,given an edge (node number list),returns the bordering*)
(*triangle numbers.It's done by working through each of the triangles' edges*)
ClearAll[edgesNeighbors]
edgesNeighbors[_]={};
MapIndexed[(edgesNeighbors[#1[[1]]]=Flatten[{edgesNeighbors[#1[[1]]],#2[[1]]}];
edgesNeighbors[#1[[2]]]=Flatten[{edgesNeighbors[#1[[2]]],#2[[1]]}];
edgesNeighbors[#1[[3]]]=Flatten[{edgesNeighbors[#1[[3]]],#2[[1]]}];)&,triangleEdges];
(*Build a triangle relation table.Each'1' indicates a triangle relation*)
relations=ConstantArray[0,{triangleEdges//Length,triangleEdges//Length}];
Scan[(n=edgesNeighbors[##];
If[Length[n]==2,{n1,n2}=n;
relations[[n1,n2]]=1;relations[[n2,n1]]=1];)&,singleEdges]
(*Build a neighborhood list*)
triangleNeigbours=Table[Flatten[Position[relations[[i]],1]],{i,triangleEdges//Length}];
trires=Table[Flatten[{polygons[[i]],triangleNeigbours[[i]]}],{i,1,Length#polygons}];
Cases[Cases[trires,x_:>Length[x]],4]
Output shows always there are four triangles that shares only one edges with others.
{4,4,4,4}
In case of belisarius method we don't see this happening but there we get triangles with numerically zero areas.
BR
Import the data and construct the BSpline function as before:
dat = Import["Downloads/3DFoil.mat", "Data"];
fu = BSplineFunction[dat]
Generate the surface, making sure to include (only) the boundary line, which will follow the edge of the surface. Make sure to set Mesh to either All or None.
pic = ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Red]
Extract the points from the boundary line:
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity]
Find the "corners", based on your parameter space:
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1]
Find the edge points best corresponding to the corners, keeping in mind that ParametricPlot3D doesn't use the limits exactly, so we can't just use Position:
nf = Nearest[bound -> Automatic];
nf /# corners
Figure our which range of points on the boundary correspond to the areas you need to fill up. This step involved some manual inspection.
sets = {bound[[2 ;; 22]], bound[[22 ;; 52]], bound[[52 ;; 72]],
bound[[72 ;;]]}
Construct new polygons corresponding to the holes:
Graphics3D[Polygon[sets[[{1, 3}]]], Boxed -> False, BoxRatios -> 1]
Show[pic, Graphics3D[Polygon[sets[[{1, 3}]]]]]
Note that there is probably still a hole that can't be seen where the edge runs between the holes you mentioned, and I haven't tried to fill it in, but you should have enough information to do that if needed.
Your data set looks like this:
Graphics3D[Point#Flatten[dat, 1]]
It consists of 22 sections of 50 points.
Adding a mid-line in each end section (which is actually the end section flattened):
dat2 = Append[Prepend[dat,
Table[(dat[[1, i]] + dat[[1, -i]])/2, {i, Length[dat[[1]]]}]
],
Table[(dat[[-1, i]] + dat[[-1, -i]])/2, {i, Length[dat[[-1]]]}]
];
Graphics3D[{Point#Flatten[dat, 1], Red, Point#dat2[[1]], Green, Point#dat2[[-1]]}]
Now add some weights to the wingtip rim:
sw = Table[1, {24}, {50}];
sw[[2]] = 1000 sw[[1]];
sw[[-2]] = 1000 sw[[1]];
fu = BSplineFunction[dat2, SplineWeights -> sw];
Show[
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> All,
AspectRatio -> Automatic, PlotPoints -> 20, Boxed -> False,
Axes -> False, Lighting -> "Neutral"
],
Graphics3D[{PointSize -> 0.025, Green, Point#dat2[[-1]], Red,Point#dat2[[-2]]}]
]
Note that I increased the PlotPoints value to 20.
(*With your points in "dat"*)
fu = BSplineFunction[dat[[1 ;; 2]]];
Show[{ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic, PlotPoints -> 30],
ListPlot3D[dat[[1]]]}]
And with
InputForm[%]
you get the "unified" graphics object.
Edit
Another way, probably better:
(*With your points in "dat"*)
fu = BSplineFunction[dat];
Show[
{ ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False],
ParametricPlot3D[
BSplineFunction[{First#dat, Reverse#First#dat}][u, v], {u, 0, 1}, {v, 0, 1},
Mesh -> None, PlotStyle -> Yellow],
ParametricPlot3D[
BSplineFunction[{dat[[First#Dimensions#dat]],
Reverse#dat[[First#Dimensions#dat]]}]
[u, v], {u, 0, 1}, {v, 0, 1}]}]
In just one structure:
(*With your points in "dat"*)
fd = First#Dimensions#dat;
ParametricPlot3D[
{BSplineFunction[dat][u, v],
BSplineFunction[{dat[[1]], Reverse#dat[[1]]}] [u, v],
BSplineFunction[{dat[[fd]], Reverse#dat[[fd]]}][u, v]},
{u, 0, 1}, {v, 0, 1},
Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False]
Edit
You can check that there are small triangles, but they are triangles indeed and not zero area polygons:
fu = BSplineFunction[dat];
check = ParametricPlot3D[{BSplineFunction[{First#dat, Reverse#dat[[1]]}][u, v]},
{u, 0, 1}, {v, 0, 1}, Mesh -> All,
PlotStyle -> Yellow, Mesh -> All, AspectRatio -> Automatic,
PlotPoints -> 10, Boxed -> False, Axes -> False];
pts = check /. Graphics3D[GraphicsComplex[a_, b__], ___] -> a;
m = check[[1]][[2]][[1]][[1]] /. {___, GraphicsGroup[{Polygon[a_]}]} -> a;
t = Replace[m, {a_, b_, c_} -> {pts[[a]], pts[[b]], pts[[c]]}, {1}];
polygonArea[pts_List?(Length[#] == 3 &)] :=
Norm[Cross[pts[[2]] - pts[[1]], pts[[3]] - pts[[1]]]]/2;
t[[Position[Ordering[polygonArea /# t], 1][[1]]]]
(*
->{{{-4.93236, 0.0989696, -2.91748},
{-4.92674, 0.0990546, -2.91748},
{-4.93456, 0.100181, -2.91748}}}
*)

How to choose the numbers shown on the axes of a plot in mathemetica?

I have already checked all the examples and settings in the Mathematica documentation center, but couldn't find any example on how to choose the numbers that will be shown on the axes.
How do I change plot axis numbering like 2,4,6,.. to PI,2PI,3PI,...?
Howard has already given the correct answer in the case where you want the labels Pi, 2 Pi etc to be at the values Pi, 2 Pi etc.
Sometimes you might want to use substitute tick labels at particular values, without rescaling data.
One of the other examples in the documentation shows how:
Plot[Sin[x], {x, 0, 10},
Ticks -> {{{Pi, 180 \[Degree]}, {2 Pi, 360 \[Degree]}, {3 Pi,
540 \[Degree]}}, {-1, 1}}]
I have a suite of small custom functions for formatting Ticks the way I want them. This is probably too much information if you are just starting out, but it is worth knowing that you can use any number format and substitute anything into your ticks if desired.
myTickGrid[min_, max_, seg_, units_String, len_?NumericQ,
opts : OptionsPattern[]] :=
With[{adj = OptionValue[UnitLabelShift], bls = OptionValue[BottomLabelShift]},
Table[{i,
If[i == max,
DisplayForm[AdjustmentBox[Style[units, LineSpacing -> {0, 12}],
BoxBaselineShift -> If[StringCount[units, "\n"] > 0, adj + 2, adj]]],
If[i == min,
DisplayForm#AdjustmentBox[Switch[i, _Integer,
NumberForm[i, DigitBlock -> 3,
NumberSeparator -> "\[ThinSpace]"], _, N[i]],
BoxBaselineShift -> bls],
Switch[i, _Integer, NumberForm[i, DigitBlock -> 3,
NumberSeparator -> "\[ThinSpace]"], _, N[i]]]], {len, 0}}, {i,
If[Head[seg] === List, Union[{min, max}, seg], Range[min, max, seg]]}]]
And setting:
Options[myTickGrid] = {UnitLabelShift -> 1.3, BottomLabelShift -> 0}
SetOptions[myTickGrid, UnitLabelShift -> 1.3, BottomLabelShift -> 0]
Example:
Plot[Erfc[x], {x, -2, 2}, Frame -> True,
FrameTicks -> {myTickGrid[-2, 2, 1, "x", 0.02, UnitLabelShift -> 0],
myTickGrid[0, 2, {0.25, .5, 1, 1.8}, "Erfc(x)", 0.02]}]
You can find an example here:
Ticks -> {{Pi, 2 Pi, 3 Pi}, {-1, 0, 1}}
Ticks also accepts a function, which will save you the trouble of listing the points manually or having to change the max value each time. Here's an example:
xTickFunc[min_, max_] :=
Table[{i, i, 0.02}, {i, Ceiling[min/Pi] Pi, Floor[max/Pi] Pi, Pi}]
Plot[Sinc[x], {x, -5 Pi, 5 Pi}, Ticks -> {xTickFunc, Automatic},
PlotRange -> All]
If you want more flexibility in customizing your ticks, you might want to look into LevelScheme.

Is it possible to create polar CountourPlot/ListCountourPlot/DensityPlot in Mathematica?

I am looking to plot something like the whispering gallery modes -- a 2D cylindrically symmetric plot in polar coordinates. Something like this:
I found the following code snippet in Trott's symbolics guidebook. Tried running it on a very small data set; it ate 4 GB of memory and hosed my kernel:
(* 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]]
Here, gr is a rectangular 2D ListContourPlot, generated using something like this (for example):
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]
Is there a straightforward way to do cylindrical plots like this?.. I find it hard to believe that I would have to turn to Matlab for my curvilinear coordinate needs :)
Previous snippets deleted, since this is clearly the best answer I came up with:
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
Replacing ContourPlot by Plot3D and removing the unsupported options you get:
This is a relatively straightforward problem. The key is that if you can parametrize it, you can plot it. According to the documentation both ListContourPlot and ListDensityPlot accept data in two forms: an array of height values or a list of coordinates plus function value ({{x, y, f} ..}). The second form is easier to deal with, such that even if your data is in the first form, we'll transform it into the second form.
Simply, to transform data of the form {{r, t, f} ..} into data of the form {{x, y, f} ..} you doN[{#[[1]] Cos[ #[[2]] ], #[[1]] Sin[ #[[2]] ], #[[3]]}]& /# data, when applied to data taken from BesselJ[1, r/2] Cos[3 t] you get
What about when you just have an array of data, like this guy? In that case, you have a 2D array where each point in the array has known location, and in order to plot it, you have to turn it into the second form. I'm partial to MapIndexed, but there are other ways of doing it. Let's say your data is stored in an array where the rows correspond to the radial coordinate and the columns are the angular coordinate. Then to transform it, I'd use
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]&
which gives the same result.
If you have an analytic solution, then you need to transform it to Cartesian coordinates, like above, but you use replacement rules, instead. For instance,
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]
gives
Two things to note: 1) Evaluate is needed to ensure that the replacement is performed correctly, and 2) ArcTan[x, y] takes into account the quadrant that the point {x,y} is found in.

VertexCoordinate Rules and VertexList from GraphPlot Graphic

Is there any way of abstracting the vertex order that GraphPlot applies to VertexCoordinate Rules from the (FullForm or InputForm) of the graphic produced by GraphPlot? I do not want to use the GraphUtilities function VertexList. I am also aware of GraphCoordinates, but both of these functions work with the graph, NOT the graphics output of GraphPlot.
For example,
gr1 = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5, 5 -> 6, 6 -> 1};
gp1 = GraphPlot[gr1, Method -> "CircularEmbedding",
VertexLabeling -> True];
Last#(gp1 /. Graphics[Annotation[x___], ___] :> {x})
gives the following list of six coordinate pairs:
VertexCoordinateRules -> {{2., 0.866025}, {1.5, 1.73205}, {0.5,
1.73205}, {0., 0.866025}, {0.5, 1.3469*10^-10}, {1.5, 0.}}
How do I know which rule applies to which vertex, and can I be certain that this is
the same as that given by VertexList[gr1]?
For example
Needs["GraphUtilities`"];
gr2 = SparseArray#
Map[# -> 1 &, EdgeList[{2 -> 3, 3 -> 4, 4 -> 5, 5 -> 6}]];
VertexList[gr2]
gives {1, 2, 3, 4, 5}
But ....
gp2 = GraphPlot[gr2, VertexLabeling -> True,
VertexCoordinateRules ->
Thread[VertexList[gr1] ->
Last#(gp1 /. Graphics[Annotation[x___], ___] :> {x})[[2]]]];
Last#(gp2 /. Graphics[Annotation[x___], ___] :> {x})
gives SIX coordinate sets:
VertexCoordinateRules -> {{2., 0.866025}, {1.5, 1.73205}, {0.5,
1.73205}, {0., 0.866025}, {0.5, 1.3469*10^-10}, {1.5, 0.}}
How can I abstract the correct VertexList for VertexCoordinateRules for gr2, for example?
(I am aware that I can correct things by taking the VertexList after generating gr2 as follows, for example)
VertexList#
SparseArray[
Map[# -> 1 &, EdgeList[{2 -> 3, 3 -> 4, 4 -> 5, 5 -> 6}]], {6, 6}]
{1, 2, 3, 4, 5, 6}
but the information I need appears to be present in the GraphPlot graphic: how can I obtain it?
(The reason I convert the graph to an adjacency matrix it that, as pointed out by Carl Woll of Wolfram, it allows me to include an 'orphan' node, as in gp2)
With vertex labeling, one way is to get coordinates of the labels. Notice that output of GraphPlot is in GraphicsComplex where coordinates of coordinate aliases are as first label, you can get it as
points = Cases[gp1, GraphicsComplex[points_, __] :> points, Infinity] // First
Looking at FullForm you'll see that labels are in text objects, extract them as
labels = Cases[gp1, Text[___], Infinity]
The actual label seems to be two levels deep so you get
actualLabels = labels[[All, 1, 1]];
Coordinate alias is the second parameter so you get them as
coordAliases = labels[[All, 2]]
Actual coordinates were specified in GraphicsComplex, so we get them as
actualCoords = points[[coordAliases]]
There a 1-1 correspondence between list of coordinates and list of labels, so you can use Thread to return them as list of "label"->coordinate pairs.
here's a function that this all together
getLabelCoordinateMap[gp1_] :=
Module[{points, labels, actualLabels, coordAliases, actualCoords},
points =
Cases[gp1, GraphicsComplex[points_, __] :> points, Infinity] //
First;
labels = Cases[gp1, Text[___], Infinity];
actualLabels = labels[[All, 1, 1]];
coordAliases = labels[[All, 2]];
actualCoords = points[[coordAliases]];
Thread[actualLabels -> actualCoords]
];
getLabelCoordinateMap[gp1]
Not that this only works on labelled GraphPlot. For ones without labels you could try to extract from other graphics objects, but you may get different results depending on what objects you extract the mapping from because there seems to be a bug which sometimes assigns line endpoints and vertex labels to different vertices. I've reported it. The way to work around the bug is to either always use explicit vertex->coordinate specification for VertexCoordinateList, or always use "adjacency matrix" representation. Here's an example of discrepancy
graphName = {"Grid", {3, 3}};
gp1 = GraphPlot[Rule ### GraphData[graphName, "EdgeIndices"],
VertexCoordinateRules -> GraphData[graphName, "VertexCoordinates"],
VertexLabeling -> True]
gp2 = GraphPlot[GraphData[graphName, "AdjacencyMatrix"],
VertexCoordinateRules -> GraphData[graphName, "VertexCoordinates"],
VertexLabeling -> True]
BTW, as an aside, here are the utility functions I use for converting between adjacency matrix and edge rule representation
edges2mat[edges_] := Module[{a, nodes, mat, n},
(* custom flatten to allow edges be lists *)
nodes = Sequence ### edges // Union // Sort;
nodeMap = (# -> (Position[nodes, #] // Flatten // First)) & /#
nodes;
n = Length[nodes];
mat = (({#1, #2} -> 1) & ### (edges /. nodeMap)) //
SparseArray[#, {n, n}] &
];
mat2edges[mat_List] := Rule ### Position[mat, 1];
mat2edges[mat_SparseArray] :=
Rule ### (ArrayRules[mat][[All, 1]] // Most)
If you execute FullForm[gp1] you'll get a bunch of output which I won't post here. Near the start of the output you'll find a GraphicsComplex[]. This is, essentially, a list of points and then a list of uses of those points. So, for your graphic gp1 the beginning of the GraphicsComplex is:
GraphicsComplex[
List[List[2., 0.866025], List[1.5, 1.73205], List[0.5, 1.73205],
List[0., 0.866025], List[0.5, 1.3469*10^-10], List[1.5, 0.]],
List[List[RGBColor[0.5, 0., 0.],
Line[List[List[1, 2], List[2, 3], List[3, 4], List[4, 5],
List[5, 6], List[6, 1]]]],
The first outermost list defines the positions of 6 points. The second outermost list defines a bunch of lines between those points, using the numbers of the points within the first list. It's probably easier to understand if you play around with this.
EDIT: In response to OP's comment, if I execute:
FullForm[GraphPlot[{3 -> 4, 4 -> 5, 5 -> 6, 6 -> 3}]]
I get
Graphics[Annotation[GraphicsComplex[List[List[0.`,0.9997532360813222`],
List[0.9993931236462025`,1.0258160108662504`],List[1.0286626995939243`,
0.026431169015735057`],List[0.02872413637035287`,0.`]],List[List[RGBColor[0.5`,0.`,0.`],
Line[List[List[1,2],List[2,3],List[3,4],List[4,1]]]],List[RGBColor[0,0,0.7`],
Tooltip[Point[1],3],Tooltip[Point[2],4],Tooltip[Point[3],5],Tooltip[Point[4],6]]],
List[]],Rule[VertexCoordinateRules,List[List[0.`,0.9997532360813222`],
List[0.9993931236462025`,1.0258160108662504`],
List[1.0286626995939243`,0.026431169015735057`],List[0.02872413637035287`,0.`]]]],
Rule[FrameTicks,None],Rule[PlotRange,All],Rule[PlotRangePadding,Scaled[0.1`]],
Rule[AspectRatio,Automatic]]
The list of vertex positions is the first list inside the GraphicsComplex. Later in the FullForm you can see the list where Mathematica adds tooltips to label the vertices with the identifiers you supplied in the original edge list. Since what you are now looking at is the code describing a graphic there's only an indirect relationship between your vertices and what will be plotted; the information is all there but not entirely straightforward to unpack.
p2 = Normal#gp1 // Cases[#, Line[points__] :> points, Infinity] &;
p3 = Flatten[p2, 1];
ListLinePlot[p3[[All, 1 ;; 2]]]
V12.0.0

Resources