Skip to main content
added 2 characters in body
Source Link
Sjoerd C. de Vries
  • 66k
  • 14
  • 188
  • 324

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["https://i.sstatic.net/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]
 ]

Mathematica graphics

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]

Mathematica graphics

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 loosinglosing quality.

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

Mathematica graphics

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["https://i.sstatic.net/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]
 ]

Mathematica graphics

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]

Mathematica graphics

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, rotated, without loosing quality.

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

Mathematica graphics

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["https://i.sstatic.net/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]
 ]

Mathematica graphics

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]

Mathematica graphics

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]}]}]]

Mathematica graphics

Source Link
halirutan
  • 113.1k
  • 7
  • 263
  • 476

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["https://i.sstatic.net/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]
 ]

Mathematica graphics

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]

Mathematica graphics

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, rotated, without loosing quality.

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

Mathematica graphics