Skip to content

Commit ac56acc

Browse files
maxitgmaxitg
authored
Adaptive arrowheads (#268)
## Changes * Closes #217. * Make the arrowheads adaptively change from `0.1` to `0.185` depending on the size of the graph. * The style spec is contributed by *Jeremy Davis*. ## Comments * The arrowhead function is now in `style.m`. This is the first precedent where a function is used for a style. ## Tests * Comparison of old arrowheads (on the left), and the new adaptive ones (on the right): ``` In[] := Grid@Transpose[ WolframModel[{{1, 2, 3}, {4, 5, 6}, {1, 4}} -> {{2, 7, 8}, {3, 9, 10}, {5, 11, 12}, {6, 13, 14}, {8, 12}, {11, 10}, {13, 7}, {14, 9}}, {{1, 1, 1}, {1, 1, 1}, {1, 1}, {1, 1}, {1, 1}}, 3]["EventsStatesPlotsList", "ArrowheadLength" -> #] & /@ {0.1, Automatic}] ``` <img width="408" alt="image" src="https://user-images.githubusercontent.com/1479325/76712423-3e7fc800-66ef-11ea-8d50-0b37a544c783.png"> * The new spec makes it possible to see arrows on graphs 1.85 larger than before: ``` In[] := WolframModel[{{1, 2}, {2, 3}} -> {{4, 2}, {4, 1}, {2, 1}, {3, 4}}, {{1, 2}, {2, 3}, {3, 4}, {4, 1}}, 5, "FinalStatePlot"] ``` <img width="399" alt="image" src="https://user-images.githubusercontent.com/1479325/76712427-55beb580-66ef-11ea-967e-14895148a7cf.png"> * The new spec function can be looked up with `WolframPhysicsProjectStyleData`: ``` In[] := WolframPhysicsProjectStyleData["SpatialGraph", "ArrowheadLengthFunction"] Out[] = Max[0.1, Min[0.185, 0.066 + 0.017 #PlotRange]] & ```
1 parent 3647e69 commit ac56acc

File tree

3 files changed

+61
-38
lines changed

3 files changed

+61
-38
lines changed

‎Kernel/WolframModelPlot.m

+19-9
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,7 @@
3232
VertexCoordinateRules -> {},
3333
VertexLabels -> None,
3434
VertexSize -> style[$lightTheme][$vertexSize],
35-
"ArrowheadLength" -> style[$lightTheme][$arrowheadLength],
35+
"ArrowheadLength" -> Automatic,
3636
VertexStyle -> Automatic, (* inherits from PlotStyle *)
3737
"MaxImageSize" -> Automatic},
3838
Options[Graphics]];
@@ -177,8 +177,8 @@
177177
correctCoordinateRulesQ[head, OptionValue[WolframModelPlot, opts, VertexCoordinateRules]] &&
178178
correctHighlightQ[OptionValue[WolframModelPlot, opts, GraphHighlight]] &&
179179
correctHighlightStyleQ[head, OptionValue[WolframModelPlot, opts, GraphHighlightStyle]] &&
180-
correctSizeQ[head, "Vertex size", OptionValue[WolframModelPlot, opts, VertexSize]] &&
181-
correctSizeQ[head, "Arrowhead length", OptionValue[WolframModelPlot, opts, "ArrowheadLength"]] &&
180+
correctSizeQ[head, "Vertex size", OptionValue[WolframModelPlot, opts, VertexSize], {}] &&
181+
correctSizeQ[head, "Arrowhead length", OptionValue[WolframModelPlot, opts, "ArrowheadLength"], {Automatic}] &&
182182
correctPlotStyleQ[head, OptionValue[WolframModelPlot, opts, PlotStyle]] &&
183183
correctStyleLengthQ[
184184
head, "vertices", MatchQ[edges, {$hypergraphPattern...}], Length[vertexList[edges]], OptionValue[WolframModelPlot, opts, VertexStyle]] &&
@@ -202,9 +202,12 @@
202202
correctHighlightStyleQ[head_, highlightStyle_] :=
203203
If[ColorQ[highlightStyle], True, Message[head::invalidHighlightStyle, highlightStyle]; False]
204204

