13
$\begingroup$

I want to draw this shape in Mathematica. I don't know what to start with. Can I use BezierCurve? Or should I try to form an equation that could end up in this shape?

Enter image description here

$\endgroup$
12
  • 3
    $\begingroup$ Which details are important in this shape? The thickness? The arrows? The red? What format do you need? Are you trying to produce an image? Would it be okay to build a tree or graph and just plot it? $\endgroup$
    – lericr
    Nov 30, 2022 at 13:37
  • 1
    $\begingroup$ I think since the user mentioned Bezier curves they would like practically the same image but with the lines straightened and a more symmetric figure that looks as close as possible to the drawing. $\endgroup$ Nov 30, 2022 at 13:41
  • 1
    $\begingroup$ Yes, use BezierCurve, as it essentially allows you to specify the tangent at the endpoints, and you want a vertical tangent at both endpoints and branching points. Please try to make the question a bit more concrete: ideally show what you tried with BezierCurve, but at a minimum give some example data that should be used to construct the graphics. How do you represent this tree? When you tagged the question graphs-and-networks, did you mean to indicate that you are looking to work wit Graph? I am asking because this tag is often misused to mean "graphs" = "plots". $\endgroup$
    – Szabolcs
    Nov 30, 2022 at 14:08
  • 2
    $\begingroup$ If you are looking to work with Graph, it may be useful for you to look at the last example here: szhorvat.net/mathematica/IGDocumentation/… It's not the same, but it creates edges with similar shapes and shows how one may define an edge shape using BezierCurve. $\endgroup$
    – Szabolcs
    Nov 30, 2022 at 14:11
  • 2
    $\begingroup$ The shape resembles a Sankey diagram. Maybe the answers in this question can help. $\endgroup$ Nov 30, 2022 at 14:22

4 Answers 4

18
$\begingroup$

