How to Label Graph Edges with their weights - wolfram-mathematica

Warning! I posted the question when Mathematica v 8.0 was the coolest kid. The bug has been solved as of version 9.0.1
The help for EdgeLabels states:
However:
CompleteGraph[4,
EdgeWeight -> Range#6,
VertexShapeFunction -> "Name",
EdgeLabels -> "EdgeWeight"]
Results in:
So, no Edge Labels ... I guess it is a bug.
I used a nasty construct like:
adj = {{\[Infinity], 1, 1, 1, 1}, {1, \[Infinity], 2, 2, 2},
{1, 2, \[Infinity], 2, 2}, {1, 2, 2, \[Infinity], 2},
{1, 2, 2, 2, \[Infinity]}};
WeightedAdjacencyGraph[adj,
VertexShapeFunction -> "Name",
EdgeLabels ->
MapThread[Rule,{EdgeList##,AbsoluteOptions[#, EdgeWeight]/.{_ -> x_}-> x}],
GraphHighlight -> FindEdgeCover[#]]
&# WeightedAdjacencyGraph[adj]
Better ideas?

For a regular GraphPlot, you will need a slightly more complicated solution using EdgeRenderingFunction (documentation). Suppose you have an adjacency matrix where the elements are also the (directional) weights.
lilnums = {{0, 2., 1., 3., 0, 6.}, {0, 0, 1., 2., 0, 0}, {1., 8., 0, 2., 0,
2.}, {10., 13., 7., 0, 0, 10.}, {0, 0, 0, 0, 0, 0}, {4., 1., 1., 2.,
2., 0}}
Here are some labels for the vertices, supposing you are drawing network diagrams for international inter-bank exposures (the original has a lot more countries!).
names = {"AT", "AU", "CA", "CH", "CL", "ES"}
The following does what you need. The tricks are the reference back to the adjacency matrix using the parts of #2 inside the part specification, to reference the correct elements of nums, and the Mean[#1] to locate the label at the midpoint of the edge. The slot #1 seems to hold the coordinates of the vertices.
GraphPlot[lilnums, DirectedEdges -> True,
VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .04],
Black, Text[names[[#2]], #1]} &),
EdgeRenderingFunction -> ({AbsoluteThickness[2], Red,
Arrowheads[0.02], Arrow[#1, 0.05], Black,
Text[Round# Abs[(lilnums[[#2[[1]], #2[[2]]]] +
lilnums[[#2[[2]], #2[[1]]]])], Mean[#1],
Background -> Yellow]} &), VertexLabeling -> True,
ImageSize -> 600,
PlotLabel -> Style["Plot Label", Bold, 14, FontFamily -> "Arial"]]

EdgeLabels -> "EdgeWeight" still doesn't work in 8.0.4 and no longer seems to be in the documentation. However, here is one solution that does work:
lilnums = {{0, 2., 1., 3., 0, 6.}, {0, 0, 1., 2., 0, 0}, {1., 8., 0, 2., 0, 2.},
{10., 13., 7., 0, 0, 10.}, {0, 0, 0, 0, 0, 0}, {4., 1., 1., 2., 2., 0}}
names = {"AT", "AU", "CA", "CH", "CL", "ES"};
g = WeightedAdjacencyGraph[names, lilnums /. {0 -> \[Infinity]},
VertexShapeFunction -> "Name" , ImagePadding -> 15];
SetProperty[g, EdgeLabels -> MapThread[#1 -> #2 &,
{EdgeList[g], PropertyValue[g, EdgeWeight]}]]

EdgeLabels works fine. EdgeWeights does not.
It may already be obvious from Belisarius' second example that the problem lies with EdgeWeights not EdgeLabels
Here's some additional evidence. EdgeLabels very gladly displays a variety of labels correctly. But when you ask mma to display "EdgeWeights", it incorrectly displays 1's, no matter what you've stored there.
CompleteGraph[4, VertexShapeFunction -> "Name",
EdgeLabels -> {
UndirectedEdge[1, 2] -> "hello",
UndirectedEdge[1, 4] -> "goodbye", UndirectedEdge[2, 3] -> 55,
UndirectedEdge[3, 4] -> \[Pi]/2,
UndirectedEdge[4, 2] ->
"\!\(\*UnderoverscriptBox[\(\[Sum]\), \(i = 0\), \(26\)]\)(-1\!\(\
\*SuperscriptBox[\()\), \(i\)]\)\!\(\*SuperscriptBox[\(\[Theta]\), \
\(n - i\)]\)", UndirectedEdge[1, 3] -> {a, b, c}}]
The bug is not unique to CompleteGraph. Graph and GridGraph have the same problem.

The solution is easy. Upgrade to V 8.0.1 :)
At least that is what I have and it works there. (windows 7)
Btw, I do not know if the labels on the edges are correct, but at least it does
put them on the figure, unlike your image).

Related

Draw lines to intersection of two functions

I'm trying to draw lines to the intersection of two functions in Mathematica that can be manipulated with a couple variables each in the following equation:
Manipulate[
Show[
Plot[
Tooltip[QSupply + q^PriceElasticity, "Supply"], {q, 0, 150},
AxesOrigin -> {0, 0},
PlotStyle -> {Thick, Red},
AxesLabel -> {"quantity", "price"},
PlotRange -> {{0, 200}, {0, 200}},
PlotLabel -> Macroeconomy, Ticks -> {{{45, "Qe"}}, {{54.3, "Pe"}}},
BaseStyle -> {FontWeight -> "Bold", FontSize -> 12}
],
Plot[
Tooltip[(DemandElasticity/q) + QDemand, "Aggregate Demand"], {q,
0, 180},
AxesOrigin -> {0, 0},
PlotStyle -> {Thick, Blue}
],
Graphics[{Dashed, Line[{{45, 0}, {45, 54.3}}]}],
Graphics[{Dashed, Line[{{0, 54.3}, {45, 54.3}}]}]
],
{PriceElasticity, 0.6, 10},
{QSupply, -17, 55, 2},
{DemandElasticity, 500, 10000, 100},
{QDemand, 0, 150, 10}
]
I tried using the FindRoot function, but the output doesn't give a raw value (eg. {q->40.0123}. Is there a way to extract the value from the FindRoot output? Or is there a better way to go about this?
I also looked into using Mesh but it looks like that would only help draw a dot at the point of intersection.
Thanks for your help!

PlotMarkers disappear when plotting exactly two polylines in Mathematica?

Not sure if this is a MMA bug or me doing something wrong.
Consider the following function:
plotTrace[points_] :=
ListPlot[points,
Joined -> True,
PlotMarkers -> Table[i, {i, Length#points}]]
now consider passing it values generated by RandomReal. Namely, consider
RandomReal[1, {nTraces, nPointsPerTrace, 2(*constant = nDimensions*)}].
If nTraces is 1, then PlotMarkers are displayed for all values of nPointsPerTrace that I tried:
Manipulate[
plotTrace[RandomReal[1, {1, nPointsPerTrace, 2}]],
{nPointsPerTrace, 1, 20, 1}]
If nTraces is 3 or greater, then plot markers are displayed for all values of nPointsPerTrace that I tried
Manipulate[plotTrace[RandomReal[1, {nTraces, nPointsPerTrace, 2}]],
{nTraces, 3, 20, 1}, {nPointsPerTrace, 1, 20, 1}]
But if nTraces is exactly 2, I don't see plot markers, no matter the value of nPointsPerTrace:
Manipulate[plotTrace[RandomReal[1, {2, nPointsPerTrace, 2}]],
{nPointsPerTrace, 1, 20, 1}]
Hints, clues, advice would be greatly appreciated!
It's treating PlotMarkers -> {1,2} as a marker and size, instead of as two markers:
In[137]:= ListPlot[{{1, 2, 3}, {4, 5, 6}}, PlotMarkers -> {1, 2}] // InputForm
Out[137]//InputForm=
Graphics[GraphicsComplex[{{1., 1.}, {2., 2.}, {3., 3.}, {1., 4.}, {2., 5.}, {3., 6.},
{1., 1.}, {2., 2.}, {3., 3.}, {1., 4.}, {2., 5.}, {3., 6.}},
{{{Hue[0.67, 0.6, 0.6], Inset[Style[1, FontSize -> 2], 7],
Inset[Style[1, FontSize -> 2], 8], Inset[Style[1, FontSize -> 2], 9]},
{Hue[0.9060679774997897, 0.6, 0.6], Inset[Style[1, FontSize -> 2], 10],
Inset[Style[1, FontSize -> 2], 11], Inset[Style[1, FontSize -> 2], 12]}, {}}}],
{AspectRatio -> GoldenRatio^(-1), Axes -> True, AxesOrigin -> {0, 0},
PlotRange -> {{0, 3.}, {0, 6.}}, PlotRangeClipping -> True,
PlotRangePadding -> {Scaled[0.02], Scaled[0.02]}}]
Things get even stranger when you try different things for PlotMarkers. The following does not display the plot markers, as in your examples above.
pts = RandomReal[1, {2, 10, 2}];
(* No markers *)
ListPlot[pts,
Joined -> True,
PlotMarkers -> {1, 2}
]
However, when you change the 2 to b, it does:
pts = RandomReal[1, {2, 10, 2}];
(* Has markers *)
ListPlot[pts,
Joined -> True,
PlotMarkers -> {1, b}
]
If you try to change the 1 to something, it doesn't work:
pts = RandomReal[1, {2, 10, 2}];
(* No markers *)
ListPlot[pts,
Joined -> True,
PlotMarkers -> {a, 2}
]
It does indeed sound like a bug, but I'm not sure if this is version dependent or some behavior that's not obvious.

Combining Plots in Mathematica is not giving the expected result

I'm trying to combine 3 functions graphed on a Plot[] and 1 function graphed on a ParametricPlot[]. My equations are as follows:
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1}, PlotLegend -> {"-2 x", "-2 \!\(\*SqrtBox[\(x\)]\)", "-2 \!\(\*SuperscriptBox[\(x\), \(3/5\)]\)"}]
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,0, 1.40138}, PlotLegend -> {"Problem 3"}]
Show[plota, plotb]
This is the image it gives:
As yoda said, PlotLegends is terrible. However, if you don't mind setting the plot styles manually and repeating them lateron, ShowLegend can help.
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1},
PlotStyle -> {{Red}, {Blue}, {Orange}}];
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u, 0, 1.40138},
PlotStyle -> {{Black}}];
And now
ShowLegend[Show[plota, plotb],
{{{Graphics[{Red, Line[{{0, 0}, {1, 0}}]}], Label1},
{Graphics[{Blue, Line[{{0, 0}, {1, 0}}]}], Label2},
{Graphics[{Orange, Line[{{0, 0}, {1, 0}}]}], Label3},
{Graphics[{Black, Line[{{0, 0}, {1, 0}}]}], Label4}},
LegendSize -> {0.5, 0.5}, LegendPosition -> {0.5, -0.2}}]
which will give you this:
You can also write some simple functions to make this a little less cumbersome, if you deal with this problem often.
Well, the root cause of the error is the PlotLegends package, which is a terrible, buggy package. Removing that, Show combines them correctly:
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1}]
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,
0, 1.40138}]
Show[plota, plotb]
You can see Simon's solution here for ideas to label your different curves without using PlotLegends. This answer by James also demonstrates why PlotLegends has the reputation it has...
You can still salvage something with the PlotLegends package. Here's an example using ShowLegends that you can modify to your tastes
colors = {Red, Green, Blue, Pink};
legends = {-2 x, -2 Sqrt[x], -2 x^(3/5), "Problem 3"};
plota = Plot[{-2 x, -2 Sqrt[x], -2 x^(3/5)}, {x, 0, 1},
PlotStyle -> colors[[1 ;; 3]]];
plotb = ParametricPlot[{2.4056 (u - Sin[u]), 2.4056 (Cos[u] - 1)}, {u,
0, 1.40138}, PlotStyle -> colors[[4]]];
ShowLegend[
Show[plota,
plotb], {Table[{Graphics[{colors[[i]], Thick,
Line[{{0, 0}, {1, 0}}]}], legends[[i]]}, {i, 4}],
LegendPosition -> {0.4, -0.15}, LegendSpacing -> 0,
LegendShadow -> None, LegendSize -> 0.6}]
As the other answers pointed out, the culprit is PlotLegend. So, sometimes is useful to be able to roll your own plot legends:
plotStyle = {Red, Green, Blue};
labls = {"a", "b", "Let's go"};
f[i_, s_] := {Graphics[{plotStyle[[i]], Line[{{0, 0}, {1, 0}}]},
ImageSize -> {15, 10}], Style[labls[[i]], s]};
Plot[{Sin[x], Sin[2 x], Sin[3 x]}, {x, 0, 2 Pi},
PlotStyle -> plotStyle,
Epilog ->
Inset[Framed[Style#Column[{Grid[Table[f[i, 15], {i, 1, 3}]]}]],
Offset[{-2, -2}, Scaled[{1, 1}]], {Right, Top}],
PlotRangePadding -> 1
]

Effect of change in Viewpoint->{x,y,z} on the size of graphic objects is not what I expected. How to fix?

If you run the following code snippet:
Manipulate[
Graphics3D[
{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0,0,0}
],
{a, 1, 100}
]
and move the viewpoint from (1,1,1) to (1,1,100) with the slider you will see that after a while the objects remain fixed in size.
Questions.
1. When I move the viewpoint further away from the scene I want the objects to become smaller. How should this be done in Mathematica?
( EDIT: )
2. What is the position of the 'camera' in relation to Viewpoint?
See ViewAngle. Under "More Information", note that the default setting ViewAngle -> Automatic is effectively equivalent to ViewAngle -> All when you zoom far enough out.
You just need to add an explicit setting for ViewAngle:
Manipulate[
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0, 0, 0},
ViewAngle -> 35 Degree], {a, 1, 100}]
As far as I know, the camera viewpoint really coincides with the position given by ViewPoint. Because Mathematica scales the result to fit in about the same image you don't see much changes but they are there. The perspective changes considerably. Try, for instance, to move away from a semi-transparant square and you'll see that the farther you go, the more the projection becomes an orthogonal projection:
If you want to scale your image according to distance you can use ImageSize. SphericalRegion is good to stabilize the image.
Manipulate[
vp = {1, 1, a};
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> vp,
AxesOrigin -> {0, 0, 0},
SphericalRegion -> True,
ImageSize -> 500/Norm[vp]],
{a, 1, 100}
]
[animation made with some ImagePadding to keep object in the center. I stopped the animation at a = 10, the image gets pretty small after that]

