# Custom arrow shaft

Inspired by Sjoerd C. de Vries' nice answer to this question, and the desire to pimp a Graph I did with Mathematica recently I would like to know if there are ways to customize the arrow's shaft rather than its head (other than using Tube in Graphics3D). I am especially interested in arrows with non-uniform thickness along its length. Consider some examples grabbed from the web:

Any chance to come up with a solution that allows to have Graphs like the following with automatically drawn/scaled arrow?

P.S.: This is a 2D question:). I understand that Line (and Tube) have the advantages to be easier to handle in 3D.

-
Well, Arrow[] can take a JoinedCurve[] as an argument, so you can at least make an outline of your "arrows of non-uniform thickness". – J. M. Oct 4 '12 at 11:41

Update: added a version using Inset below the original answer

Here's an extended version of the arrow heads customization code. There are two pieces. One is the arrow drawing routine. The other one is an arrow editor, similar to my arrowheads editor but with more controls. There is a 'Copy to Clipboard' button to copy the drawArrow function with necessary parameter values filled in to generate the designed arrow.

Code is at the bottom of this answer.

usage:

Graph[{1 -> 2, 2 -> 3, 3 -> 4, 4 -> 1, 4 -> 5, 5 -> 6,
6 -> 7, 7 -> 8, 8 -> 1},
EdgeShapeFunction -> ({drawArrow[{{-6.5, 1}, {-4, 1/2}, {-6,
0}, {-2, 0.2}, {-2, 0.5}, {-2, 1}, {-2, 1.1}, {-1, 1}, {0,
0}}, #1[[1]], #1[[2]], ArrowFillColor -> RGBColor[1, 1, 0],
ArrowFillOpacity -> 0.5, ArrowEdgeThickness -> 0.1,
ArrowEdgeColor -> RGBColor[1, 0.5, 0], ArrowEdgeOpacity -> 1,
LeftArrowSpacing -> 0.2, RightArrowSpacing -> 0.2]} &),
VertexShapeFunction -> None, EdgeStyle -> Automatic]


The 2nd and 3rd argument are the start and end positions of the arrow, respectively. Replacing these with #1[[1]] and #1[[2]] and adding an & at the end, turns the drawArrow function into a function that can be used as EdgeShapeFunction in Graph

More examples:

The code:

Options[drawArrow] = {ArrowFillColor -> Black,
ArrowEdgeThickness -> 0.02, ArrowEdgeColor -> Black,
ArrowFillOpacity -> 1, ArrowEdgeOpacity -> 1,
LeftArrowSpacing -> 0, RightArrowSpacing -> 0};

drawArrow[{shaftEndLeft_, shaftMidLeft_, shaftEndMid_, baseMidLeft_,
innerMidLeft_, innerBaseLeft_, outerBaseLeft_, outerMidLeft_,
top_}, pstart_, pend_, OptionsPattern[]] :=
Module[{baseMidRight, outerMidRight, innerMidRight, innerBaseRight,
outerBaseRight, shaftEndRight, shaftMidRight},

shaftEndRight = {1, -1} shaftEndLeft;
shaftMidRight = {1, -1} shaftMidLeft;
baseMidRight = {1, -1} baseMidLeft;
innerBaseRight = {1, -1} innerBaseLeft;
outerBaseRight = {1, -1} outerBaseLeft;
outerMidRight = {1, -1} outerMidLeft;
innerMidRight = {1, -1} innerMidLeft;
{
If[OptionValue[ArrowEdgeColor] === None, EdgeForm[],
EdgeForm[
Directive[Thickness[OptionValue[ArrowEdgeThickness]],
OptionValue[ArrowEdgeColor],
Opacity[OptionValue[ArrowEdgeOpacity]]]]],
If[OptionValue[ArrowFillColor] === None, FaceForm[],
FaceForm[
Directive[Opacity[OptionValue[ArrowFillOpacity]],
OptionValue[ArrowFillColor]]]],
GeometricTransformation[
FilledCurve[
{
Line[{shaftEndMid, shaftEndLeft}],
BSplineCurve[{shaftEndLeft, shaftMidLeft, baseMidLeft}],
BSplineCurve[{baseMidLeft, innerMidLeft, innerBaseLeft}],
Line[{innerBaseLeft, outerBaseLeft}],
BSplineCurve[{outerBaseLeft, outerMidLeft, top}],
BSplineCurve[{top, outerMidRight, outerBaseRight}],
Line[{outerBaseRight, innerBaseRight}],
BSplineCurve[{innerBaseRight, innerMidRight, baseMidRight}],
BSplineCurve[{baseMidRight, shaftMidRight, shaftEndRight}],
Line[{shaftEndRight, shaftEndMid}]
}
], FindGeometricTransform[{pstart,
pend}, {shaftEndMid + {-OptionValue[
LeftArrowSpacing] EuclideanDistance[shaftEndMid, top], 0},
top + {OptionValue[RightArrowSpacing] EuclideanDistance[
shaftEndMid, top], 0}}][[2]]
]
}
]

