Graph flow chart

Question

I am trying to reproduce this figure using Mathematica. I am not even sure it is possible. Maybe Graph approach can be used.

Here is my starting point.

greenRed = 
  Graphics[{Rectangle[{0, 0.5}, {17, 16}], Darker@Green, 
    Table[Rectangle[{0, i}, {9, i + 1}], {i, 1, 15, 1.5}], Red, 
    Table[Rectangle[{i + 9.5, 0.5}, {i + 10.5, 16}], {i, 0, 6, 1.5}]},
    AspectRatio -> 1, PlotRangePadding -> None];

redGreen = 
  Graphics[{Rectangle[{0, 0.5}, {17, 16}], Red, 
    Table[Rectangle[{i + 0.5, 0.5}, {i + 1.5, 16}], {i, 0, 6, 1.5}], 
    Darker@Green, 
    Table[Rectangle[{8., i}, {17, i + 1}], {i, 1, 15, 1.5}]}, 
   AspectRatio -> 1, PlotRangePadding -> None];

greenGreen = 
  Graphics[{Rectangle[{0, 0.5}, {17, 16}], Darker@Green, 
    Table[Rectangle[{0, i}, {17, i + 1}], {i, 1, 15, 1.5}]}, 
   AspectRatio -> 1, PlotRangePadding -> None];

redRed = Graphics[{Rectangle[{0, 0.5}, {17, 16}], Red, 
    Table[Rectangle[{i + 0.5, 0.5}, {i + 1.5, 16}], {i, 0, 16, 1.5}]},
    AspectRatio -> 1, PlotRangePadding -> None];

red = Graphics[{Rectangle[{0, 0.5}, {17, 16}], Red, 
    Table[Rectangle[{i + 0.5, 0.5}, {i + 1.5, 16}], {i, 0, 6, 1.5}], 
    White, Rectangle[{8, 0.5}, {17, 16}]}, AspectRatio -> 1];

green = Graphics[{Rectangle[{0, 0.5}, {17, 16}], Darker@Green, 
    Table[Rectangle[{0, i}, {9, i + 1}], {i, 1, 15, 1.5}], White, 
    Rectangle[{9, 0.5}, {17, 16}]}, AspectRatio -> 1];

mat={{0, 0, 1, 1, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 1, 1, 0, 0, 0, 0}, {0, 
  0, 0, 1, 0, 1, 1, 1, 0, 0}, {0, 0, 0, 0, 1, 0, 1, 0, 1, 0}, {0, 0, 
  0, 0, 0, 1, 0, 0, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 1, 0, 1}, {0, 0, 0, 
  0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 
  0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}};
AdjacencyGraph[mat, 
 VertexShape -> {1 -> greenRed, 2 -> redGreen, 3 -> green, 4 -> red, 
   5 -> red, 6 -> green, 7 -> greenRed, 8 -> greenGreen, 9 -> redRed, 
   10 -> redGreen}, VertexSize -> 0.5]

I don't know how to plot flow lines. Any suggestion?

Answer 1

AdjacencyGraph[mat, ImagePadding -> 40, VertexSize -> 0.5, 
  VertexShape -> vshapes, EdgeLabels -> elabels, 
  VertexLabels -> vlabels, EdgeShapeFunction -> edgeshapefuncs, 
  VertexCoordinates -> vcoords, ImageSize -> 400]

where vshapes, elabels, vlabels, edshapefunctions and vcoords are defined below.

First, shapes red and green are modified to remove the white parts:

red2 = Graphics[{Red, Table[Rectangle[{i + 0.5, 0.5}, {i + 1.5, 16}], {i, 0, 6, 1.5}]}, 
   AspectRatio -> 2, Background -> Black];
green2 = Graphics[{Darker@Green, Table[Rectangle[{0, i}, {9, i + 1}], {i, 1, 15, 1.5}]}, 
   AspectRatio -> 2, Background -> Black];

vshapes = MapIndexed[#2[[1]] -> # &, {greenRed, redGreen, green2, red2, red2, 
    green2, greenRed, greenGreen, redRed, redGreen}];

Vertex and edge labels are straightforward:

vlabels = MapThread[# -> Placed[Style["percept " <> #2, 14], Above] &, 
  {{7, 8, 9, 10}, {"1", "3", "2", "4"}}];
