Neural network illustrations

Question

(Since this post was met with a certain reluctance to be given answers, a version of it is also posted in Community.)

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]

But, here are some more examples.

Update

Addressing the concerns in the comments...

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 for a few presentations about deep learning. (Like this Mathematica-vs-R over deep learning presentation.) I was somewhat surprised that such images were not easy to find.

What I am interested in are images like these:

Answer 1

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 be 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 options of Graphics.

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

(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.)

Answer 2

The key is GraphLayout -> "MultipartiteEmbedding".

layerCounts = {5, 3, 3, 8, 2};

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
  ]

This won't work for only two layers because GraphUnion is being unreasonable when given a single argument. You can complain to WRI support about that, or implement a workaround.

Answer 3

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

Answer 4

Using CompleteGraph with a list of layer sizes as input and deleting edges that connect non-consecutive layers:

ClearAll[layeredNW]
layeredNW[layers : {__}, opts : OptionsPattern[Graph]] := Module[{cg = 
    CompleteGraph[layers, DirectedEdges -> True]}, 
  SetProperty[EdgeDelete[cg, DirectedEdge[a_, b_] /; 
     (Subtract @@ (PropertyValue[{cg, #} , VertexCoordinates][[1]] & /@ {b, a}) > 1)], 
   {PerformanceGoal -> "Quality", VertexSize -> .5, VertexStyle -> White, 
    EdgeStyle -> Black, VertexCoordinates -> GraphEmbedding[cg], opts}]]

Example:

layers = {2, 5, 2, 3, 1, 3, 4, 1};
colors = Flatten[MapThread[ConstantArray,
      {ColorData[63, "ColorList"][[;; Length@layers]], layers}]];

layeredNW[layers, VertexStyle -> {i_ :> colors[[i]]}, ImageSize -> Large, VertexSize -> .3]

Stress-test

layers = {2, 5, 2, 3, 1, 3, 4, 1}*5;
colors = Flatten[
   MapThread[
    ConstantArray, {ColorData[63, "ColorList"][[;; Length@layers]], 
     layers}]];

layeredNW[layers, VertexStyle -> {i_ :> colors[[i]]}, 
 ImageSize -> Large, VertexSize -> .7, ImageSize -> 1600]

Answer 5

I'm not sure that the code is clean, but once I had to make a graph that has a fixed size in all layers (except those with one node). I put it as is just for diversity reasons, may be it will inspire somebody.

nList = {2, 7, 9, 1}; (* nodes by layers *)

Main functions:

nEmbed[nList_List] := Module[{list, nRagged, ragged},
   nRagged[list_List] := 
    Internal`PartitionRagged[Range[Total@list], list];
   ragged = nRagged[nList];
   
   (* returns flatten join of all 'matrixes of connections' between \
layers *)
   
   Flatten@(Outer[Rule, Sequence @@ #] & /@ 
      Table[ragged[[i]], {i, Partition[Range[Length@nList], 2, 1]}])
   ];


nCoord [nList_List] := 
  Module[{list, nRagged, ragged, coordy, coordx, k = 3}, 
   nRagged[list_List] := 
    Internal`PartitionRagged[Range[Total@list], list];
   ragged = nRagged[nList];
   
   (* coordy reflects vertical layout, 
   coordx uses the same function but can be corrected with k *)
   
   coordy[rag_List /; Length[rag] == 1] := {5.};
   coordy[rag_List /; Length[rag] > 1] := 
    Table[i N[10./(Length[rag] - 1), 2], {i, 0, Length[rag] - 1}];
   coordx = coordy;
   
   (* coordx applies to the layers (and so nodes), 
   but coordy applies to nodes in respective layers *)
   
   Thread[Range[Total@nList] -> 
     Flatten[(Thread /@ Thread[{k (coordx @ #), coordy /@ #}] &) @ 
       ragged, 1]]
   ];

Usage:

Graph[nEmbed[#], VertexCoordinates -> nCoord[#], 
   VertexLabels -> "Name",
   VertexSize -> 0.3,
   EdgeShapeFunction -> "Line",
   ImageSize -> Large] &@ nList

For some sort of stress-test with nList = {8, 17, 19, 6, 4, 3};.