Message Boards Message Boards

GROUPS:

Please share neural network illustrations

Posted 5 months ago
744 Views
|
4 Replies
|
19 Total Likes
|

(A version of the same/similar MSE post, which was met with a certain reluctance to be given answers.)

Please share neural networks diagrams you have made in Mathematica / WL. Here is an example:

ClearAll[a];
ns = {3, 4, 6, 4, 1};
nodes = MapIndexed[Function[{n, i}, Prepend[#, i[[1]]] & /@ Array[a, {n}]], ns];
edges = Map[Outer[Rule, #[[1]], #[[2]]] &, Partition[nodes, 2, 1]];
colors = Map[# -> ColorData[11, "ColorList"][[#[[1]]]] &, Flatten[nodes]];
Graph[Flatten[edges], VertexSize -> 0.3, VertexStyle -> colors]

enter image description here

But, here are some more examples.

The question is intentionally given with a short explanation and a link to examples. I wanted to gather some pictures of neural networks made with Mathematica/WL for a few presentations about deep learning. (Using Mathematica/WL's neural networks framework; like this one.) I was somewhat surprised that such images were not easy to find.

What I am interested are images like these:

enter image description here

enter image description here

enter image description here

4 Replies

enter image description here

A bit different function that always places vertices symmetrically:

LayersGraph[layers_]:=
Module[{
    uni=Table[Unique[],#]&/@layers,
    coor=Flatten[Table[{k,#}&/@(Range[#]-Mean[Range[#]]&/@layers)[[k]],{k,Length[layers]}],1]},
Graph[
    Flatten[uni],
    Flatten[Outer[Rule,#1,#2]&@@@Partition[uni,2,1]],
VertexCoordinates->coor,
EdgeShapeFunction->"Line",VertexSize->.3]
]

Usage that gives the image above:

LayersGraph[{2, 2, 3, 7, 2, 5, 3, 4, 1}]

A bit different version would go like:

LayersGraph[layers_]:=
Module[{
    vert=TakeList[Range[Total[layers]],layers],
    coor=Flatten[Table[{k,#}&/@(Range[#]-Mean[Range[#]]&/@layers)[[k]],{k,Length[layers]}],1]},
Graph[
    Flatten[vert],
    Flatten[Outer[Rule,#1,#2]&@@@Partition[vert,2,1]],
VertexCoordinates->coor,
EdgeShapeFunction->"Line",GraphStyle->"SmallNetwork"]
]

LayersGraph[{2, 2, 3, 7, 2, 5, 3, 4, 1}]

enter image description here

Here's a possible implementation based on the following features:

  • GraphLayout -> "MultipartiteEmbedding". Note that in practice the partitions must be specified using the syntax GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> {2,3,4}}. This takes the first two vertices as the first partition, the next 3 as the second, etc.

  • CompleteGraph[{m,n}], which creates a complete bipartite graph. This is the typical connectivity pattern between two successive layers of a NN.

We start with the number of nodes in each layer of the network:

layerCounts = {5, 3, 4, 6};

We are going to construct a complete bipartite graph for each successive pair and merge them appropriately. We will need GraphUnion, which unfortunately does not take a single argument. It wants at least two. Here's a trivial generalization so that we can also plot an NN with only two layers (i.e. made of a single bipartite complete graph):

graphUnion[g_?GraphQ] := g
graphUnion[g__?GraphQ] := GraphUnion[g]

Make the graph:

graph = GraphUnion @@ MapThread[
    IndexGraph,
    {CompleteGraph /@ Partition[layerCounts, 2, 1], 
     FoldList[Plus, 0, layerCounts[[;; -3]]]}
    ];

If you want arrowheads, change CompleteGraph to CompleteGraph[#, DirectedEdges -> True]&. Should the behaviour of this function change in the future, DirectedGraph[CompleteGraph[#], "Acyclic"] would also work.

Compute styles for each layer:

vstyle = Catenate[
  Thread /@ Thread[
    TakeList[VertexList[graph], layerCounts] -> ColorData[97] /@ Range@Length[layerCounts]
    ]
  ]

Mathematica graphics

Style the graph, and apply the multipartite layout:

graph = Graph[graph, 
  GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> layerCounts}, 
  GraphStyle -> "BasicBlack", 
  VertexSize -> 0.5,
  VertexStyle -> vstyle
]

Mathematica graphics

The same method was posted here:

For completeness, we can also add a legend:

Legended[graph,
 Placed[
  PointLegend[
   ColorData[97] /@ Range@Length[layerCounts], 
   Row[{"layer ", #}] & /@ Range@Length[layerCounts],
   LegendMarkerSize -> 30, LegendLayout -> "Row"
   ],
  Below]
 ]

Mathematica graphics

Thank you for your post! I made a function based on your code.

ClearAll[NeuralNetworkGraph]

NeuralNetworkGraph[layerCounts : {_Integer ..}] :=    
  NeuralNetworkGraph[
   AssociationThread[Row[{"layer ", #}] & /@ Range@Length[layerCounts], layerCounts]];

NeuralNetworkGraph[namedLayerCounts_Association] :=      
  Block[{graphUnion, graph, vstyle, 
    layerCounts = Values[namedLayerCounts], 
    layerCountsNames = Keys[namedLayerCounts]},
   graphUnion[g_?GraphQ] := g;
   graphUnion[g__?GraphQ] := GraphUnion[g];
   graph = 
    graphUnion @@ 
     MapThread[
      IndexGraph, {CompleteGraph /@ Partition[layerCounts, 2, 1], 
       FoldList[Plus, 0, layerCounts[[;; -3]]]}];
   vstyle = 
    Catenate[
     Thread /@ 
      Thread[TakeList[VertexList[graph], layerCounts] -> 
        ColorData[97] /@ Range@Length[layerCounts]]];
   graph = 
    Graph[graph, 
     GraphLayout -> {"MultipartiteEmbedding", 
       "VertexPartition" -> layerCounts}, GraphStyle -> "BasicBlack", 
     VertexSize -> 0.5, VertexStyle -> vstyle];
   Legended[graph, 
    Placed[PointLegend[ColorData[97] /@ Range@Length[layerCounts], 
      layerCountsNames, LegendMarkerSize -> 30, LegendLayout -> "Row"], Below]]
  ];

Here is an example:

NeuralNetworkGraph[<|"Input" -> 4, "Hidden 1" -> 5, "Hidden 2" -> 6, 
  "Hidden 3" -> 6, "Hidden 4" -> 4, "Hidden 5" -> 3, "Hidden 6" -> 5, 
  "Hidden 7" -> 8, "Hidden 8" -> 3, "Hidden 9" -> 2, "Output" -> 1|>]

enter image description here

Below is given a function definition that can be used to make a neural network plot with formulae and activation functions graphics. The code/plot can garnished some more, but at this point I find it good enough...

Clear[FormulaNeuralNetworkGraph]
FormulaNeuralNetworkGraph[layerCounts : {_Integer, _Integer, _Integer}] :=      
  Block[{gr1, gr2, gr3, gr4, gr, bc},
   gr1 = IndexGraph[CompleteGraph[Take[layerCounts, 2]]];
   gr2 = Graph[Map[(layerCounts[[1]] + #) \[UndirectedEdge] (layerCounts[[1]] + layerCounts[[2]] + #) &, Range[layerCounts[[2]]]]];
   gr3 = IndexGraph[CompleteGraph[Take[layerCounts, -2]], layerCounts[[1]] + layerCounts[[2]] + 1];
   bc = layerCounts[[1]] + 2*layerCounts[[2]];
   gr4 = Graph[Map[(bc + #) \[UndirectedEdge] (bc + layerCounts[[3]] + #) &, Range[layerCounts[[3]]]], VertexLabels -> "Name"];
   gr = GraphUnion[gr1, gr2, gr3, gr4];
   Graph[gr, 
    GraphLayout -> {"MultipartiteEmbedding", 
      "VertexPartition" -> {layerCounts[[1]], layerCounts[[2]], 
        layerCounts[[2]], layerCounts[[3]], layerCounts[[3]]}}]
   ];

Clear[FormulaNeuralNetworkGraphPlot]
Options[FormulaNeuralNetworkGraphPlot] = Options[Graphics];

FormulaNeuralNetworkGraphPlot[layerCounts : {_Integer, _Integer, _Integer}, func1_, opts : OptionsPattern[]] :=      
  FormulaNeuralNetworkGraphPlot[layerCounts, func1, # &, opts];

FormulaNeuralNetworkGraphPlot[
   layerCounts : {_Integer, _Integer, _Integer}, func1_, func2_, 
   opts : OptionsPattern[]] :=      
  Block[{plOpts, grFunc1, grFunc2, gr, vNames, vCoords, vNameToCoordsRules, edgeLines},
   plOpts = {PlotTheme -> "Default", Axes -> True, Ticks -> False, Frame -> True, FrameTicks -> False, ImageSize -> Small};
   grFunc1 = Plot[func1[x], {x, -2, 2}, Evaluate[plOpts]];
   grFunc2 = Plot[func2[x], {x, -2, 2}, Evaluate[plOpts]];

   gr = FormulaNeuralNetworkGraph[layerCounts];
   vNames = VertexList[gr];
   vCoords = VertexCoordinates /. AbsoluteOptions[gr, VertexCoordinates];
   vNameToCoordsRules = Thread[vNames -> vCoords]; 
   edgeLines = Arrow@ReplaceAll[List @@@ EdgeList[gr], vNameToCoordsRules]; 

   Graphics[{
     Arrowheads[0.02], GrayLevel[0.2], edgeLines,

     EdgeForm[Black], FaceForm[Gray], 
     Map[Disk[#, 0.04] &, vCoords[[1 ;; -layerCounts[[-1]] - 1]]],

     Black,
     Map[{EdgeForm[Gray], FaceForm[White], Disk[#, 0.14], 
        Text[Style["\[Sum]", 16, Bold], #]} &,
      Join[
       vCoords[[layerCounts[[1]] + 1 ;; layerCounts[[1]] + layerCounts[[2]]]],
       vCoords[[-2 layerCounts[[-1]] ;; -layerCounts[[-1]] - 1]]
       ]],

     Map[{EdgeForm[None], FaceForm[White], 
        Rectangle[# - {0.2, 0.15}, # + {0.2, 0.15}], 
        Inset[grFunc1, #1, Center, 0.4]} &, 
      vCoords[[ Total[layerCounts[[1 ;; 2]]] + 1 ;; Total[layerCounts[[1 ;; 2]]] + layerCounts[[2]]] ]],

     Map[{EdgeForm[None], FaceForm[White], 
        Rectangle[# - {0.2, 0.15}, # + {0.2, 0.15}], 
        Inset[grFunc2, #1, Center, 0.4]} &, 
      MapThread[Mean@*List, {vCoords[[-2 layerCounts[[-1]] ;; -layerCounts[[-1]] - 1]], vCoords[[-layerCounts[[-1]] ;; -1]]}]]}, 
    opts]
   ];

Note that the function FormulaNeuralNetworkGraphPlot takes the potions of Graphics.

 FormulaNeuralNetworkGraphPlot[{5, 9, 6}, Tanh, #^3 &,  ImageSize -> 500]

enter image description here

(I tried to reuse as much as I can the code from the answer of Szabolcs. I had to move to using Graphics because I had hard time insetting the activation functions plots using the multi-partite graph options.)

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract