Constructing multigraph from vertex list

Question

Given a list of vertices, with each vertex containing an edge list:

vertices = {{"foo","3","bar"},{"3","bar"},{"foo"}}

How can I construct a multigraph where each unique string in the input is an edge, connecting the two vertices containing that edge? The following almost works, but restricts the graph to single edges:

RelationGraph[(ContainsAny[#1,#2] && #1!=#2)&, vertices]

The actual names of the edges in the output isn't important, just the topology of the graph.

Answer 1

You can construct an adjacency matrix using Outer with Length @* Intersection as the first argument and use it with AdjacencyGraph:

am = Outer[Length @* Intersection, vertices, vertices, 1];
AdjacencyGraph[vertices, am - DiagonalMatrix[Diagonal[am]],
 DirectedEdges -> True, VertexLabels -> "Name", 
 GraphLayout -> "CircularEmbedding"]

Alternatively, construct edge list using Outer and use Graph:

edgelist = Flatten[Outer[If[SameQ[##], {}, 
      ConstantArray[DirectedEdge[##], Length[Intersection[##]]]] &, 
    vertices, vertices, 1]]; 
Graph[edgelist, VertexLabels -> "Name",  GraphLayout -> "CircularEmbedding"]

same picture

Answer 2

Maybe the following will do what you want.

verticeEdgeDescription = {{"foo", "3", "bar"}, {"3", 
"bar"}, {"foo"}};
(*give numbers to the vertices*)
vertexNumberPlusConnections = MapIndexed[{Last@#2, #1} &,verticeEdgeDescription];
combinations = Select[Tuples[vertexNumberPlusConnections, 2], #[[1]] != #[[2]] &];
combinations2 = DeleteDuplicates[Sort[#] & /@ combinations];
combinations3 = Select[{#[[1, 1]], #[[2, 1]], Intersection @@ #[[;; , -1]]} & /@ combinations2, #[[-1]] != {} &];
Graph[Flatten[With[{firstNode = #[[1]], secondNode = #[[2]], edges = #[[3]]}, 
 Labeled[firstNode \[UndirectedEdge] secondNode, #] & /@ 
  edges] & /@ combinations3], VertexLabels -> "Name", EdgeLabels -> "Name"]

This is mostly doing what you want. The one odd thing is that the labels in the generated graph seem wrong for the edges.

I'm not (yet) happy with how I determine the connections - too much manipulation to get unique connections.

Here is the connection edges: {Labeled[1 [UndirectedEdge] 2, "3"] , Labeled[1 [UndirectedEdge] 2, "bar"] , Labeled[1 [UndirectedEdge] 3, "foo"]}