A spline solution:

    Module[{th, rl, ll, pts, join, liquid}, th = 20;
 rl = {{0, -1}, {0, 0}, {0, 2/3}, {1/2, 1}, {1, 4/3}, {1, 2}};
 ll = {{2, -1}, {2, 0}, {2, 2/3}, {3/2, 1}, {1, 4/3}, {1, 2}};
 pts = {Flatten[{rl, {1, 3} + # & /@ rl, {2, 6} + # & /@ 
      rl, {{3, 8}}}, 1], ll, 
   Flatten[{{{3, -1}, {3, 0}}, {1, 3} + # & /@ ll}, 1], 
   Flatten[{{{4, -1}, {4, 4}}, {2, 6} + # & /@ ll}, 1]};
 liquid = {{{0, -1}, {0, -.5}}, {{2, -1}, {2, -.5}}, 
{{3, -1}, {3,-.5}}, {{4, -1}, {4, -.5}}};
 Graphics[{AbsoluteThickness[th], BSplineCurve /@ pts, White, 
   AbsoluteThickness[th - 1], 
   BSplineCurve /@ Evaluate[pts /. 8 -> 8.02], Black,
   AbsoluteThickness[th], BSplineCurve /@ liquid, Lighter[Red, .75], 
   AbsoluteThickness[th - 1], 
   BSplineCurve /@ Evaluate[liquid /. -.5 -> -.48], Black, 
   AbsoluteThickness[1], Opacity[.25],
   Arrowheads[.075], Dashed, 
   Arrow[BSplineCurve[#]] & /@ {{1, 3} + # & /@ 
      Reverse@Rest@rl, {1, 3} + # & /@ Reverse@Rest@ll, {2, 6} + # & /@
       Reverse@Rest@rl, {2, 6} + # & /@ Reverse@Rest@ll, 
     Reverse@Rest@rl, Reverse@Rest@ll},
   Opacity[1], Dashing[None], Line[{{-.5, -1.21}, {4.5, -1.21}}]
   }
  ]]

This was just built from basic building block:

Module[{pts = {{0, 0}, {0, 2/3}, {1/2, 1}, {1, 4/3}, {1, 2}}}, 
 Graphics[{BSplineCurve[pts], Green, Line[pts], Red, Point[pts]}]]
$\endgroup$
6
  • $\begingroup$ Very nice. How do you find the points for the BSplineCurve ? $\endgroup$ Dec 1, 2022 at 10:35
  • 1
    $\begingroup$ @userrandrand please see update $\endgroup$
    – martin
    Dec 1, 2022 at 11:08
  • 1
    $\begingroup$ @userrandrand you can play around with DynamicModule[{pts = {{0, 0}, {1, 1}, {2, -1}, {3, 0}, {4, -2}, {5, 1}}}, LocatorPane[Dynamic[pts], Dynamic[Graphics[{BSplineCurve[pts], Green, Line[pts], Red, Point[pts]}]], Appearance -> None]] to get a feel of it $\endgroup$
    – martin
    Dec 1, 2022 at 11:43
  • 1
    $\begingroup$ Thank you very much for your help . I got a better idea of the main properties such as collinear points stay collinear, the endpoints do whatever you ask and the middle points follow lazily. I also realized that I could maybe just construct an outline of the figure with Line and then maybe /.Line->BsplineCurve. Maybe I can use this to smooth pixeled letters for a toy OCR project I have . Thank you again and very neat addition to the figure . $\endgroup$ Dec 1, 2022 at 11:58
  • 1
    $\begingroup$ Thank you very much. You made it look so easy. $\endgroup$
    – user444
    Dec 2, 2022 at 11:24
14
$\begingroup$

Outline

  • Gallery

  • Method 1 : TreePlot with EdgeShapeFunction

straightfoward to use

  • Method 2: Stack parametric plots

Interactive, can be tedious or like a game

  • Method 3: Nested shifts and line rewiring

easy to use black box function with customization

  • Appendix

Gallery

  • Method 1 : TreePlot with EdgeShapeFunction

Note : There are small imperfections from edge corners near the vertices.

enter image description here

  • Method 2: Stack parametric plots

enter image description here

  • Method 3: Nested shifts and line rewiring

enter image description here


Method 1 : TreePlot with EdgeShapeFunction

Drawback : The edges can not be extracted without involving image processing and so the inner part of the pipes have to be colored. An explanation of how to obtain the edges via image processing is given in the appendix.

In the first subsection of the Applications section in the documentation for BezierCurves there is the following edge shape function:

bezieredge = 
  Function[{pts}, 
   BezierCurve[{pts[[
      1]], {pts[[1, 1]], (pts[[1, 2]] + 2 pts[[2, 2]])/3}, {pts[[2, 
       1]], (2 pts[[1, 2]] + pts[[2, 2]])/3}, pts[[2]]}]];

Thickening the lines, increasing the opacity, adding DropShadowing (new in version 13.1) for some "edge" and including the previous edge shape function (the w labels are arbitrary):

TreePlot[
 Tree[w, {Tree[w, {Tree[w, {Tree[w, {w}]}], Tree[w, {Tree[w, {w}]}]}],
     Tree[w, {w}], Tree[w, {w}]}] // TreeGraph, 
 EdgeShapeFunction -> bezieredge, 
 EdgeStyle -> 
  Directive[Thickness[0.05], Opacity[1], Black, 
   DropShadowing[{-3, 3}, 5, RGBColor[0.300725, 0.680491, 0.901701]]],
  VertexLabels -> None, VertexShape -> None]

Method 2: Stack parametric plots

Drawback : Interactive not algorithmic

The following is an incomplete answer. It is a tedious task of lego packing Tanh curves. It could be kind of soothing or amusing to play with but it's not a quick algorithm. Although I did not use Manipulate to find the parameters below, a code to use Manipulate is provided in the appendix.

plot1 = ParametricPlot[{{Tanh[x], x}, {-Tanh[x], x}}, {x, -10, 0}, 
   Axes -> False, PlotStyle -> Orange];

plot2 = ParametricPlot[{{Tanh[x] - 4, x}, {4 - Tanh[x], x}}, {x, -10, 
    3}, Axes -> False, PlotStyle -> Orange];

plot3 = ParametricPlot[{Tanh[x] - 2, x + 13}, {x, -10, 3}, 
   Axes -> False, PlotStyle -> Orange];

  plot4 = ParametricPlot[{2*Tanh[x] + 5, x + 13}, {x, -10, 0}, 
   Axes -> False, PlotStyle -> Orange];

plot5 = ParametricPlot[{5 - 2*Tanh[x], x + 13}, {x, -23, 0}, 
   Axes -> False, PlotStyle -> Orange];

plot6 = ParametricPlot[{10 - Tanh[x], x + 13}, {x, -23, 3}, 
   Axes -> False, PlotStyle -> Orange];

Show[{plot3, plot2, plot1, plot4, plot5, plot6}, PlotRange -> All]

enter image description here


Method 3: Nested shifts and line rewiring

Drawback: the code can only generate nested iterations of the tree structure given in the question.

The plots in the gallery above can be made easily with the code below. As examples:

The straight lines can be obtained with (code definitions below)

node // nestAddnode[2] //Graphics

where n=2 represents the number of recursions performed by nestAddnode. Increasing the number of recursions increases the number of nodes in the graph. Curved lines can be obtained with:

node // nestAddnode[2]// ReplaceAll[Line -> BSplineCurve] //Graphics

node above is a list of lines with the following graphical representation:

image

Other types of nodes made of three lines with three openings of equal width might also work if the lines are given as {Line[{pts1}],Line[{pts2}],Line[{pts3}]} with pts a list of points (not segments of points such as {{ptsa,ptsb},{ptsc,ptsd}). The points in the lines also have to be ordered according to the image below:

label[label_, point_] := 
  Sequence @@ ({Text[Style[label, Medium], # + 0.2], Point@#} &@
     point);

{node, Red, PointSize@Large, label["start", node[[1, 1, 1]]], 
  label["end", node[[1, 1, -1]]], label["start", node[[2, 1, 1]]], 
  label["end", node[[2, 1, -1]]], label["start", node[[3, 1, 1]]], 
  label["end", node[[3, 1, -1]]]} // Graphics

enter image description here

The method of constructing the tree consists of recursively shifting the node in the image above to the lower left of the tree, rewiring lines to make extended lines rather than line segments and extending vertical lines. The reason for rewiring the lines rather than keeping segments of lines is that it allows transforming straight lines to curves using a replacement rule like Line->BSplineCurve for example.

Other than BSplineCurve, the image in the gallery used the following resource functions as options to make curves:

code

code to make node :

Note: …=[Ellipsis]

path1 = AnglePath[{Pi/4, -Pi/4, -Pi/4}];
Clear[pt1, pt2];
{pt1, pt2} = {path1[[1]] - {1/2, 0}, path1[[-1]] + {1/2, 0}};
tsol = Min@
   SolveValues[
    Norm[pt1 + \[FormalT]*{Cos[Pi/4], 
         Sin[Pi/4]} - (pt2 + \[FormalT]*{-Cos[Pi/4], Sin[Pi/4]})] == 
     1/2, \[FormalT], Reals];
vertical…edge…height = {0, 1};
node = {Line[{pt1 - vertical…edge…height, pt1, 
     pt1 + tsol*{Cos[Pi/4], Sin[Pi/4]}, 
     pt1 + tsol*{Cos[Pi/4], Sin[Pi/4]} + 
      vertical…edge…height}], 
   Line@Join[{path1[[1]] - vertical…edge…height}, 
     path1, {path1[[-1]] - vertical…edge…height}],
    Line[{pt2 + tsol*{-Cos[Pi/4], Sin[Pi/4]} + 
      vertical…edge…height, 
     pt2 + tsol*{-Cos[Pi/4], Sin[Pi/4]}, pt2, 
     pt2 - vertical…edge…height}]};

Code that adds node to a tree of nodes:

Clear[addLeft];

addLeft[tree_,node_]:=
Module[{shifted…node},
shifted…node=
Map[#-First@Extract[tree,{{1,1,-1},{-1,1,1}}]+First@Extract[tree,{{1,1,1},{2,1,1}}]&,
    node,
    {3}]
;

{
Join[shifted…node[[1]],
    tree[[1]],
    2]
,

shifted…node[[2]]
,

Join[Reverse/@shifted…node[[3]],
    tree[[2]],
    Line[{tree[[2,1,-1]],
        tree[[2,1,-1]]+{0,-tree[[2,1,-1,-1]]+shifted…node[[1,1,1,2]]}}
    ]
    ,2]
,

(* extend other columns *)
Sequence@@Table[    
        Join[
        Line[{
            tree[[m,1,1]]+{0,-tree[[m,1,1,-1]]+shifted…node[[1,1,1,-1]]}
            ,
            tree[[m,1,1]]}
        ]
        ,
        tree[[m]]
        ,
        Line[{tree[[m,1,-1]],
            tree[[m,1,-1]]+{0,-tree[[m,1,-1,-1]]+shifted…node[[1,1,1,-1]]}}
        ],
        2],
        {m,3,Length@tree-1}]
,
Join[       
    tree[[-1]]
    ,
    Line[{tree[[-1,1,-1]],
        tree[[-1,1,-1]]+{0,-tree[[-1,1,-1,-1]]+shifted…node[[1,1,1,-1]]}
        }
    ]
,
2]
}
]

Nested application of addLeft :

nestAddnode[n_][node_] := Nest[addLeft[#, node] &, node, n];

code to use optional random coloring as in the plots above:

Clear[colorize];
colorize := 
  Riffle[Thread@Hue[RandomReal[] + Subdivide[Length@#]], #] &; 

code to use optional resource function customizations:

spline[pts_] := 
 ParametricPlot[ResourceFunction["AkimaSpline"][pts][t], {t, 0, 1}, 
  Axes -> False]


spline2[pts_, d__] := 
 ParametricPlot[
  ResourceFunction["CurveToBSplineFunction"][pts, d][t], {t, 0, 1}, 
  Axes -> False]

showSpline[node_] := 
  node /. Line[s_] :> spline[N@DeleteDuplicates@Simplify@s] // 
   Show[#, PlotRange -> All] &;

showSpline2[node_, d__] := 
  node /. Line[s_] :> spline2[N@DeleteDuplicates@Simplify@s, d] // 
   Show[#, PlotRange -> All] &;

    showSpline3[node_, d__] := 
  node /. Line[s_] :> 
    ResourceFunction["RoundedLine"][N@DeleteDuplicates@Simplify@s, d];

The image in the gallery was produced with :

Note : Uses resource function ResourceFunction["NearEqualPartition"] in code below.

node // nestAddnode[2] // {Graphics, 
     ReplaceAll[Line -> BSplineCurve]/*colorize/*Graphics, 
     showSpline, (showSpline3[#, 0.7] &)/*colorize/*Graphics, 
     showSpline2[#, 2, 0.5] &} // Through // 
  ResourceFunction["NearEqualPartition"][#, 2] & // GraphicsGrid

Appendix

The edges from the treeplot can be obtained via image processing. To increase quality of the final image, the image is also remade into a graphics objects. That last step can lead to errors but it the errors seem minor in the image below:

The plot given above with different parameters :

plot=TreePlot[
  Tree[w, {Tree[
      w, {Tree[w, {Tree[w, {w}]}], Tree[w, {Tree[w, {w}]}]}], 
     Tree[w, {w}], Tree[w, {w}]}] // TreeGraph, 
  EdgeShapeFunction -> bezieredge, 
  EdgeStyle -> Directive[Thickness[0.1], Opacity[1], Black], 
  VertexLabels -> None, VertexShape -> None];

Image from plot:

im = Image@plot;

obtaining the edge from the branches:

im2 = im // ImageData // Part[#, All, All, 4] & // Image // 
MorphologicalPerimeter // Dilation[#, 2] & // ColorNegate

Turn the image back to a graphics object:

im2 // ImageGraphics;

im3

  • Method 2: Stack parametric plots

Code to use Manipulate

I did not use Manipulate to obtain the parameters above I just guessed based on what I expected from scaling and shifting step by step. If you would like a more interactive approach I left a code to use Manipulate below

With the parameter choices below initially the curves are super imposed. I would recommend starting small with just 1 or 2 curves and using some of the parameter choices above.

The curve function. To produce quicker plots I reduced the number of points. You can take default options for the plot once your find the parameter choice.

    Clear[plot]; 
plot[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ, e_?NumericQ, 
  f_?NumericQ] := 
 ParametricPlot[{a + b*Tanh[x], c*x + d}, {x, e, f}, Axes -> False, 
  PlotStyle -> Orange, PerformanceGoal -> "Speed", PlotPoints -> 30, 
  MaxRecursion -> 0]

Ranges for parameters a,b,c,d,e. splice should be undefined and will be used in a replacement rule later. The syntax is splice[min,max] where min and max represent the minimal and maximal value of the parameter:

arange = splice[0, 10]; brange = splice[-5, 5]; crange = 
 splice[-2, 2]; drange = splice[0, 15]; erange = splice[-30, 0];
frange = splice[0, 5];

The manipulate function (Note that you might need to enlarge the image):

  • n below is the number of curves

  • the comment below is to keep track of the meaning of the variables on the controllers by giving the plot command for the first curve. The syntax is v[1,1]=a in the expression for plot, v[1,2]=b,v[1,3]=c,v[1,4]=d,v[1,5]=e,v[1,6]=f,v[2,1]=a,v[2,2]=b,etc

  • click the plus sign next to each controller to enter values

the code:

n = 2;
Manipulate[
 Evaluate@
  Quiet@Show[plot @@@ Array[v, {n, 6}], ImageSize -> Small, 
    PlotRange -> All], 
 Transpose[{#, {arange, brange, crange, drange, erange, frange}}] & /@
       Array[v, {n, 6}] /. splice -> Sequence // Catenate // 
   Apply[Sequence] // Evaluate, DefaultLabelStyle -> Orange, 
 Paneled -> False, ControlPlacement -> Left]

(* {v[1,1]+v[1,2]*Tanh[x],v[1,3]*x+v[1,4]},{x,v[1,5],v[1,6]} *)
$\endgroup$
1
  • 2
    $\begingroup$ Thank you very much $\endgroup$
    – user444
    Dec 1, 2022 at 4:29
12
$\begingroup$

A couple of years ago, I wrote a (somewhat general) function to make Sankey diagrams. The top-level function (parseSankeyAssociation) doesn't seem to work out of the box for this use-case, but we can achieve a fairly decent result using the sankeyRibbonGraphics function defined at the bottom of the answer.

With[{length=10,col=Black,width=2.5},
{
sankeyRibbonGraphics[{{{0,-3},{0,-2}},{{length,-1},{length,0}}},col,width],
sankeyRibbonGraphics[{{{length,-1},{length,0}},{{2length,-1},{2length,0}}},col,width],
sankeyRibbonGraphics[{{{2length,-1},{2length,0}},{{3length,-1},{3length,0}}},col,width],
sankeyRibbonGraphics[{{{0,-3},{0,-2}},{{length,-5},{length,-4}}},col,width],
sankeyRibbonGraphics[{{{length,-5},{length,-4}},{{2length,-3},{2length,-2}}},col,width],
sankeyRibbonGraphics[{{{length,-5},{length,-4}},{{2length,-7},{2length,-6}}},col,width],
sankeyRibbonGraphics[{{{2length,-3},{2length,-2}},{{3length,-3},{3length,-2}}},col,width],
sankeyRibbonGraphics[{{{2length,-7},{2length,-6}},{{3length,-5},{3length,-4}}},col,width],
sankeyRibbonGraphics[{{{2length,-7},{2length,-6}},{{3length,-9},{3length,-8}}},col,width]
}//Graphics
]

Note, this uses the excellent answer here on using ParametricPlot to make constant-thickness (or in-fact varying-thickness) ribbons.

enter image description here

Edit:

For self-completeness here's the necessary minified code (Note I swapped the colDirective option to affect BoundaryStyle instead of PlotStyle to get the outlines. See edit history if you prefer the filled output)

thickness[f_,th_]:=Block[{x},{x,f}+Normalize[{-D[f,x],1}] th]
sankeyRibbonFunction[{{sourceMin_,sourceMax_},{targetMin_,targetMax_}},width_:10]:=With[{sourceCentroid=Last@Mean[{sourceMin,sourceMax}],targetCentroid=Last@Mean[{targetMin,targetMax}],midpoint=First@Mean[{sourceMin,targetMin}]},(targetCentroid-sourceCentroid)/(1+E^(-width (-midpoint+x)))+sourceCentroid]
sankeyRibbonGraphics[{{sourceMin_,sourceMax_},{targetMin_,targetMax_}},colDirective_,width_:10]:=With[{heightSource=Last[sourceMax-sourceMin]/2,heightTarget=Last[targetMax-targetMin]/2},First[ParametricPlot[Evaluate@thickness[sankeyRibbonFunction[{{sourceMin,sourceMax},{targetMin,targetMax}},width],If[heightSource==heightTarget,heightSource t,heightSource t+(heightTarget-heightSource) t LogisticSigmoid[width (x-(First[sourceMin]+First[targetMin])/2)]]],{x,First[sourceMin],First[targetMin]},{t,-1,1},PlotPoints->{25,3},MaxRecursion->4,Mesh->None,BoundaryStyle->colDirective,PlotStyle->None]]]
$\endgroup$
5
  • 2
    $\begingroup$ Nice I was able to remove the lines inside the diagram with image processing by defining g to be the diagram and using ImageMeasurements[FillingTransform[ColorNegate@Image@g], "Contours"] // Graphics but as expected that introduces pixelization error i.stack.imgur.com/cIGQJ.png . Nice function $\endgroup$ Nov 30, 2022 at 20:26
  • 2
    $\begingroup$ Graphics[MeshPrimitives[BoundaryDiscretizeGraphics[...], 1]] also seems to work reasonably well, where ... is the filled graphics output using BoundaryStyle -> None, PlotStyle -> colDirective in the sankeyRibbonGraphics function $\endgroup$ Nov 30, 2022 at 20:42
  • 1
    $\begingroup$ Oh that's how you get BoundaryDiscretizeGraphics to work. I tried that initially and got an error. Thanks for the nice trick that might come in handy later $\endgroup$ Nov 30, 2022 at 20:51
  • 1
    $\begingroup$ This is wonderful. Truly. I just want to know one more thing. How can I make the branching portion smoother? Would increasing mech do the trick? $\endgroup$
    – user444
    Dec 1, 2022 at 4:27
  • 1
    $\begingroup$ Increasing m in PlotPoints->{m,3} should do it. The second dimension is for the thickness which at-most varies linearly so a low number suffices $\endgroup$ Dec 1, 2022 at 4:36
10
$\begingroup$

Use Translate with multiples of 3 along x-axis and multiples of 4 along y-axis to move objects o1 and o2.

o1 = {Line[{{0, 0}, {0, 1}}], Line[{{1, 0}, {1, 1}}], 
   Circle[{2, 0}, 2, {π + ArcTan[Sqrt[7]/3], π + π/2}], 
   Circle[{2, 0}, 1, {π, π + π/2}], 
   Circle[{2, -3}, 2, {0, 0 + π/2}], 
   Circle[{2, -3}, 1, {0, 0 + π/2}], 
   Circle[{2 - 3, 0}, 
    2, {3/2 π, 3/2 π + π/2 - ArcTan[Sqrt[7]/3]}], 
   Circle[{2 - 3, 0}, 1, {3/2 π, 3/2 π + π/2}], 
   Circle[{2 - 3, -3}, 2, {π/2, π/2 + π/2}], 
   Circle[{2 - 3, -3}, 1, {π/2, π/2 + π/2}]};

o2 = {Line[{{0, 1}, {0, 5}}], Line[{{1, 1}, {1, 5}}]};

Graphics[{o1, Translate[o1, {-3, -4}], Translate[o1, {-6, -8}], 
  Translate[o2, {3, -8}], Translate[o2, {3, -12}], 
  Translate[o2, {0, -12}], Translate[o2, {-9, -16}], 
  Translate[o2, {-3, -16}], Translate[o2, {0, -16}], 
  Translate[o2, {3, -16}]}]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you. It's simple and efficient $\endgroup$
    – user444
    Dec 1, 2022 at 4:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.