add nmap and emap; improve graph output

haskell-igraph.cabal

@@ -51,7 +51,7 @@ library
     exposed-modules: IGraph.Exporter.Graphics
 
   if flag(graphics)
-    build-depends: diagrams-lib, diagrams-svg
+    build-depends: diagrams-lib, diagrams-cairo
 
   build-depends:
       base >=4.0 && <5.0

src/IGraph.hs

@@ -2,8 +2,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 module IGraph
     ( LGraph(..)
-    , U
-    , D
+    , U(..)
+    , D(..)
     , Graph(..)
     , mkGraph
     , fromLabeledEdges
@@ -19,10 +19,13 @@ module IGraph
 
     , filterNode
     , filterEdge
+
+    , nmap
+    , emap
     ) where
 
 import Control.Arrow ((***))
-import Control.Monad (liftM)
+import Control.Monad (liftM, forM_)
 import Control.Monad.ST (runST)
 import Control.Monad.Primitive
 import qualified Data.HashMap.Strict as M
@@ -195,3 +198,24 @@ filterEdge f gr = runST $ do
     gr' <- thaw gr
     delEdges deleted gr'
     unsafeFreeze gr'
+
+-- | Map a function over the node labels in a graph
+nmap :: (Graph d, Read v, Hashable u, Read u, Eq u, Show u)
+     => ((Node, v) -> u) -> LGraph d v e -> LGraph d u e
+nmap fn gr = unsafePerformIO $ do
+    (MLGraph g) <- thaw gr
+    forM_ (nodes gr) $ \i -> do
+        let label = fn (i, nodeLab gr i)
+        igraphCattributeVASSet g vertexAttr i (show label)
+    unsafeFreeze (MLGraph g)
+
+-- | Map a function over the edge labels in a graph
+emap :: (Graph d, Read v, Hashable v, Eq v, Read e1, Show e2)
+     => ((Edge, e1) -> e2) -> LGraph d v e1 -> LGraph d v e2
+emap fn gr = unsafePerformIO $ do
+    (MLGraph g) <- thaw gr
+    forM_ (edges gr) $ \(fr, to) -> do
+        let label = fn ((fr,to), edgeLabByEid gr i)
+            i = igraphGetEid g fr to True True
+        igraphCattributeEASSet g edgeAttr i (show label)
+    unsafeFreeze (MLGraph g)

src/IGraph/Exporter/GEXF.hs

@@ -28,7 +28,7 @@ instance Hashable NodeAttr where
 
 defaultNodeAttributes :: NodeAttr
 defaultNodeAttributes = NodeAttr
-    { _size = 1.0
+    { _size = 0.15
     , _nodeColour = opaque black
     , _nodeLabel = ""
     , _positionX = 0
@@ -39,6 +39,7 @@ data EdgeAttr = EdgeAttr
     { _edgeLabel :: String
     , _edgeColour :: AlphaColour Double
     , _edgeWeight :: Double
+    , _edgeArrowLength :: Double
     } deriving (Show, Read, Eq)
 
 instance Hashable EdgeAttr where
@@ -49,6 +50,7 @@ defaultEdgeAttributes = EdgeAttr
     { _edgeLabel = ""
     , _edgeColour = opaque black
     , _edgeWeight = 1.0
+    , _edgeArrowLength = 5.0
     }
 
 genXMLTree :: (ArrowXml a, Graph d) => LGraph d NodeAttr EdgeAttr -> a XmlTree XmlTree

src/IGraph/Exporter/Graphics.hs

@@ -6,13 +6,14 @@ module IGraph.Exporter.Graphics
     ) where
 
 import Diagrams.Prelude
-import Diagrams.Backend.SVG.CmdLine
+import Diagrams.Size (dims)
+import Diagrams.Backend.Cairo
 
 import IGraph
 import IGraph.Exporter.GEXF
 
-renderGraph :: FilePath -> Double -> Double -> LGraph d NodeAttr EdgeAttr -> IO ()
-readerGraph out gr = renderSVG out (Dims w h) $ graphToDiagram gr
+renderGraph :: Graph d => FilePath -> Double -> Double -> LGraph d NodeAttr EdgeAttr -> IO ()
+renderGraph out w h gr = renderCairo out (dims $ w ^& h) $ graphToDiagram gr
 
 graphToDiagram :: Graph d => LGraph d NodeAttr EdgeAttr -> Diagram B
 graphToDiagram gr = position (map drawNode (nodes gr)) <> mconcat (map drawEdge (edges gr))
@@ -21,11 +22,18 @@ graphToDiagram gr = position (map drawNode (nodes gr)) <> mconcat (map drawEdge
                  , circle (_size nattr) # lwO 0 # fcA (_nodeColour nattr) )
       where
         nattr = nodeLab gr x
-    drawEdge (from, to) =
-        fromVertices [ _positionX nattr1 ^& _positionY nattr1
-                     , _positionX nattr2 ^& _positionY nattr2 ]
+    drawEdge (from, to) = arrowBetween'
+        ( with & arrowTail .~ noTail
+               & arrowHead .~ arrowH
+               & headLength .~ output (_edgeArrowLength eattr)
+        ) start end
+        # lwO (_edgeWeight eattr) # lcA (_edgeColour eattr)
       where
         eattr = edgeLab gr (from, to)
+        start = _positionX nattr1 ^& _positionY nattr1
+        end = _positionX nattr2 ^& _positionY nattr2
         nattr1 = nodeLab gr from
         nattr2 = nodeLab gr to
+    arrowH | isDirected gr = dart
+           | otherwise = noHead
 {-# INLINE graphToDiagram #-}

src/IGraph/Generators.hs

 module IGraph.Generators
-    ( erdosRenyiGame
+    ( ErdosRenyiModel(..)
+    , erdosRenyiGame
     ) where
 
 import IGraph

src/IGraph/Internal/Attribute.chs

@@ -15,7 +15,10 @@ import System.IO.Unsafe (unsafePerformIO)
 
 #include "igraph/igraph.h"
 
-makeAttributeRecord :: Show a => String -> [a] -> AttributeRecord
+makeAttributeRecord :: Show a
+                    => String    -- ^ name of the attribute
+                    -> [a]       -- ^ values of the attribute
+                    -> AttributeRecord
 makeAttributeRecord name xs = unsafePerformIO $ do
     ptr <- newCAString name
     value <- listToStrVector $ map (B.pack . show) xs
@@ -51,3 +54,7 @@ instance Storable AttributeRecord where
 {#fun pure igraph_cattribute_EAS as ^ { `IGraphPtr', `String', `Int' } -> `String' #}
 
 {#fun igraph_cattribute_EAS_setv as ^ { `IGraphPtr', `String', `StrVectorPtr' } -> `Int' #}
+
+{#fun igraph_cattribute_VAS_set as ^ { `IGraphPtr', `String', `Int', `String' } -> `Int' #}
+
+{#fun igraph_cattribute_EAS_set as ^ { `IGraphPtr', `String', `Int', `String' } -> `Int' #}

src/IGraph/Mutable.hs

@@ -54,8 +54,8 @@ class MGraph d where
 
     delEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m ()
 
-data U
-data D
+data U = U
+data D = D
 
 instance MGraph U where
     new n = unsafePrimToPrim $ igraphInit >>= igraphNew n False >>= return . MLGraph

src/test.hs

-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-import qualified Data.ByteString.Char8 as B
-import IGraph
-import IGraph.Generators
-import IGraph.Layout
-import System.Environment
-import Data.Default
-
-main = do
-    gr <- erdosRenyiGame GNM 100 50 U False
-    coord <- getLayout gr def