# How to create a representation of a multilayered neural network from scratch using Graph?

One valid way is given at the end.

I thought CompleteGraph[{2, 3, 3, 1}] would create the representation that I wanted but it creates too many edges (from the first layer to the third layer, etc). Instead of that, this works:

q = {2, 3, 3, 1};
Range[#1, #2] &, {Prepend[Most[Accumulate[q]], 0] + 1,
Accumulate[q]}];
qp = Flatten@
Map[UndirectedEdge @@@ # &][Tuples /@ Partition[qf, 2, 1]];
Graph[qp]


But it only works for very simple layers. For example,

q = {2, 3, 5, 8, 1};
...


creates a graph that is clustered rather than layered. One could give options to Graph, such as

Graph[qp,
GraphLayout -> {"LayeredDigraphEmbedding", "Orientation" -> Left}]


but for some reason, one of the nodes from the two of the first layer is arranged so as to be not in the first layer. So I don't know how to specify the method for specific GraphLayouts.

I could also not guide "MultipartiteEmbedding" into the correct behavior

Graph[qp,
GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> q}


because the layout confuses the layers due to the given ordering of qp (places a node from the first layer on the second, and a node from the second on the first).

This works:

q = {2, 3, 5, 8, 1};
Range[#1 + 1, #2] &, {Prepend[Most[Accumulate[q]], 0],
Accumulate[q]}];
qp = Flatten@
Map[UndirectedEdge @@@ # &][Tuples /@ Partition[qf, 2, 1]];
qc = GraphEmbedding[CompleteGraph[q]];
Graph[qp, VertexCoordinates -> Map[# -> qc[[#]] &, Range[Total[q]]]]


I started playing around with neural nets so I wanted a clean representation of one to have as a map on the side.

Is there a function or option specifically for this? Are there other ways of doing this? Thanks for the tips.

Use the option GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> q} and use the first argument of Graph to provide the list of vertices

Graph[Range[Total@q], qp,
GraphLayout -> {"MultipartiteEmbedding", "VertexPartition" -> q}] You can also delete unwanted edges from CompleteGraph[q]:

EdgeDelete[#,  a_ <-> b_ /; Abs[Subtract @@ GraphEmbedding[#][[{a, b}, 1]]] > 1] & @
CompleteGraph[q] 