elabels = {DirectedEdge[3, 4] -> Placed[Style["α", 20], {1/2, {1/2, 0}}], 
   DirectedEdge[4, 5] -> Placed[Style["β", 20], {1/2, {1/2, 0}}]};

We get the vertex layout by transforming GraphEmbedding[CompleteGraph[{2, 4, 4}]]:

vcoords = ScalingTransform[{-1, 1}]@
   RotationTransform[Pi/2][GraphEmbedding[CompleteGraph[{2, 4, 4}]]];
vcoords[[{1, 2}]] = ScalingTransform[{2, 1}][vcoords[[{1, 2}]]];

Finally we make edge 3 -> 6 curved to avoid edge overlaps

AdjacencyGraph[mat, ImagePadding -> 40, VertexSize -> 0.5, 
 VertexShape -> vshapes, EdgeLabels -> elabels, 
 VertexLabels -> vlabels, VertexCoordinates -> vcoords, ImageSize -> 400, 
 EdgeShapeFunction -> {DirectedEdge[3, 6] -> {"CurvedEdge", "Curvature" -> .7}}]

Getting the edge shapes and layout is manual:

ClearAll[dotArrow]
dotArrow[setback_: {.06, .06}, color_: Lighter[Blue]] := {Thickness[.01], Opacity[1], 
  color, JoinForm["Round"], (GraphElementData["DotLine"][##]/. BezierCurve->Line)  /. 
    {Arrowheads[{{a_, b_, {c_, d_}}}] :> Arrowheads[{{a, 1, {c, d}}, {-a, 0, {c, d}}}], 
     Arrow[x_] :> Arrow[x, setback]}} &

edgeshapefuncs = {_ :> (dotArrow[][{1, .95} # & /@ #[[{1, -1}]], ##2]&),
   DirectedEdge[1, 4] | DirectedEdge[2, 5] | DirectedEdge[5, 9] :> dotArrow[ {0, .12}],
   DirectedEdge[4, 5] -> (dotArrow[.06, Orange][{1, .95} # & /@ #[[{1, -1}]], ##2] &),
   DirectedEdge[3, 6] -> (dotArrow[.12, Orange][{#[[1]], {#[[1, 1]], 1.25 #[[1, 2]]}, 
      {#[[2, 1]], 1.25 #[[2, 2]]}, #[[-1]]}, ##2] &),
   DirectedEdge[3, 7] | DirectedEdge[6, 10] :> 
     (dotArrow[{0, .06}][{#[[1]], {1.5 #[[1, 1]], #[[1, 2]]}, {1.5 #[[2, 1]], #[[2, 2]]},
        {1.1, 1} #[[-1]]}, ##2] &),
   DirectedEdge[1, 3] | DirectedEdge[1,4]|DirectedEdge[2,5]|DirectedEdge[2, 6] :>       
     (dotArrow[{0, .12}][{#[[1]], {#[[2, 1]], #[[1, 2]]}, #[[-1]]}, ##2] &),
   DirectedEdge[3, 8] | DirectedEdge[5, 10] | DirectedEdge[4, 9] :> 
     (dotArrow[ {0, .12}][{{1, 1.05} #[[1]], 
        {2/3 #[[1, 1]] + 1/3 #[[-1, 1]], 1.05 #[[1, 2]]}, 
        {2/3 #[[1, 1]] + 1/3 #[[-1, 1]], #[[2, 2]]}, #[[-1]]}, ##2] &),
   DirectedEdge[4, 7] :> (dotArrow[ {0, .12}][{{1, 1.05} #[[1]], 
        {2/3 #[[1, 1]] + 1/3 #[[-1, 1]], 1.05 #[[1, 2]]},
        {2/3 #[[1, 1]] + 1/3 #[[-1, 1]],  Mean[#[[{1, -1}, 2]]]},
        {#[[2, 1]], Mean[#[[{1, -1}, 2]]]}, #[[-1]]}, ##2] &),
   DirectedEdge[6, 8] :> (dotArrow[ {0, .12}][{{1, 1.05} #[[1]],
        {5/6 #[[1, 1]] + 1/6 #[[-1, 1]], 1.05 #[[1, 2]]}, 
        {5/6 #[[1, 1]] + 1/6 #[[-1, 1]], Mean[#[[{1, -1}, 2]]]}, 
        {#[[2, 1]], Mean[#[[{1, -1}, 2]]]}, #[[-1]]}, ##2] &)};