DynamicModule[{top, fill, edge, arrowFillColor, arrowEdgeColor,
arrowFillOpacity, arrowEdgeThickness, arrowEdgeOpacity},
Manipulate[
top = {0, 0};
shaftEndMid = {1, 0} shaftEndMid;
Graphics[
h = drawArrow2[{shaftEndLeft, shaftMidLeft, shaftEndMid,
baseMidLeft, innerMidLeft, innerBaseLeft, outerBaseLeft,
outerMidLeft, top}, shaftEndMid, top,
ArrowFillColor -> If[fill, arrowFillColor, None],
ArrowFillOpacity -> arrowFillOpacity,
ArrowEdgeThickness -> arrowEdgeThickness,
ArrowEdgeColor -> If[edge, arrowEdgeColor, None],
ArrowEdgeOpacity -> arrowEdgeOpacity
];
h /. {drawArrow2 -> drawArrow},
PlotRange -> {{-7, 2}, {-2, 2}},
GridLines -> {Range[-7, 2, 1/4], Range[-2, 2, 1/4]},
GridLinesStyle -> Dotted,
ImageSize -> 800,
AspectRatio -> Automatic
],
{{shaftEndLeft, {-6.5, 1}}, Locator},
{{shaftMidLeft, {-4, 1/2}}, Locator},
{{shaftEndMid, {-6, 0}}, Locator},
{{baseMidLeft, {-2, 0.2}}, Locator},
{{innerMidLeft, {-2, 0.5}}, Locator},
{{innerBaseLeft, {-2, 1}}, Locator},
{{outerBaseLeft, {-2, 1.1}}, Locator},
{{outerMidLeft, {-1, 1}}, Locator},
Grid[
{
{Style["Fill", Bold, 16],
Control@{{fill, True, "Fill"}, {True, False}}, "  ",
Control@{{arrowFillColor, Yellow, "Color"}, Yellow}, "  ",
Control@{{arrowFillOpacity, 0.5, "Opacity"}, 0, 1}, "", ""},
{Style["Edge", Bold, 16],
Control@{{edge, True, "Edge"}, {True, False}}, "  ",
Control@{{arrowEdgeColor, Orange, "Color"}, Orange}, "  ",
Control@{{arrowEdgeThickness, 0.02, "Thickness"}, 0, 0.1}, "  ",
Control@{{arrowEdgeOpacity, 1, "Opacity"}, 0, 1}}
}\[Transpose]
, Alignment -> Left,
Dividers -> {{True, True, {False}, True}, {True, True, {False},
True}}
],
Button["Copy to clipboard",
CopyToClipboard[
h /. {drawArrow2 -> Defer[drawArrow]}
],
ImageSize -> Automatic
]
]
]


UPDATE

I was not satisfied with the behavior of the line thickness in the arrow definition. The problem was discussed in this question. I implemented the Inset idea of Mr.Wizard and also improved the clipboard copying, based on Simon's idea, but got rid of his Sequence that ended up as junk in the copied code. At the bottom the new code. A result is shown here:

