How to create Diagrams using Wolfram / Mathematica?

Question

How can one use Wolfram to make diagrams like

with the arrows labeled as well (to label "mediating factors" between the causal elements)?

kglr · Accepted Answer

vertices = {"rush hour", "bad weather", "accident", "traffic jam", "sirens"};

edges = DirectedEdge @@@ {"rush hour" -> "traffic jam", "bad weather" -> "accident", 
      "accident" -> "traffic jam", "bad weather" -> "traffic jam", 
      "accident" -> "sirens"};

edgelabels = RandomWord["Noun", Length @ edges];

Graph[edges, 
 PlotTheme -> "IndexLabeled", 
 VertexSize -> Large, 
 EdgeLabels -> Thread[edges -> edgelabels]]

Use additional options to embellish the picture:

elabeling = AssociationThread[edges, edgelabels];

eSF = {Arrowheads[{{.04, .75}, 
    {.05, .45, Graphics @ Text[Framed[Style[elabeling @ #2, 14],
      FrameStyle -> None,  Background -> White]]}}], 
    Last @ GraphElementData["Arrow"][##]} &;

coords = Drop[Join @@ Array[{ #2, (3 - #)}&, {2, 3}], {4}]

Graph[vertices, edges, 
 VertexLabelStyle -> 14, 
 ImageSize -> Large, 
 GraphStyle -> "IndexLabeled", 
 VertexSize -> .4, 
 EdgeShapeFunction -> eSF, 
 VertexCoordinates -> coords]

We can also construct the graphics primitives from scratch:

radius = Offset @  Max[(1.2/2) 
    Rasterize[Style[#, 14, "Graphics"], "RasterSize"][[1]] & /@ vertices];

Graphics[{{Arrowheads[{{.02, .75}, {.05, .45, 
        Graphics @Text[Framed[Style[elabeling @ #, 14], FrameStyle -> None, 
           Background -> White], {0, 0}, {0, .25}]}}], 
     Arrow[List @@ # /. Thread[vertices -> coords]]} & /@ edges, 
  FaceForm[White], EdgeForm[Gray], Disk[#, radius] & /@ coords, 
  MapThread[Text, {Style[#, 16] & /@ vertices, coords}]}, 
 ImageSize -> 800, PlotRangePadding -> Scaled[.2]]

Update: From comments: "Ideally a user just supplies a list of relationships (with possible labels)..."

elist = {{"rush hour" -> "traffic jam",  "empty"}, 
 {"bad weather" -> "accident", "canyon"}, 
 {"accident" -> "traffic jam", "sweatshirt"}, 
 {"bad weather" -> "traffic jam", "pump"}, 
 {"accident" -> "sirens", "nominative"}};

You can use GraphComputation`LayeredGraphPlotLegacy or GraphComputation`GraphPlotLegacy (if you have access to versions before v12 you can use LayeredGraphPlot and GraphPlot, respectively):

GraphComputation`LayeredGraphPlotLegacy[elist,  
 DirectedEdges -> True, EdgeLabeling -> True, VertexLabeling -> True, 
 ImageSize -> 500, BaseStyle -> 15, PlotStyle -> Black]

GraphComputation`GraphPlotLegacy[elist,  
 DirectedEdges -> True, EdgeLabeling -> True, VertexLabeling -> True, 
 ImageSize -> 500, BaseStyle -> 15, PlotStyle -> Black,
 Method -> "LayeredDigraphDrawing"]

same picture

To render vertices as disks add the option

VertexRenderingFunction -> ({White, EdgeForm[Black], Disk[#, .3], Black, Text[#2, #1]} &)

to get

Nasser · Answer

r = 1; (*radius of each disk*)

(*center of each disk. Numbers left to right, top to bottom*)
c1 = {0, 0}; c2 = {r + 2, 0}; c3 = {r + 5, 0}; c4 = {r + 2, -(r + 2)}; 
c5 = {r + 5, -(r + 2)};

makeDisk[r_, c_] := {EdgeForm[Black],LightYellow, Disk[c, r]}(*change as needed*)

makeArrow[from_, to_, dir_] := Module[{z = Cos[Pi/4]},
   Which[
    dir == "right", 
    Arrow[{{from[[1]] + r, from[[2]]}, {to[[1]] - r, to[[2]]}}],

dir == "down", 
    Arrow[{{from[[1]], from[[2]] - r}, {to[[1]], to[[2]] + r}}],

dir == "right-down", 
    Arrow[{{from[[1]] + z, from[[2]] - z}, {to[[1]] - z, to[[2]] + z}}],

dir == "left-down", 
    Arrow[{{from[[1]] - z, from[[2]] - z}, {to[[1]] + z, to[[2]] + z}}]

]
   ];
putLabel[txt_, at_] := Style[Text[txt, at], Bold, 12]
Graphics[{
  makeDisk[1, c1],
  makeDisk[1, c2],
  makeDisk[1, c3],
  makeDisk[1, c4],
  makeDisk[1, c5],
  makeArrow[c2, c3, "right"],
  makeArrow[c2, c4, "down"],
  makeArrow[c3, c5, "down"],
  makeArrow[c1, c4, "right-down"],
  makeArrow[c3, c4, "left-down"],
  putLabel["rush hour", c1],
  putLabel["bad weather", c2],
  putLabel["accident", c3],
  putLabel["traffic jam", c4],
  putLabel["siren", c5]
  }, Axes -> False]

How to create Diagrams using Wolfram / Mathematica?

2 Answers

Add your own answers!

Ask a Question