2013-08-13 Graphs: a Balancing Act
A while ago, me and some friends wrote a C++ tool to generate and visualise graphs, and I was surprised at how easy it is to “balance” graph vertices so that they are laid out in a nice way. This tutorial reproduces a version of the algorithm in Haskell, using the gloss library to get the graph on the screen. Apart from gloss nothing outside the Haskell Platform is needed.1
This tutorial is aimed at beginners, and only a basic knowledge of Haskell is required—we disregard performance in favour of simple code. Here is a preview of the result:
Preliminaries
We import the libraries we need, qualifying Map and Set avoiding clashes with the Prelude.
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import System.Random
import Graphics.Gloss
import Graphics.Gloss.Data.Vector
import Graphics.Gloss.Data.ViewState
import Graphics.Gloss.Interface.Pure.GameThe idea
First, let’s frame the problem we want to solve. We have an undirected graph, and we want to position its vertices on a surface so that the result is pleasant to look at. “Pleasant to look at” is still a very vague requirement depending on fuzzy things like human taste, and in fact there are many ways to go at this problem.
We will gain inspiration from physics, and take vertices to be like charged particles repelling each other, and edges to be like elastic bands pulling the vertices together.2 We will calculate the forces and update the positions in rounds, and hopefully after some time our graph will stabilise. With the right numbers, this gives surprisingly good results: clusters of vertices are held together by the numerous edges between them, while sparsely connected vertices remain distant, reducing clutter.
The Graph
We need some kind of identifier for our vertices, we will simply go for Int. An Edge is a pair of Vertexs.
We want to store our graph so that the operations we need to execute are as natural as possible. Given the algorithm outline given above, we need to do two things well: iterating through all the vertices, and iterating through the neighbours of a given vertex. With that in mind, the simplest thing to do is simply store the graph as the set of neighbouring nodes for each Vertex:
-- INVARIANT Every `Vertex` present in a set of neighbours is
-- present as a key in the `Map`.
newtype Graph = Graph {grNeighs :: Map Vertex (Set Vertex)}
emptyGraph :: Graph
emptyGraph = Graph Map.emptyWhen we add a vertex, we make sure that a set of neighbours exist for that vertex. In this way adding existing vertices will not modify the graph.
addVertex :: Vertex -> Graph -> Graph
addVertex v (Graph neighs) =
Graph $ case Map.lookup v neighs of
Nothing -> Map.insert v Set.empty neighs
Just _ -> neighsWhen we add an Edge, we first make sure that the vertices provided are present in the graph by adding them, and then add each vertex to the other vertex’s neighbours.
addEdge :: Edge -> Graph -> Graph
addEdge (v1, v2) gr = Graph neighs
where
gr' = addVertex v1 (addVertex v2 gr)
neighs = Map.insert v1 (Set.insert v2 (vertexNeighs v1 gr')) $
Map.insert v2 (Set.insert v1 (vertexNeighs v2 gr')) $
grNeighs gr'vertexNeighs unsafely gets the neighbours of a given Vertex: the precondition is that the Vertex provided is in the graph.
This is all we need to implement the algorithm. It is also useful to have a function returning all the edges in the Graph so that we can draw them. Set.foldr and Map.foldrWithKey are equivalent to the usual foldr for lists, with the twist that with a Map we fold over the key and value at the same time. Since the graph is undirected, we “order” each edge so that the the vertex with the lower id appears first: in this way we will avoid duplicates like (1, 2) and (2, 1).
graphEdges :: Graph -> Set Edge
graphEdges = Map.foldrWithKey' foldNeighs Set.empty . grNeighs
where
-- For each vertex `v1`, insert an edge for each neighbour `v2`.
foldNeighs v1 ns es =
Set.foldr' (\v2 -> Set.insert (order (v1, v2))) es ns
order (v1, v2) = if v1 > v2 then (v1, v2) else (v2, v1)The Scene
Now that we have our graph, we need a data structure recording the position of each point. We also want to be able to “grab” points to move them around, so we add a field recording whether we have a Vertex grabbed or not. We also make use of gloss ViewState, which will let us implement panning, rotating, and zooming in an easy way.
-- INVARIANT The keys in `scGraph` are the same as the keys
-- in `scPoints`.
data Scene =
Scene { scGraph :: Graph
, scPoints :: Map Vertex Point
, scSelected :: Maybe Vertex
, scViewState :: ViewState }
emptyScene :: Scene
emptyScene =
Scene{ scGraph = emptyGraph
, scPoints = Map.empty
, scSelected = Nothing
, scViewState = viewStateInit }Then two predictable operations: one that adds a Vertex, with its initial position on the scene, and one that adds an Edge. When adding the Edge, we need both points to be already present—see the invariant for Scene. We cannot simply add the vertices like we do in addEdge because we need their positions.
scAddVertex :: Vertex -> Point -> Scene -> Scene
scAddVertex v pt sc@Scene{scGraph = gr, scPoints = pts} =
sc{scGraph = addVertex v gr, scPoints = Map.insert v pt pts}
scAddEdge :: Edge -> Scene -> Scene
scAddEdge e@(v1, v2) sc@Scene{scGraph = gr, scPoints = pts} =
if Map.member v1 pts && Map.member v2 pts
then sc{scGraph = addEdge e gr}
else error "scAddEdge: non existant point!"It is also useful to have an helper to get the position of a Vertex.
Drawing
Now we can write the functions to convert the Scene to a Picture. Thanks to gloss, this is extremely easy: we are offered a simple data type that gloss will use to get things on the screen.
Some constants:
vertexRadius :: Float
vertexRadius = 6
vertexColor :: Color
vertexColor = makeColor 1 0 0 1 -- Red
edgeColor :: Color
edgeColor = makeColor 1 1 1 0.8 -- WhiteishDrawing a Vertex is simply drawing a circle. We use ThickCircle to get the circle to be filled instead of just an outline.
drawVertex :: Vertex -> Scene -> Picture
drawVertex v sc =
Translate x y (ThickCircle (vertexRadius / 2) vertexRadius)
where (x, y) = vertexPos v scDrawing an Edge is drawing a Line.
Bringing everything together, we generate Pictures for all the vertices and all the edges, and then combine those with the appropriate colours. Moreover we get the ViewPort in the ViewState—which stores the current translation, rotation, and scaling—and apply it to the picture.
drawScene :: Scene -> Picture
drawScene sc@Scene{scGraph = gr, scViewState = ViewState{viewStateViewPort = port}} =
applyViewPortToPicture port $
Pictures [Color edgeColor edges, Color vertexColor vertices]
where
vertices = Pictures [drawVertex n sc | n <- Map.keys (grNeighs gr) ]
edges = Pictures [drawEdge e sc | e <- Set.toList (graphEdges gr)]Balancing
Now to the interesting part, the code necessary to balance the graph. As mentioned, we have two contrasting forces. Each vertex “pushes” all the others away, and each edge “pulls” together the connected vertices.
First we define a function for the “pushing” force, resulting from the charge of the vertices. Predictably, the force will be inversely proportional to the square of the distance of the two vertices. Graphics.Gloss.Data.Vector defines
type Vector = (Float, Float)and also a Num instance for Vector, which means that we can take advantage of vector subtraction to easily get the distance and the direction of the force.
The charge of each particle has been determined empirically to give good results—increasing it will lead to a more “spaced out” graph, decreasing it a more crowded one. mulSV lets us multiply Vectors by scalars, magV lets us get the magnitude of a vector (in this case the distance). Varying the charge will determine how far apart the vertices will be.
charge :: Float
charge = 100000
pushForce :: Point -- Vertex we're calculating the force for
-> Point -- Vertex pushing the other away
-> Vector
pushForce v1 v2 =
-- If we are analysing the same vertex, l = 0
if l > 0 then (charge / l) `mulSV` normaliseV d else 0
where
d = v1 - v2
l = magV d ** 2For what concerns the force that pulls connected vertices together, it will be proportional to the distance of the two vertices, so we can take the distance vector directly and multiply it by the stiffness, although this time ve have the vector point in the other direction, since this force brings the vertices together.
stiffness :: Float
stiffness = 1 / 2
pullForce :: Point -> Point -> Vector
pullForce v1 v2 = stiffness `mulSV` (v2 - v1)We can then write a function to get the velocity of a Vertex in each round:
updatePosition :: Float -- Time since the last update
-> Vertex -- Vertex we are analysing
-> Scene
-> Point -- New position
updatePosition dt v1 sc@Scene{scPoints = pts, scGraph = gr} =
v1pos + pull + push
where
v1pos = vertexPos v1 sc
-- Gets a velocity by multiplying the time by the force (we take
-- the mass to be 1).
getVel f v2pos = dt `mulSV` f v1pos v2pos
-- Sum all the pushing and pulling. All the other vertices push,
-- the connected vertices pull.
push = Map.foldr' (\v2pos -> (getVel pushForce v2pos +)) 0 pts
pull = foldr (\v2pos -> (getVel pullForce v2pos +)) 0
[vertexPos v2 sc | v2 <- Set.toList (vertexNeighs v1 gr)]We bring everything together by calculating the new position for each vertex. We do not move the vertex that is currently selected by the user, if there is one.
updatePositions :: Float -> Scene -> Scene
updatePositions dt sc@Scene{scSelected = sel, scGraph = Graph neighs} =
foldr f sc (Map.keys neighs)
where
f n sc' =
let pt = if Just n == sel
then vertexPos n sc else updatePosition dt n sc'
in scAddVertex n pt sc'User interaction
When a user clicks to grab a point, we need to check if she has caught something. Thus we define inCircle to check if the a point is inside the drawn version of a vertex.
inCircle :: Point -- Where the user has clicked
-> Float -- The scaling factor in the ViewPort
-> Point -- The position of the vertex
-> Bool
inCircle p sca v = magV (v - p) <= vertexRadius * scafindVertex iterates through all the vertices and returns one if the position where the user has clicked is in it.
findVertex :: Point -> Float -> Scene -> Maybe Vertex
findVertex p1 sca Scene{scPoints = pts} =
Map.foldrWithKey' f Nothing pts
where
f _ _ (Just v) = Just v
f v p2 Nothing = if inCircle p1 sca p2 then Just v else NothingUser input will come in the form of Events, a gloss data type that represents key or mouse button presses, and mouse motion. Thus we define handleEvent to process an Event and a Scene producing a new Scene:
We want the user to be able to grab vertices. Since the default configuration for the ViewState—which we are using—already uses the left and right mouse button for its actions, we require the user to press Ctrl and click:
handleEvent (EventKey (MouseButton LeftButton) Down Modifiers{ctrl = Down} pos) sc =
case findVertex (invertViewPort port pos) (viewPortScale port) sc of
Nothing -> sc
Just v -> sc{scSelected = Just v}
where
viewState = scViewState sc
port = viewStateViewPort viewStateinvertViewPort “undoes” the rotation, translation and scaling applied by the ViewPort to the picture, so that we can map user input to the coordinates that scPoints refers to.
When the user releases the left mouse button and a vertex is selected, we deselect it:
handleEvent (EventKey (MouseButton LeftButton) Up _ _) sc@Scene{scSelected = Just _} =
sc{scSelected = Nothing}When the user moves the mouse and a vertex is selected, we move the vertex where the cursor is:
handleEvent (EventMotion pos) sc@Scene{scPoints = pts, scSelected = Just v} =
sc{scPoints = Map.insert v (invertViewPort port pos) pts}
where
port = viewStateViewPort (scViewState sc)When none of the above apply, we pass the event to the ViewState, which will handle the panning, rotating, and zooming.
Running
Finally, we put the code above to good use. We will use a sample graph to draw:
-- Taken from <http://www.graphviz.org/Gallery/undirected/transparency.gv.txt>.
sampleGraph :: [Edge]
sampleGraph =
[(1, 30), (1, 40), (8, 46), (8, 16), (10, 25), (10, 19), (10, 33),
(12, 8 ), (12, 36), (12, 17), (13, 38), (13, 24), (24, 49), (24, 13),
(24, 47), (24, 12), (25, 27), (25, 12), (27, 12), (27, 14), (29, 10),
(29, 8 ), (30, 24), (30, 44), (38, 29), (38, 35), (2, 42), (2, 35),
(2, 11), (14, 18), (14, 24), (14, 38), (18, 49), (18, 47), (26, 41),
(26, 42), (31, 39), (31, 47), (31, 25), (37, 26), (37, 16), (39, 50),
(39, 14), (39, 18), (39, 47), (41, 31), (41, 8 ), (42, 44), (42, 29),
(44, 37), (44, 32), (3, 20), (3, 28), (6, 45), (6, 28), (9, 6 ),
(9, 16), (15, 16), (15, 48), (16, 50), (16, 32), (16, 39), (20, 33),
(33, 9 ), (33, 46), (33, 48), (45, 15), (4, 17), (4, 15), (4, 12),
(17, 21), (19, 35), (19, 15), (19, 43), (21, 19), (21, 50), (23, 36),
(34, 23), (34, 24), (35, 34), (35, 16), (35, 18), (36, 46), (5, 7 ),
(5, 36), (7, 32), (7, 11), (7, 14), (11, 40), (11, 50), (22, 46),
(28, 43), (28, 8 ), (32, 28), (32, 39), (32, 42), (40, 22), (40, 47),
(43, 11), (43, 17)
]Then an utility function fromEdges initialises a scene from a list of edges randomising the positions of the vertices in the initial window size:
windowSize :: (Int, Int)
windowSize = (640, 480)
fromEdges :: StdGen -> [Edge] -> Scene
fromEdges gen es =
foldr scAddEdge (fst (Set.foldr' addv (emptyScene, gen) vs)) es
where
vs = Set.fromList (concat [[v1, v2] | (v1, v2) <- es])
halfWidth = fromIntegral (fst windowSize) / 2
halfHeight = fromIntegral (snd windowSize) / 2
addv v (sc, gen1) =
let (x, gen2) = randomR (-halfWidth, halfWidth ) gen1
(y, gen3) = randomR (-halfHeight, halfHeight) gen2
in (scAddVertex v (x, y) sc, gen3)Finally, we use the play function provided by gloss to make everything work. The important arguments in play are the last two functions, which update the state of the world after a user event and after a time step, respectively. In our case handleEvent and updatePositions will do the job, our world being a Scene.
sceneWindow :: Scene -> IO ()
sceneWindow sc =
play (InWindow "Graph Drawing - ctrl + left mouse button to drag" windowSize (10, 10))
black 30 sc drawScene handleEvent updatePositionsThen all its left to do is to initialise the Scene and run sceneWindow.
Improvements
The code provided is a good starting point for many improvements, here we give some suggestions.
Performance
The code does not scale well for big graphs, for a number of reason.
QuadTree/Voronoi diagram: Currently our algorithm is cubic: for each vertex we go over all the other vertices for the push forces and over all the neighbours for the pull forces.
It can be made much faster by approximating distant clusters of vertices to a single particle with higher charge. An easy way is to subdivide recursively the space into squares, a goal achievable by storing the graph in a QuadTree.3 Then squares that are far enough are deemed as one entity.4
A more precise but also more expensive way is to subdivide the space in a more irregular way depending on the disposition of the vertices, for example in what is called a Voronoi diagram.
Arrays: Currently, once a graph is loaded, it stays the same forever. This considered, using
Mapis quite a waste: we can utilise a structure with much better performance to store the graph, such as anArrayor aVector. The best option would probably be an unboxedVector.
Functionality
Weighed edges: We can easily adapt the algorithm to work with weighed edges by adjusting the stiffness of each edge depending on the weigh. For example if the weigh represents the distance between two connected nodes, the stiffness will be inversely proportional to the weigh, so that closer vertices will indeed end up being closer.
Generating graphs: Generating realistic graphs is an interesting and useful challenge. It turns out that many real networks, such as friendships and the web, share certain characteristics. Such networks are known as small-world networks, and various algorithms to generate them are available.
3D: The algorithm can be trivially extended to the 3rd dimension—in fact given the right
Numinstances it will work in automatically, and with some type class trickery in any dimension.The hard part would be drawing the graph, since
glossdoes not go beyond 2 dimensions, and raw OpenGL is so much uglier.dotfiles: The program could be enhanced with a parser fordotor similar format, so that experiments could be ran on existing graphs.
If you implement any of the above in a nice way, let me know!
As usual, comments on Reddit.
Note that you need the very last version of
gloss, 1.8.0.1, for this code to work. The author spent some time hacking on gloss to make this code simpler, and the changes have been merged recently.↩This class of algorithms is known as force-directed graph drawing.↩
glossprovides a module to work with QuadTrees,Graphics.Gloss.Data.QuadTree.↩This approach is known as Barnes-Hut simulation.↩