205-
correctSizeQ[head_, capitalizedName_, size_ ? (# >= 0 &)] := True
205+
correctSizeQ[head_, capitalizedName_, size_ ? (# >= 0 &), _] := True
206206

207-
correctSizeQ[head_, capitalizedName_, size_] := (
207+
correctSizeQ[head_, capitalizedName_, size_, allowedSpecialValues_] /;
208+
MatchQ[size, Alternatives @@ allowedSpecialValues] := True
209+
210+
correctSizeQ[head_, capitalizedName_, size_, _] := (
208211
Message[head::invalidSize, capitalizedName, size];
209212
False
210213
)
@@ -244,10 +247,13 @@
244247
vertexSize_,
245248
arrowheadLength_,
246249
maxImageSize_,
247-
graphicsOptions_] := Catch[Module[{graphics, imageSizeScaleFactor},
248-
graphics = drawEmbedding[styles, vertexLabels, highlight, highlightColor, vertexSize, arrowheadLength] @
249-
hypergraphEmbedding[edgeType, hyperedgeRendering, vertexCoordinates] @
250-
edges;
250+
graphicsOptions_] := Catch[Module[{embedding, graphics, imageSizeScaleFactor},
251+
embedding = hypergraphEmbedding[edgeType, hyperedgeRendering, vertexCoordinates] @ edges;
252+
numericArrowheadLength = Replace[
253+
arrowheadLength,
254+
Automatic -> style[$lightTheme][$arrowheadLengthFunction][<|"PlotRange" -> vertexEmbeddingRange[embedding[[1]]]|>]];
255+
graphics =
256+
drawEmbedding[styles, vertexLabels, highlight, highlightColor, vertexSize, numericArrowheadLength] @ embedding;
251257
imageSizeScaleFactor = Min[1, 0.7 (#[[2]] - #[[1]])] & /@ PlotRange[graphics];
252258
Show[
253259
graphics,
@@ -257,6 +263,10 @@
257263
ImageSize -> adjustImageSize[maxImageSize, imageSizeScaleFactor]]]
258264
]]
259265

266+
vertexEmbeddingRange[{}] := 0
267+
268+
vertexEmbeddingRange[vertexEmbedding_] := Max[#2 - #1 & @@@ MinMax /@ Transpose[vertexEmbedding[[All, 2, 1, 1]]]]
269+
260270
adjustImageSize[w_ ? NumericQ, {wScale_, hScale_}] := w wScale
261271

262272
adjustImageSize[dims : {w_ ? NumericQ, h_ ? NumericQ}, scale_] := dims scale

‎Kernel/style.m

+3-3
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@
1616
PackageScope["$causalGraphFinalVertexStyle"]
1717
PackageScope["$causalGraphEdgeStyle"]
1818
PackageScope["$vertexSize"]
19-
PackageScope["$arrowheadLength"]
19+
PackageScope["$arrowheadLengthFunction"]
2020
PackageScope["$edgeArrowheadShape"]
2121
PackageScope["$vertexStyle"]
2222
PackageScope["$edgeLineStyle"]
@@ -72,7 +72,7 @@
7272
"CreatedEdgeStyle" -> $destroyedEdgeStyle,
7373
"DestroyedAndCreatedEdgeStyle" -> $destroyedAndCreatedEdgeStyle,
7474
"VertexSize" -> $vertexSize,
75-
"ArrowheadLength" -> $arrowheadLength,
75+
"ArrowheadLengthFunction" -> $arrowheadLengthFunction,
7676
"EdgeArrowheadShape" -> $edgeArrowheadShape,
7777
"VertexStyle" -> $vertexStyle,
7878
"EdgeLineStyle" -> $edgeLineStyle,
@@ -186,7 +186,7 @@
186186

187187
(* WolframModelPlot *)
188188
$vertexSize -> 0.06,
189-
$arrowheadLength -> 0.1,
189+
$arrowheadLengthFunction -> (Max[0.1, Min[0.185, 0.066 + 0.017 #PlotRange]] &),
190190
$edgeArrowheadShape -> Polygon[{
191191
{-1.10196, -0.289756}, {-1.08585, -0.257073}, {-1.05025, -0.178048}, {-1.03171, -0.130243}, {-1.01512, -0.0824391},
192192
{-1.0039, -0.037561}, {-1., 0.}, {-1.0039, 0.0341466}, {-1.01512, 0.0780486}, {-1.03171, 0.127805},

‎Tests/WolframModelPlot.wlt

+39-26
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,10 @@
2323
{{1, 2, 3}, {3, 4, 5}, {1, 2, 3, 4}}
2424
};
2525

26+
{$minArrowheadSize, $maxArrowheadSize} =
27+
WolframPhysicsProjectStyleData["SpatialGraph", "ArrowheadLengthFunction"][
28+
<|"PlotRange" -> #|>] & /@ {0, 1.*^100};
29+
2630
$selfLoopLength = FirstCase[
2731
WolframModelPlot[{{1, 1}}, "HyperedgeRendering" -> "Subgraphs"],
2832
Line[pts_] :> RegionMeasure[Line[pts]],
@@ -293,6 +297,11 @@
293297
]
294298
} & /@ {VertexSize, "ArrowheadLength"},
295299

300+
VerificationTest[
301+
Head[WolframModelPlot[#, "ArrowheadLength" -> Automatic]],
302+
Graphics
303+
] & /@ {{{1, 2, 3}, {3, 4, 5}}, {{1, 1}}, {{1}}, {}},
304+
296305
(* HypergraphPlot can still be used *)
297306

298307
VerificationTest[
@@ -598,32 +607,36 @@
598607
{{{1, 2}}, {{1, 2, 3}}, {{1, 2, 3}, {3, 4, 5}}, RandomInteger[10, {5, 5}]})
599608
],
600609

601-
VerificationTest[
602-
Equal @@ (
603-
Mean[Cases[
604-
WolframModelPlot[#, "HyperedgeRendering" -> "Subgraphs"],
605-
Line[pts_] :> EuclideanDistance @@ pts,
606-
All]] & /@
607-
{{{1, 2}}, {{1, 2, 3}}, {{1, 2, 3}, {3, 4, 5}}, {{1, 2, 3}, {3, 4, 5}, {5, 6, 1}}, {{1, 2, 3, 4, 5, 1}}})
608-
],
609-
610-
VerificationTest[
611-
Abs[
612-
First[
613-
Nearest[
614-
Cases[
615-
WolframModelPlot[#, "HyperedgeRendering" -> "Subgraphs"],
616-
Line[pts_] :> RegionMeasure[Line[pts]],
617-
All],
618-
$selfLoopLength]] -
619-
$selfLoopLength] <
620-
1.*^-10
621-
] & /@ {
622-
{{1, 1}},
623-
{{1, 2, 3}, {1, 1}},
624-
{{1, 2, 3}, {3, 4, 5}, {5, 5}},
625-
{{1, 2, 3}, {3, 4, 5}, {5, 6, 1, 1}},
626-
{{1, 2, 3, 4, 5, 5, 1}}},
610+
With[{$minArrowheadSize = $minArrowheadSize, $maxArrowheadSize = $maxArrowheadSize},
611+
VerificationTest[
612+
Length[DeleteDuplicates[
613+
Mean[Cases[
614+
WolframModelPlot[#, "HyperedgeRendering" -> "Subgraphs"],
615+
Line[pts_] :> EuclideanDistance @@ pts,
616+
All]] & /@
617+
{{{1, 2}}, {{1, 2, 3}}, {{1, 2, 3}, {3, 4, 5}}, {{1, 2, 3}, {3, 4, 5}, {5, 6, 1}}, {{1, 2, 3, 4, 5, 1}}},
618+
#2 - #1 <= $maxArrowheadSize - $minArrowheadSize &]] == 1
619+
]],
620+
621+
With[{
622+
$minArrowheadSize = $minArrowheadSize, $maxArrowheadSize = $maxArrowheadSize, $selfLoopLength = $selfLoopLength},
623+
VerificationTest[
624+
Abs[
625+
First[
626+
Nearest[
627+
Cases[
628+
WolframModelPlot[#, "HyperedgeRendering" -> "Subgraphs"],
629+
Line[pts_] :> RegionMeasure[Line[pts]],
630+
All],
631+
$selfLoopLength]] -
632+
$selfLoopLength] <
633+
$maxArrowheadSize - $minArrowheadSize
634+
] & /@ {
635+
{{1, 1}},
636+
{{1, 2, 3}, {1, 1}},
637+
{{1, 2, 3}, {3, 4, 5}, {5, 5}},
638+
{{1, 2, 3}, {3, 4, 5}, {5, 6, 1, 1}},
639+
{{1, 2, 3, 4, 5, 5, 1}}}],
627640

628641
(* Automatic image size *)
629642
VerificationTest[

0 commit comments

Comments
 (0)