Show[
Graph[GraphData["DodecahedralGraph", "EdgeRules"],
VertexShape -> Graphics@{Red, Disk[]},
EdgeShapeFunction ->
Function[{p$, v$},
drawArrow @@ {{{-6.2059999999999995,
0.3650000000000002}, {-4.052, 1.045}, {-6.156,
0.}, {-1.5380000000000003,
0.2549999999999999}, {-0.9879999999999995,
0.46499999999999986}, {-2, 1}, {-1.428, 1.435}, {-1,
1}, {0, 0}}, p$[[1]], p$[[2]], {ArrowFillColor ->
RGBColor[0., 0.61538109407187, 0.1625391012436103],
ArrowFillOpacity -> 0.462, ArrowEdgeThickness -> 0.0616,
ArrowEdgeColor ->
RGBColor[0.06968795300221256, 0.30768291752498667, 0.],
ArrowEdgeOpacity -> 1}}],
VertexCoordinates ->
MapIndexed[First[#2] -> #1 &,
GraphData["DodecahedralGraph", "VertexCoordinates"]]],
Method -> {"ShrinkWrap" -> True}
]


(Note the "ShrinkWrap". Using Inset apparently generates a lot of white space that has to be cropped)

The code:

Options[drawArrow] = {ArrowFillColor -> Black,
ArrowEdgeThickness -> 0.02, ArrowEdgeColor -> Black,
ArrowFillOpacity -> 1, ArrowEdgeOpacity -> 1,
LeftArrowSpacing -> 0, RightArrowSpacing -> 0};

drawArrow[{shaftEndLeft_, shaftMidLeft_, shaftEndMid_, baseMidLeft_,
innerMidLeft_, innerBaseLeft_, outerBaseLeft_, outerMidLeft_,
top_}, pstart_, pend_, OptionsPattern[]] :=
Module[{baseMidRight, outerMidRight, innerMidRight, innerBaseRight,
outerBaseRight, shaftEndRight, shaftMidRight},

shaftEndRight = {1, -1} shaftEndLeft;
shaftMidRight = {1, -1} shaftMidLeft;
baseMidRight = {1, -1} baseMidLeft;
innerBaseRight = {1, -1} innerBaseLeft;
outerBaseRight = {1, -1} outerBaseLeft;
outerMidRight = {1, -1} outerMidLeft;
innerMidRight = {1, -1} innerMidLeft;
Inset[
Graphics[
{
If[OptionValue[ArrowEdgeColor] === None, EdgeForm[],
EdgeForm[
Directive[Thickness[OptionValue[ArrowEdgeThickness]],
OptionValue[ArrowEdgeColor],
Opacity[OptionValue[ArrowEdgeOpacity]]]]],
If[OptionValue[ArrowFillColor] === None, FaceForm[],
FaceForm[
Directive[Opacity[OptionValue[ArrowFillOpacity]],
OptionValue[ArrowFillColor]]]],
FilledCurve[
{
Line[{shaftEndMid, shaftEndLeft}],
BSplineCurve[{shaftEndLeft, shaftMidLeft, baseMidLeft}],
BSplineCurve[{baseMidLeft, innerMidLeft, innerBaseLeft}],
Line[{innerBaseLeft, outerBaseLeft}],
BSplineCurve[{outerBaseLeft, outerMidLeft, top}],
BSplineCurve[{top, outerMidRight, outerBaseRight}],
Line[{outerBaseRight, innerBaseRight}],
BSplineCurve[{innerBaseRight, innerMidRight, baseMidRight}],
BSplineCurve[{baseMidRight, shaftMidRight, shaftEndRight}],
Line[{shaftEndRight, shaftEndMid}]
}
]
},
PlotRange -> {{-7, 1}, {-2, 2}}
],
pstart, {-7, 0}, EuclideanDistance[pstart, pend], pend - pstart
]
]

DynamicModule[{top, fill, edge, arrowFillColor, arrowEdgeColor,
arrowFillOpacity, arrowEdgeThickness, arrowEdgeOpacity},
Manipulate[
top = {0, 0};
shaftEndMid = {1, 0} shaftEndMid;
Graphics[
drawArrow[{shaftEndLeft, shaftMidLeft, shaftEndMid, baseMidLeft,
innerMidLeft, innerBaseLeft, outerBaseLeft, outerMidLeft,
top}, {-7, 0}, {1, 0},
ArrowFillColor -> If[fill, arrowFillColor, None],
ArrowFillOpacity -> arrowFillOpacity,
ArrowEdgeThickness -> arrowEdgeThickness,
ArrowEdgeColor -> If[edge, arrowEdgeColor, None],
ArrowEdgeOpacity -> arrowEdgeOpacity
],
PlotRange -> {{-7, 1}, {-2, 2}},
GridLines -> {Range[-7, 1, 1/4], Range[-2, 2, 1/4]},
GridLinesStyle -> Dotted,
ImageSize -> 800,
AspectRatio -> Automatic
],
{{shaftEndLeft, {-6.5, 1}}, Locator},
{{shaftMidLeft, {-4, 1/2}}, Locator},
{{shaftEndMid, {-6, 0}}, Locator},
{{baseMidLeft, {-2, 0.2}}, Locator},
{{innerMidLeft, {-2, 0.5}}, Locator},
{{innerBaseLeft, {-2, 1}}, Locator},
{{outerBaseLeft, {-2, 1.1}}, Locator},
{{outerMidLeft, {-1, 1}}, Locator},
Grid[
{
{Style["Fill", Bold, 16],
Control@{{fill, True, "Fill"}, {True, False}}, "  ",
Control@{{arrowFillColor, Yellow, "Color"}, Yellow}, "  ",
Control@{{arrowFillOpacity, 0.5, "Opacity"}, 0, 1}, "", ""},
{Style["Edge", Bold, 16],
Control@{{edge, True, "Edge"}, {True, False}}, "  ",
Control@{{arrowEdgeColor, Orange, "Color"}, Orange}, "  ",
Control@{{arrowEdgeThickness, 0.02, "Thickness"}, 0, 0.1}, "  ",
Control@{{arrowEdgeOpacity, 1, "Opacity"}, 0, 1}}
}\[Transpose]
, Alignment -> Left,
Dividers -> {{True, True, {False}, True}, {True, True, {False},
True}}
],
Button["Copy to clipboard",
With[
{
params = {shaftEndLeft, shaftMidLeft, shaftEndMid, baseMidLeft,
innerMidLeft, innerBaseLeft, outerBaseLeft, outerMidLeft, top},
opts = {ArrowFillColor -> If[fill, arrowFillColor, None],
ArrowFillOpacity -> arrowFillOpacity,
ArrowEdgeThickness -> arrowEdgeThickness,
ArrowEdgeColor -> If[edge, arrowEdgeColor, None],
ArrowEdgeOpacity -> arrowEdgeOpacity}
},
CopyToClipboard[
Defer[EdgeShapeFunction ->
Function[{p,
v}, (drawArrow @@ {params, p[[1]], p[[2]], opts})]]]
],
ImageSize -> Automatic
]
], SaveDefinitions -> True
]

-
I love the variety of arrows you can get with this method, and the simplicity of designing them with Locators. +1 – Simon Woods Oct 8 '12 at 19:42

Any chance to come up with a solution that allows to have Graphs like the following with automatically drawn/scaled arrow?

Yes! Even without implementing your own Arrow function. The trick is simple, start with taking your image and extract and binarize one version of your arrow. After this I crop the image to be of squared size and apply a very light Gaussian filter whose purpose is explained later:

img = Import["http://i.stack.imgur.com/cIYRI.jpg"];
arrowImg = ImageCrop[Binarize@ImageTake[img, {1, 400}, {-300, -1}]]
With[{d = Max[ImageDimensions[arrowImg]]},
arrowImg =
GaussianFilter[ImageCrop[arrowImg, {d, d} + 10, Padding -> White], 2]
]


Now the magic happens. Interpolate the image matrix to get a function $f(x,y)$ which is 0 inside the arrow and 1 everywhere else. Then we have this fine function called RegionPlot in Mathematica.

func = ListInterpolation[
ImageData[arrowImg, "Real", DataReversed -> True], {{0, 1}, {0, 1}}];
arrowGraphics =
RegionPlot[func[y, x] < 1/2, {x, 0, 1}, {y, 0, 1},
PlotStyle -> Green, BoundaryStyle -> Directive[Thick, Black],
Frame -> False, AspectRatio -> Automatic, PlotPoints -> 40,
MaxRecursion -> 3]


Beside that we have a green arrow again the true magic happened behind the scenes. RegionPlot creates Polygon directives to show its result which can of course be scaled, translated, and rotated without losing quality.

With[{a = First[arrowGraphics]},
Graphics[
{a, GeometricTransformation[
a, {RotationTransform[2/3 Pi], RotationTransform[4/3 Pi]}]}]]


-
This is pretty cool, but the Graphics code produced is a great deal more complex that it would need to be. – Mr.Wizard Oct 4 '12 at 15:41
Agreed, that's cool. But imagine adding a few vertices, which would requires a lot of fiddling around with Transformations to have the Arrows where they belong. It would be nicer to let Graph do this. But still, very nice idea! +1 – Markus Roellig Oct 5 '12 at 7:54

You can specify any graphics you like using EdgeRenderingFunction in GraphPlot. Here's a function to generate a customised arrow, with various parameters controlling the shape:

arowsplit[{a_, b_}] := ((1 - #) a + # b) & /@ Range[0, 1, 1/10]

arow[c_, base_, baseinset_, basewidth_, neckwidth_, neck_, headwidth_,
sweep_, tip_][{{x1_, y1_}, {x2_, y2_}}] :=
GeometricTransformation[
GeometricTransformation[FilledCurve[BSplineCurve /@
Apply[{-Sqrt[(c^-2) - 0.25],
0.5} + ((Abs[1/c]) + #1) Through[{Cos, Sin}[
ArcTan[(#2 - 0.5)/Sqrt[(c^-2) - 0.25]]]] &,
arowsplit /@
Partition[{{0, base + baseinset}, {-basewidth,
base + neck (tip - base)}, {-headwidth, (1 - sweep) (base +
neck (tip - base))}, {0,
tip}, {headwidth, (1 - sweep) (base +
neck (tip - base))}, {neckwidth headwidth,
base + neck (tip - base)}, {basewidth, base}, {0,
base + baseinset}}, 2, 1], {2}]], {{Sign[c], 0}, {0, 1}}],
TransformationFunction[{{-y1 + y2, -x1 + x2,
x1}, {x1 - x2, -y1 + y2, y1}, {0, 0, 1}}]]


To make it easier to use I've made a Manipulate which lets you vary the parameters and then paste an EdgeRenderingFunction directly into the GraphPlot expression.

Manipulate[
Graphics[{Red, PointSize[0.1], Point[{{0, 0}, {0, 1}}],
EdgeForm[{Thickness[ethick], ecol}], col,
arow[c, base, bi, bw, nw, neck, hw, sw, tip][{{0, 0}, {0, 1}}]},
PlotRange -> {Automatic, {-0.1, 1.1}}],
{{c, 1.3, "Curvature"}, -1.9, 1.9},
{{tip, 0.8, "Tip"}, 0.5, 1},
{{neck, 0.6, "Neck"}, 0, 1},
{{nw, 0.25, "Neck width"}, 0, 1},
{{hw, 0.08, "Head width"}, 0, 0.5},
{{sw, 0.05, "Sweep"}, 0, 1},
{{base, 0.2, "Base"}, 0, 0.5},
{{bw, 0.07, "Base width"}, 0, 0.5},
{{bi, 0.05, "Base inset"}, 0, 0.5}, Delimiter,
{{ecol, Blue, "Edge colour"}, Blue},
{{ethick, 0.005, "Edge thickness"}, 0, 0.1},
{{col, Yellow, "Colour"}, Yellow}, Delimiter,
Button["Paste",
With[{params = Sequence[c, base, bi, bw, nw, neck, hw, sw, tip],
ecol = ecol, ethick = ethick, col = col},
Paste[Defer[EdgeRenderingFunction ->
Function[
p, {EdgeForm[{Thickness[ethick], ecol}], col,
arow[params][p]}]]]]],
FrameLabel -> {"", "", "Edge Rendering Function Arrow\n"}]


The red dots show the position of the graph vertices relative to the arrow. I won't try to describe what all the parameters do, it's easier just to play with the Manipulate. Once you have an arrow you are happy with just position the cursor inside the GraphPlot command and click the paste button.

In the example below I've also used a custom VertexRenderingFunction:

GraphPlot[{1 -> 2, 2 -> 3, 3 -> 1},
VertexRenderingFunction -> ({Green, EdgeForm[{Thick, Black}],
Disk[#, .1], Black, Style[Text[#2, #1], 20]} &),
EdgeRenderingFunction ->
Function[p$, {EdgeForm[{Thickness[0.005], RGBColor[0, 0, 1]}], RGBColor[1, 1, 0], arow[Sequence[1.3, 0.2, 0.05, 0.07, 0.25, 0.6, 0.08, 0.05, 0.8]][p$]}]]


-
+1 It seems we had a few similar ideas. I like how you solved the problem of returning a pure function using With better than how I did it. One thing that could be improved here is that you end up with a Sequence in the copied function. – Sjoerd C. de Vries Oct 7 '12 at 19:07
One problem both your and my answer suffer from is the edge thickness. You don't get the same ratio of line thickness and arrow dimensions once you use the arrow in a larger image since the Thickness relates to the horizontal size of the total image. So, you always have to change Thickness from the one you designed the arrow at. – Sjoerd C. de Vries Oct 7 '12 at 19:13
Another thing we both could work on still is the handling of self-loops and curved arrow paths like the ones generated by LayeredGraphPlot. You get a long list of coordinates there instead of just a begin and end position. – Sjoerd C. de Vries Oct 7 '12 at 19:17
@SjoerdC.deVries, I'm not sure how to deal with the thickness problem. It should be possible to transform the arrow to follow a curved path, but I'm not sure my geometry skills are up to it :-) – Simon Woods Oct 8 '12 at 19:39
I found it tempting to go all that way, but I already spent too much time on the answer as it was. Perhaps when I retire in a few decades. – Sjoerd C. de Vries Oct 8 '12 at 19:45

For version 7 and up, fatArrow (defined below) reproduces many of the arrows in the OP's graphic (but one has to tune the parameters for each scenario, so it's not "automatic"):

Graphics[{Darker[Green], EdgeForm[Directive[Thickness[0.0075], Black]],
fatArrow[{{0, 0}, {0.44, 1.2}, {-0.85, 1.3}}, 0.15, 0.06, "HeadLength" -> 0.2, "HeadWidth" -> 0.2, "HeadAngle" -> -30, "TailNotch" -> 0.1]}]


Graphics[{Orange, EdgeForm[Directive[Thickness[0.0075], Black]],
fatArrow[{{0, 0}, {1, 0}}, .15, .15, "HeadLength" -> .25, "HeadWidth" -> .2]}]


Graphics[{White, EdgeForm[Directive[Thickness[0.02], Black]],
fatArrow[{{0, 0}, {1, 0}}, 0.1, 0.1, "HeadLength" -> 0.25, "HeadWidth" -> 0.15]}]


Graphics[{Lighter@Blend[{Black, Cyan, Blue}], EdgeForm[Directive[Thickness[0.008], Black]],
fatArrow[{{0, 0}, {1, 0}}, 0.15, 0.15, "HeadLength" -> 0.15, "HeadWidth" -> 0, "TailNotch" -> 0.15]}]


Graphics[{Black,
fatArrow[{{-0.6, 0.25}, {0.55, 0.25}, {0.25, 1.5}}, 0.4, 0.07, "HeadLength" -> 0.2, "HeadWidth" -> 0.35, "HeadAngle" -> 0]}]


The supplied points are passed to a BezierCurve, which is translated laterally to form the sides of the arrow. Could add the option to make the arrowhead out of a BezierCurve as well, to be able to reproduce the OP's red arrow. All Beziers are then replaced by straight line segments. (Welcome a version that only uses Beziers!).

The next two parameters specify the thickness at each end of the shaft.

Here's the definition:

Clear[fatArrow];
fatArrow[points_, tailwidth_, tipwidth_, OptionsPattern[]] :=
fatness, curve1, curve2, tail, head, tailnotch},
curve = BezierFunction[points];
tangent[u_] := Normalize[curve'[u]];
normal[u_] := RotationTransform[-\[Pi]/2][tangent[u]];
fatness[u_] := tailwidth + (tipwidth - tailwidth) u;
curve1 = BezierFunction[curve[#] + fatness[#] normal[#] & /@ Range[0, 1, 1/10]] /@Range[0, 1 - headlength, (1 - headlength)/20];
curve2 = BezierFunction[curve[#] - fatness[#] normal[#] & /@ Range[0, 1, 1/10]] /@Range[0, 1 - headlength, (1 - headlength)/20];
tail = BezierFunction[{First@curve2, First@curve1}];
Rest[Reverse@curve2], {curve[tailnotch]}, {First@curve1}}, 1]]}
]

-

I can offer a very simple way of copying any image element as a polygon, that canafter that be used as an element of any graphics or art work done within Mathematica. It is based on the function entitled "strokeArea".

Description.

The function strokeArea is designed to cover a region of a given image with a desired color of a specified opacity.

Parameters: image - is an image or a graphics object. There is a global variable entitled "graphicsPolygon". Upon the button click it is assigned to the graphics object, the polygon with a certain color, opacity and the boundary thickness. Upon the button click this variable may be addressed everywhere in the notebook.

Sliders: The slider thickness varies the thickness of the boundary line of the polygon returned. The default thickness is 0.005 The slider opacity varies the opacity of the polygon returned. The default opacity is 0.5. The color slider enables one to choose the color to stroke. The default color is Red. The size slider only changes the size of the image during the choice of the polygon points. This size is not rsaved in the variable "graphicsPolygon", and is only used for a better visualization. The default value is 450.

Operation:

1. Evaluate the function with some image as a variable.

2. Set the image size, the polygon color, and the boundary thickness.

3. Succesively pressing Alt+Click set the locators (having appearance of circles). Adjust the locators, if necessary. Adjust the colors, opacity and the boundary thickness.

4. Press the button "Pick up the stroked Area". Done.

5. Call the variable graphicsPolygon, where necessary

Here is this function:

Clear[strokeArea];

strokeArea[image_] :=

Manipulate[
DynamicModule[{pts = {}},
Column[{
Dynamic@LocatorPane[Dynamic[pts],
Dynamic@
Show[{image,
Graphics[{color, EdgeForm[{color, Thickness[thickness]}],
Opacity[opacity], Polygon[pts]}]
}, ImageSize -> imageSize],
LocatorAutoCreate -> True,
Appearance ->
Graphics[{{color, Thickness[thickness],
Circle[{0, 0}, 0.5]}}, ImageSize -> 10]
],
Button["Pick up the stroked Area",
Clear[graphicsPolygon];
graphicsPolygon =
Graphics[{color, EdgeForm[{color, Thickness[thickness]}],
Opacity[opacity], Thickness[thickness], Polygon[pts]}];
]
}]
], Row[{Control[{{thickness, 0.005}, 0, 0.015}], Spacer[15],
Control[{color, Red}]}], Column[{
Control[{{imageSize, 450}, 300, 600}],
Row[{Spacer[12], Control[{{opacity, 0.5}, 0, 1}]}]
}],
ControlType -> {Slider, ColorSlider, VerticalSlider},
ControlPlacement -> {Top, Left}, SaveDefinitions -> True];


In principle, this function is designed for another aim. However, one may just make a copy of one of the images in the beginning of this page, say, the red arrow with a narrow tail, copy-paste it and give it a name, say imArr, and pass as a variable into the strokeArea function

strokeArea[imArr]


and execute it. Then set cursors into the necessary positions and get this

The cursors are visible as thin circles here, and the blue boundary is given in order to guide the eye, you may remove it and change parameters. Say, after you have successfully finished to built the polygon, change the color and the opacity to that you want the arrow to have.

Press the button and evaluate the variable graphicsPolygon. This brings up the desired arrow. A good idea would be also to eliminate the small errors in the boundary by applying a filter:

Image[GaussianFilter[graphicsPolygon, 3], ImageSize -> 100]
`

One finds this:

-

## protected by R. M.♦Nov 28 '12 at 5:34

Thank you for your interest in this question. Because it has attracted low-quality or spam answers that had to be removed, posting an answer now requires 10 reputation on this site (the association bonus does not count).