How to make a grid of plots with a single pair of FrameLabels?

What is the simplest way to create a row/column/grid of plots, with the whole grid having a single FrameLabel?
I need something similar to this:
p := ListPlot[RandomInteger[10, 5], Joined -> True, Axes -> False,
Frame -> True, PlotRange -> {0, 11},
FrameLabel -> {"horizontal", None}, AspectRatio -> 1]
GraphicsRow[{Show[p, FrameLabel -> {"horizontal", "vertical"}], p, p}]
For a row format, it could have one or multiple horizontal labels, but only one vertical one.
Issues to consider:
Vertical scale must match for all plots, and must not be ruined by e.g. a too long label or automatic PlotRangePadding.
Good (and resize-tolerant!) control of inter-plot spacing is needed (after all, this is one of the motivations behind removing the redundant labels)
General space-efficiency of the arrangement. Maximum content, minimum (unnecessary) whitespace.
EDIT
I'm trying to be able to robustly create print ready figures, which involves a lot of resizing. (Because the exported PDFs will usually not have the same proportions as what I see in the notebook, and must have readable but not oversized fonts)
You can use LevelScheme to achieve what you want. Here's an example:
<< "LevelScheme`"
Figure[{
Multipanel[{{0, 1}, {0, 1}}, {1, 3},
XFrameLabels -> textit["x"], BufferB -> 3,
YFrameLabels -> textit["Sinc(x)"], BufferL -> 3,
TickFontSize -> 9,
XGapSizes -> {0.1, 0.1},
PanelLetterCorner -> {1, 1}
],
FigurePanel[{1, 1}, PlotRange -> {{-1.6, -0.6}, {-0.5, 1}}],
RawGraphics[Plot[Sinc[20 x], {x, -1.6, -0.6}]],
FigurePanel[{1, 2}, PlotRange -> {{-0.5, 0.5}, {-0.5, 1}}],
RawGraphics[Plot[Sinc[20 x], {x, -0.5, 0.5}]],
FigurePanel[{1, 3}, PlotRange -> {{0.6, 1.6}, {-0.5, 1}}],
RawGraphics[Plot[Sinc[20 x], {x, 0.6, 1.6}]]
},
PlotRange -> {{-0.1, 1.02}, {-0.12, 1.095}}]
LevelScheme offers you tremendous flexibility in the arrangement of your plot.
Instead of naming giving the plot common labels, you can move the definition inside the FigurePanel[] and control the labels for each one individually.
You can set inter-plot spacings both in the X and Y directions and also change the sizes of each panel, for e.g., the left one can take up 2/3 of the space and the next two just 1/6 of the space each.
You can set individual plot ranges, change the frame tick labels for each, control which side of the panel (top/bottom/l/r) the labels should be marked, change panel numberings, etc.
The only drawback is that you might have to wrestle with it in some cases, but in general, I've found it a pleasure to use.
EDIT
Here's one similar to your example:
Figure[{
Multipanel[{{0, 1}, {0, 1}}, {1, 3},
YFrameLabels -> textit["Vertical"], BufferL -> 3,
TickFontSize -> 9,
XGapSizes -> {0.1, 0.1},
PanelLetterCorner -> {1, 1}
],
FigurePanel[{1, 1}, PlotRange -> {{1, 10}, {0, 10}}],
RawGraphics[ListLinePlot[RandomInteger[10, 10]]],
FigurePanel[{1, 2}, PlotRange -> {{1, 10}, {0, 10}},
LabB -> textit["Horizontal"], BufferB -> 3],
RawGraphics[ListLinePlot[RandomInteger[10, 10]]],
FigurePanel[{1, 3}, PlotRange -> {{1, 10}, {0, 10}}],
RawGraphics[ListLinePlot[RandomInteger[10, 10]]]
},
PlotRange -> {{-0.1, 1.02}, {-0.2, 1.095}}]
EDIT 2
To answer Mr. Wizard's comment, here's a blank template for a 2x3 grid
Figure[{Multipanel[{{0, 1}, {0, 1}}, {2, 3},
XFrameTicks -> None,
YFrameTicks -> None,
XGapSizes -> {0.1, 0.1},
YGapSizes -> {0.1}],
FigurePanel[{1, 1}],
FigurePanel[{1, 2}],
FigurePanel[{1, 3}],
FigurePanel[{2, 1}],
FigurePanel[{2, 2}],
FigurePanel[{2, 3}]
}, PlotRange -> {{-0.01, 1.01}, {-0.01, 1.01}}]
And here's one with extended panels
Figure[{Multipanel[{{0, 1}, {0, 1}}, {2, 3},
XFrameTicks -> None,
YFrameTicks -> None,
XGapSizes -> {0.1, 0.1},
YGapSizes -> {0.1}],
FigurePanel[{1, 1}, PanelAdjustments -> {{0, 0}, {1.1, 0}}],
FigurePanel[{1, 2}],
FigurePanel[{1, 3}],
FigurePanel[{2, 2}, PanelAdjustments -> {{0, 1.1}, {0, 0}}]
}, PlotRange -> {{-0.01, 1.01}, {-0.01, 1.01}}]
You already know how to handle multiple horizontal labels through ListPlot.
You can get single labels by using Panel. For example...
p := ListPlot[RandomInteger[10, 5], Joined -> True, Axes -> False,
Frame -> True, PlotRange -> {0, 11}, AspectRatio -> 1]
Panel[GraphicsRow[{p, p, p}], {"horizontal",Rotate["vertical", Pi/2]},
{Bottom, Left}, Background -> White]
You can optionally include labels on Top and Right edges too.
Here is one option I just put together. Its advantage is that it is simple.
I like the look of yoda's LevelScheme plots better, assuming those can be done for a grid as well.
p := ListPlot[RandomInteger[10, 5], Joined -> True, Axes -> False,
Frame -> True, PlotRange -> {0, 11}, AspectRatio -> 1]
gg = GraphicsGrid[{{p, p, p}, {p, p, p}, Graphics /# Text /# {"Left", "Center", "Right"}},
Spacings -> 5, ItemAspectRatio -> {{1, 1, 0.15}}];
Labeled[gg, Rotate["vertical", Pi/2], Left]

Resources