diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,12 @@ Revision history for haskell-igraph =================================== +v0.7.0 -- 2018-05-23 +-------------------- + +* Add more functions and tests. +* Internal interface redesign. + v0.6.0 -- 2018-05-10 -------------------- diff --git a/haskell-igraph.cabal b/haskell-igraph.cabal --- a/haskell-igraph.cabal +++ b/haskell-igraph.cabal @@ -1,5 +1,5 @@ name: haskell-igraph -version: 0.6.0 +version: 0.7.0 synopsis: Haskell interface of the igraph library. description: igraph<"http://igraph.org/c/"> is a library for creating and manipulating large graphs. This package provides the Haskell @@ -29,17 +29,18 @@ IGraph.Internal.Constants IGraph.Internal IGraph - IGraph.Types IGraph.Mutable - IGraph.Clique - IGraph.Structure - IGraph.Isomorphism - IGraph.Community - IGraph.Read - IGraph.Motif - IGraph.Layout - IGraph.Generators + IGraph.Types IGraph.Exporter.GEXF + IGraph.Algorithms + IGraph.Algorithms.Structure + IGraph.Algorithms.Community + IGraph.Algorithms.Clique + IGraph.Algorithms.Layout + IGraph.Algorithms.Motif + IGraph.Algorithms.Generators + IGraph.Algorithms.Isomorphism + IGraph.Algorithms.Centrality other-modules: IGraph.Internal.C2HS @@ -53,14 +54,12 @@ build-depends: base >= 4.0 && < 5.0 , bytestring >= 0.9 - , bytestring-lexing >= 0.5 , cereal , colour , conduit >= 1.3.0 + , containers , data-ordlist , primitive - , unordered-containers - , hashable , hxt , split , singletons @@ -79,14 +78,12 @@ test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests + ghc-options: -Wall main-is: test.hs other-modules: Test.Basic Test.Attributes - Test.Structure - Test.Isomorphism - Test.Motif - Test.Clique + Test.Algorithms Test.Utils default-language: Haskell2010 diff --git a/src/IGraph.hs b/src/IGraph.hs --- a/src/IGraph.hs +++ b/src/IGraph.hs @@ -6,6 +6,10 @@ module IGraph ( Graph(..) , EdgeType(..) + , Node + , LNode + , Edge + , LEdge , isDirected , nNodes , nodeLab @@ -15,6 +19,10 @@ , edgeLab , edges , labEdges + , addNodes + , delNodes + , addEdges + , delEdges , hasEdge , getNodes , getEdgeByEid @@ -38,20 +46,23 @@ , nfilter , efilter + + -- * Non-simple graphs: multiple and loop edges + , isSimple + , hasMultiple ) where import Conduit -import Control.Arrow ((&&&)) -import Control.Monad (forM, forM_, liftM, replicateM, when) +import Control.Monad (forM, forM_, replicateM, when) import Control.Monad.Primitive import Control.Monad.ST (runST) import Data.Either (fromRight) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S +import qualified Data.Map.Strict as M +import qualified Data.Set as S import Data.List (sortBy) import Data.Ord (comparing) import Data.Serialize +import Data.Primitive.MutVar import Data.Singletons (Sing, SingI (..), fromSing) import Foreign (Ptr, castPtr) import System.IO.Unsafe (unsafePerformIO) @@ -65,10 +76,10 @@ -- | Graph with labeled nodes and edges. data Graph (d :: EdgeType) v e = Graph { _graph :: IGraph - , _labelToNode :: M.HashMap v [Node] + , _labelToNode :: M.Map v [Node] } -instance (SingI d, Serialize v, Serialize e, Hashable v, Eq v) +instance (SingI d, Serialize v, Serialize e, Ord v) => Serialize (Graph d v e) where put gr = do put $ fromSing (sing :: Sing d) @@ -115,37 +126,40 @@ nEdges = unsafePerformIO . igraphEcount . _graph {-# INLINE nEdges #-} - -- | Return all edges. +-- | Return all edges. edges :: Graph d v e -> [Edge] edges gr = map (getEdgeByEid gr) [0 .. nEdges gr - 1] {-# INLINE edges #-} labEdges :: Serialize e => Graph d v e -> [LEdge e] -labEdges gr = map (getEdgeByEid gr &&& getEdgeLabByEid gr) [0 .. nEdges gr - 1] +labEdges gr = map (\i -> (getEdgeByEid gr i, getEdgeLabByEid gr i)) + [0 .. nEdges gr - 1] {-# INLINE labEdges #-} -- | Whether a edge exists in the graph. -hasEdge :: Graph d v e -> Edge -> Bool -hasEdge gr (fr, to) = unsafePerformIO $ do +hasEdge :: Edge -> Graph d v e -> Bool +hasEdge (fr, to) gr = unsafePerformIO $ do i <- igraphGetEid (_graph gr) fr to True False return $ i >= 0 {-# INLINE hasEdge #-} -- | Return the label of given node. nodeLab :: Serialize v => Graph d v e -> Node -> v -nodeLab gr i = unsafePerformIO $ - igraphHaskellAttributeVAS (_graph gr) vertexAttr i >>= toByteString >>= - return . fromRight (error "decode failed") . decode +nodeLab gr i + | i >= nNodes gr = error "Query node is not in the graph" + | otherwise = unsafePerformIO $ + igraphHaskellAttributeVAS (_graph gr) vertexAttr i >>= toByteString >>= + return . fromRight (error "decode failed") . decode {-# INLINE nodeLab #-} -- | Return all nodes that are associated with given label. -getNodes :: (Hashable v, Eq v) => Graph d v e -> v -> [Node] -getNodes gr x = M.lookupDefault [] x $ _labelToNode gr +getNodes :: Ord v => Graph d v e -> v -> [Node] +getNodes gr x = M.findWithDefault [] x $ _labelToNode gr {-# INLINE getNodes #-} -- | Return the label of given edge. edgeLab :: Serialize e => Graph d v e -> Edge -> e -edgeLab (Graph g _) (fr,to) = unsafePerformIO $ +edgeLab (Graph g _) (fr, to) = unsafePerformIO $ igraphGetEid g fr to True True >>= igraphHaskellAttributeEAS g edgeAttr >>= toByteString >>= return . fromRight (error "decode failed") . decode @@ -163,34 +177,70 @@ return . fromRight (error "decode failed") . decode {-# INLINE getEdgeLabByEid #-} +-- | Add nodes with labels to the graph. +addNodes :: (Ord v, Serialize v) + => [v] -- ^ vertices' labels + -> Graph d v e -> Graph d v e +addNodes nds gr = runST $ do + gr' <- thaw gr + GM.addNodes nds gr' + unsafeFreeze gr' +{-# INLINE addNodes #-} + +-- | Delete nodes from the graph. +delNodes :: (Ord v, Serialize v) + => [Node] -> Graph d v e -> Graph d v e +delNodes nds gr = runST $ do + gr' <- thaw gr + GM.delNodes nds gr' + unsafeFreeze gr' +{-# INLINE delNodes #-} + +-- | Add edges with labels to the graph. +addEdges :: Serialize e + => [LEdge e] -> Graph d v e -> Graph d v e +addEdges es gr = runST $ do + gr' <- thaw gr + GM.addEdges es gr' + unsafeFreeze gr' +{-# INLINE addEdges #-} + +-- | Delete edges from the graph. +delEdges :: SingI d => [Edge] -> Graph d v e -> Graph d v e +delEdges es gr = runST $ do + gr' <- thaw gr + GM.delEdges es gr' + unsafeFreeze gr' +{-# INLINE delEdges #-} + -- | Create a empty graph. -empty :: (SingI d, Hashable v, Serialize v, Eq v, Serialize e) +empty :: (SingI d, Serialize v, Ord v, Serialize e) => Graph d v e -empty = runST $ GM.new 0 >>= unsafeFreeze +empty = runST $ GM.new [] >>= unsafeFreeze -- | Create a graph. -mkGraph :: (SingI d, Hashable v, Serialize v, Eq v, Serialize e) +mkGraph :: (SingI d, Serialize v, Ord v, Serialize e) => [v] -- ^ Nodes. Each will be assigned a ID from 0 to N. -> [LEdge e] -- ^ Labeled edges. -> Graph d v e mkGraph vattr es = runST $ do - g <- GM.new 0 - GM.addLNodes vattr g - GM.addLEdges es g + g <- GM.new [] + GM.addNodes vattr g + GM.addEdges es g unsafeFreeze g -- | Create a graph from labeled edges. -fromLabeledEdges :: (SingI d, Hashable v, Serialize v, Eq v, Serialize e) +fromLabeledEdges :: (SingI d, Serialize v, Ord v, Serialize e) => [((v, v), e)] -> Graph d v e fromLabeledEdges es = mkGraph labels es' where es' = flip map es $ \((fr, to), x) -> ((f fr, f to), x) - where f x = M.lookupDefault undefined x labelToId + where f x = M.findWithDefault undefined x labelToId labels = S.toList $ S.fromList $ concat [ [a,b] | ((a,b),_) <- es ] labelToId = M.fromList $ zip labels [0..] -- | Create a graph from a stream of labeled edges. -fromLabeledEdges' :: (MonadUnliftIO m, SingI d, Hashable v, Serialize v, Eq v, Serialize e) +fromLabeledEdges' :: (MonadUnliftIO m, SingI d, Serialize v, Ord v, Serialize e) => a -- ^ Input, usually a file -> (a -> ConduitT () ((v, v), e) m ()) -- ^ deserialize the input into a stream of edges -> m (Graph d v e) @@ -198,7 +248,7 @@ (labelToId, _, ne) <- runConduit $ mkConduit input .| foldlC f (M.empty, 0::Int, 0::Int) let action evec bsvec = do - let getId x = M.lookupDefault undefined x labelToId + let getId x = M.findWithDefault undefined x labelToId runConduit $ mkConduit input .| mapC (\((v1, v2), e) -> ((getId v1, getId v2), e)) .| deserializeGraph (fst $ unzip $ sortBy (comparing snd) $ M.toList labelToId) evec bsvec @@ -213,7 +263,7 @@ then (m, i) else (M.insert v i m, i + 1) -deserializeGraph :: (MonadIO m, SingI d, Hashable v, Serialize v, Eq v, Serialize e) +deserializeGraph :: (MonadIO m, SingI d, Serialize v, Ord v, Serialize e) => [v] -> Ptr Vector -- ^ a vector that is sufficient to hold all edges -> Ptr BSVector @@ -226,39 +276,42 @@ return $ i + 1 _ <- foldMC f 0 liftIO $ do - gr@(MGraph g) <- GM.new 0 - GM.addLNodes nds gr + gr <- GM.new [] + GM.addNodes nds gr withBSAttr edgeAttr bsvec $ \ptr -> - withPtrs [ptr] (igraphAddEdges g evec . castPtr) + withPtrs [ptr] (igraphAddEdges (_mgraph gr) evec . castPtr) unsafeFreeze gr {-# INLINE deserializeGraph #-} -- | Convert a mutable graph to immutable graph. -freeze :: (Hashable v, Eq v, Serialize v, PrimMonad m) +freeze :: PrimMonad m => MGraph (PrimState m) d v e -> m (Graph d v e) -freeze (MGraph g) = do - g' <- unsafePrimToPrim $ igraphCopy g - unsafeFreeze (MGraph g') +freeze gr = do + g' <- unsafePrimToPrim $ igraphCopy $ _mgraph gr + readMutVar (_mlabelToNode gr) >>= return . Graph g' +{-# INLINE freeze #-} -- | Convert a mutable graph to immutable graph. The original graph may not be -- used afterwards. -unsafeFreeze :: (Hashable v, Eq v, Serialize v, PrimMonad m) +unsafeFreeze :: PrimMonad m => MGraph (PrimState m) d v e -> m (Graph d v e) -unsafeFreeze (MGraph g) = unsafePrimToPrim $ do - nV <- igraphVcount g - labels <- forM [0 .. nV - 1] $ \i -> - igraphHaskellAttributeVAS g vertexAttr i >>= toByteString >>= - return . fromRight (error "decode failed") . decode - return $ Graph g $ M.fromListWith (++) $ zip labels $ map return [0..nV-1] - where +unsafeFreeze (MGraph g l) = readMutVar l >>= return . Graph g +{-# INLINE unsafeFreeze #-} -- | Create a mutable graph. thaw :: PrimMonad m => Graph d v e -> m (MGraph (PrimState m) d v e) -thaw (Graph g _) = unsafePrimToPrim . liftM MGraph . igraphCopy $ g +thaw (Graph g l) = do + g' <- unsafePrimToPrim $ igraphCopy g + l' <- newMutVar l + return $ MGraph g' l' +{-# INLINE thaw #-} -- | Create a mutable graph. The original graph may not be used afterwards. unsafeThaw :: PrimMonad m => Graph d v e -> m (MGraph (PrimState m) d v e) -unsafeThaw (Graph g _) = return $ MGraph g +unsafeThaw (Graph g l) = do + l' <- newMutVar l + return $ MGraph g l' +{-# INLINE unsafeThaw #-} -- | Find all neighbors of the given node. neighbors :: Graph d v e -> Node -> [Node] @@ -276,27 +329,30 @@ iterateVerticesC (_graph gr) vs $ \source -> runConduit $ source .| sinkList -- | Apply a function to change nodes' labels. -nmap :: (Serialize v1, Serialize v2, Hashable v2, Eq v2) +nmap :: (Serialize v1, Serialize v2, Ord v2) => (LNode v1 -> v2) -> Graph d v1 e -> Graph d v2 e nmap f gr = runST $ do - (MGraph gptr) <- thaw gr - let gr' = MGraph gptr - forM_ (nodes gr) $ \x -> GM.setNodeAttr x (f (x, nodeLab gr x)) gr' - unsafeFreeze gr' + gr' <- unsafePrimToPrim $ igraphCopy $ _graph gr + labelToId <- fmap (M.fromListWith (++)) $ forM (nodes gr) $ \x -> do + let l = f (x, nodeLab gr x) + unsafePrimToPrim $ withByteString (encode l) $ + igraphHaskellAttributeVASSet gr' vertexAttr x + return (l, [x]) + return $ Graph gr' labelToId -- | Apply a function to change edges' labels. -emap :: (Serialize e1, Serialize e2, Hashable v, Eq v, Serialize v) +emap :: (Serialize e1, Serialize e2, Ord v, Serialize v) => (LEdge e1 -> e2) -> Graph d v e1 -> Graph d v e2 emap f gr = runST $ do - (MGraph gptr) <- thaw gr - let gr' = MGraph gptr + MGraph gptr l <- thaw gr + let gr' = MGraph gptr l forM_ [0 .. nEdges gr - 1] $ \i -> do let lab = f (getEdgeByEid gr i, getEdgeLabByEid gr i) GM.setEdgeAttr i lab gr' unsafeFreeze gr' -- | Keep nodes that satisfy the constraint. -nfilter :: (Hashable v, Eq v, Serialize v) +nfilter :: (Ord v, Serialize v) => (LNode v -> Bool) -> Graph d v e -> Graph d v e nfilter f gr = runST $ do let deleted = fst $ unzip $ filter (not . f) $ labNodes gr @@ -305,10 +361,23 @@ unsafeFreeze gr' -- | Keep edges that satisfy the constraint. -efilter :: (SingI d, Hashable v, Eq v, Serialize v, Serialize e) +efilter :: (SingI d, Ord v, Serialize v, Serialize e) => (LEdge e -> Bool) -> Graph d v e -> Graph d v e efilter f gr = runST $ do let deleted = fst $ unzip $ filter (not . f) $ labEdges gr gr' <- thaw gr GM.delEdges deleted gr' unsafeFreeze gr' + +-- | Decides whether the input graph is a simple graph. A graph is a simple +-- graph if it does not contain loop edges and multiple edges. +isSimple :: Graph d v e -> Bool +isSimple = unsafePerformIO . igraphIsSimple . _graph +{-# INLINE isSimple #-} + +-- | Check whether the graph has at least one multiple edge. An edge is a +-- multiple edge if there is another edge with the same head and tail vertices +-- in the graph. +hasMultiple :: Graph d v e -> Bool +hasMultiple = unsafePerformIO . igraphHasMultiple . _graph +{-# INLINE hasMultiple #-} diff --git a/src/IGraph/Algorithms.hs b/src/IGraph/Algorithms.hs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms.hs @@ -0,0 +1,19 @@ +module IGraph.Algorithms + ( module IGraph.Algorithms.Structure + , module IGraph.Algorithms.Community + , module IGraph.Algorithms.Clique + , module IGraph.Algorithms.Layout + , module IGraph.Algorithms.Motif + , module IGraph.Algorithms.Generators + , module IGraph.Algorithms.Isomorphism + , module IGraph.Algorithms.Centrality + ) where + +import IGraph.Algorithms.Structure +import IGraph.Algorithms.Community +import IGraph.Algorithms.Clique +import IGraph.Algorithms.Layout +import IGraph.Algorithms.Motif +import IGraph.Algorithms.Generators +import IGraph.Algorithms.Isomorphism +import IGraph.Algorithms.Centrality diff --git a/src/IGraph/Algorithms/Centrality.chs b/src/IGraph/Algorithms/Centrality.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Centrality.chs @@ -0,0 +1,129 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Algorithms.Centrality + ( closeness + , betweenness + , eigenvectorCentrality + , pagerank + ) where + +import Control.Monad +import Data.Serialize (Serialize) +import Data.List (foldl') +import System.IO.Unsafe (unsafePerformIO) +import Data.Maybe +import Data.Singletons (SingI) + +import Foreign +import Foreign.C.Types + +import IGraph +{#import IGraph.Internal #} +{#import IGraph.Internal.Constants #} + +#include "haskell_igraph.h" + +-- | The normalized closeness centrality of a node is the average length of the +-- shortest path between the node and all other nodes in the graph. +closeness :: [Int] -- ^ vertices + -> Graph d v e + -> Maybe [Double] -- ^ optional edge weights + -> Bool -- ^ whether to normalize the results + -> [Double] +closeness nds gr ws normal = unsafePerformIO $ allocaVector $ \result -> + withVerticesList nds $ \vs -> withListMaybe ws $ \ws' -> do + igraphCloseness (_graph gr) result vs IgraphOut ws' normal + toList result +{#fun igraph_closeness as ^ + { `IGraph' + , castPtr `Ptr Vector' + , castPtr %`Ptr VertexSelector' + , `Neimode' + , castPtr `Ptr Vector' + , `Bool' } -> `CInt' void- #} + + +-- | Betweenness centrality +betweenness :: [Int] + -> Graph d v e + -> Maybe [Double] + -> [Double] +betweenness nds gr ws = unsafePerformIO $ allocaVector $ \result -> + withVerticesList nds $ \vs -> withListMaybe ws $ \ws' -> do + igraphBetweenness (_graph gr) result vs True ws' False + toList result +{#fun igraph_betweenness as ^ + { `IGraph' + , castPtr `Ptr Vector' + , castPtr %`Ptr VertexSelector' + , `Bool' + , castPtr `Ptr Vector' + , `Bool' } -> `CInt' void- #} + +-- | Eigenvector centrality +eigenvectorCentrality :: Graph d v e + -> Maybe [Double] + -> [Double] +eigenvectorCentrality gr ws = unsafePerformIO $ allocaArpackOpt $ \arparck -> + allocaVector $ \result -> withListMaybe ws $ \ws' -> do + igraphEigenvectorCentrality (_graph gr) result nullPtr True True ws' arparck + toList result +{#fun igraph_eigenvector_centrality as ^ + { `IGraph' + , castPtr `Ptr Vector' + , id `Ptr CDouble' + , `Bool' + , `Bool' + , castPtr `Ptr Vector' + , castPtr `Ptr ArpackOpt' } -> `CInt' void- #} + +-- | Google's PageRank algorithm, with option to +pagerank :: SingI d + => Graph d v e + -> Maybe [Double] -- ^ Node weights or reset probability. If provided, + -- the personalized PageRank will be used + -> Maybe [Double] -- ^ Edge weights + -> Double -- ^ damping factor, usually around 0.85 + -> [Double] +pagerank gr reset ws d + | n == 0 = [] + | isJust ws && length (fromJust ws) /= m = error "incorrect length of edge weight vector" + | isJust reset && length (fromJust reset) /= n = error + "incorrect length of node weight vector" + | fmap (foldl' (+) 0) reset == Just 0 = error "sum of node weight vector must be non-zero" + | otherwise = unsafePerformIO $ alloca $ \p -> allocaVector $ \result -> + withVerticesAll $ \vs -> withListMaybe ws $ \ws' -> do + case reset of + Nothing -> igraphPagerank (_graph gr) IgraphPagerankAlgoPrpack + result p vs (isDirected gr) d ws' nullPtr + Just reset' -> withList reset' $ \reset'' -> igraphPersonalizedPagerank + (_graph gr) IgraphPagerankAlgoPrpack result p vs + (isDirected gr) d reset'' ws' nullPtr + toList result + where + n = nNodes gr + m = nEdges gr + +{#fun igraph_pagerank as ^ + { `IGraph' + , `PagerankAlgo' + , castPtr `Ptr Vector' + , id `Ptr CDouble' + , castPtr %`Ptr VertexSelector' + , `Bool' + , `Double' + , castPtr `Ptr Vector' + , id `Ptr ()' + } -> `CInt' void- #} + +{#fun igraph_personalized_pagerank as ^ + { `IGraph' + , `PagerankAlgo' + , castPtr `Ptr Vector' + , id `Ptr CDouble' + , castPtr %`Ptr VertexSelector' + , `Bool' + , `Double' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , id `Ptr ()' + } -> `CInt' void- #} diff --git a/src/IGraph/Algorithms/Clique.chs b/src/IGraph/Algorithms/Clique.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Clique.chs @@ -0,0 +1,50 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Algorithms.Clique + ( cliques + , largestCliques + , maximalCliques + , cliqueNumber + ) where + +import Control.Applicative ((<$>)) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Foreign.Ptr as C2HSImp +import Foreign + +import IGraph +import IGraph.Internal.C2HS +{#import IGraph.Internal #} + +#include "haskell_igraph.h" + +cliques :: Graph d v e + -> (Int, Int) -- ^ Minimum and maximum size of the cliques to be returned. + -- No bound will be used if negative or zero + -> [[Int]] -- ^ cliques represented by node ids +cliques gr (lo, hi) = unsafePerformIO $ allocaVectorPtr $ \vptr -> do + igraphCliques (_graph gr) vptr lo hi + (map.map) truncate <$> toLists vptr +{#fun igraph_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #} + +largestCliques :: Graph d v e -> [[Int]] +largestCliques gr = unsafePerformIO $ allocaVectorPtr $ \vptr -> do + igraphLargestCliques (_graph gr) vptr + (map.map) truncate <$> toLists vptr +{#fun igraph_largest_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr' } -> `CInt' void- #} + +maximalCliques :: Graph d v e + -> (Int, Int) -- ^ Minimum and maximum size of the cliques to be returned. + -- No bound will be used if negative or zero + -> [[Int]] -- ^ cliques represented by node ids +maximalCliques gr (lo, hi) = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do + igraphMaximalCliques (_graph gr) vpptr lo hi + (map.map) truncate <$> toLists vpptr +{#fun igraph_maximal_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #} + +cliqueNumber :: Graph d v e -> Int +cliqueNumber gr = unsafePerformIO $ igraphCliqueNumber $ _graph gr +{#fun igraph_clique_number as ^ + { `IGraph' + , alloca- `Int' peekIntConv* + } -> `CInt' void- #} diff --git a/src/IGraph/Algorithms/Community.chs b/src/IGraph/Algorithms/Community.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Community.chs @@ -0,0 +1,134 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +module IGraph.Algorithms.Community + ( modularity + , findCommunity + , CommunityMethod(..) + , defaultLeadingEigenvector + , defaultSpinglass + ) where + +import Data.Function (on) +import Data.List (sortBy, groupBy) +import Data.List.Ordered (nubSortBy) +import Data.Ord (comparing) +import System.IO.Unsafe (unsafePerformIO) + +import Foreign +import Foreign.C.Types + +import IGraph +import IGraph.Internal.C2HS +{#import IGraph.Internal #} +{#import IGraph.Internal.Constants #} + +#include "haskell_igraph.h" + +modularity :: Graph d v e + -> [[Int]] -- ^ Communities. + -> Maybe [Double] -- ^ Weights + -> Double +modularity gr clusters ws + | length nds /= length (concat clusters) = error "Duplicated nodes" + | nds /= nodes gr = error "Some nodes were not given community assignments" + | otherwise = unsafePerformIO $ withList membership $ \membership' -> + withListMaybe ws (igraphModularity (_graph gr) membership') + where + (membership, nds) = unzip $ nubSortBy (comparing snd) $ concat $ + zipWith f [0 :: Int ..] clusters + where + f i xs = zip (repeat i) xs +{#fun igraph_modularity as ^ + { `IGraph' + , castPtr `Ptr Vector' + , alloca- `Double' peekFloatConv* + , castPtr `Ptr Vector' + } -> `CInt' void- #} + +data CommunityMethod = + LeadingEigenvector + { _nIter :: Int -- ^ number of iterations, default is 10000 + } + | Spinglass + { _nSpins :: Int -- ^ number of spins, default is 25 + , _startTemp :: Double -- ^ the temperature at the start + , _stopTemp :: Double -- ^ the algorithm stops at this temperature + , _coolFact :: Double -- ^ the cooling factor for the simulated annealing + , _gamma :: Double -- ^ the gamma parameter of the algorithm. + } + +defaultLeadingEigenvector :: CommunityMethod +defaultLeadingEigenvector = LeadingEigenvector 10000 + +defaultSpinglass :: CommunityMethod +defaultSpinglass = Spinglass + { _nSpins = 25 + , _startTemp = 1.0 + , _stopTemp = 0.01 + , _coolFact = 0.99 + , _gamma = 1.0 } + +findCommunity :: Graph 'U v e + -> Maybe [Double] -- ^ node weights + -> CommunityMethod -- ^ Community finding algorithms + -> [[Int]] +findCommunity gr ws method = unsafePerformIO $ allocaVector $ \result -> + withListMaybe ws $ \ws' -> do + case method of + LeadingEigenvector n -> allocaArpackOpt $ \arpack -> + igraphCommunityLeadingEigenvector (_graph gr) ws' nullPtr result + n arpack nullPtr False + nullPtr nullPtr nullPtr + nullFunPtr nullPtr + Spinglass{..} -> igraphCommunitySpinglass (_graph gr) ws' nullPtr nullPtr result + nullPtr _nSpins False _startTemp + _stopTemp _coolFact + IgraphSpincommUpdateConfig _gamma + IgraphSpincommImpOrig 1.0 + + fmap ( map (fst . unzip) . groupBy ((==) `on` snd) + . sortBy (comparing snd) . zip [0..] ) $ toList result + +{#fun igraph_community_spinglass as ^ + { `IGraph' + , castPtr `Ptr Vector' + , id `Ptr CDouble' + , id `Ptr CDouble' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , `Int' + , `Bool' + , `Double' + , `Double' + , `Double' + , `SpincommUpdate' + , `Double' + , `SpinglassImplementation' + , `Double' + } -> `CInt' void- #} + +{#fun igraph_community_leading_eigenvector as ^ + { `IGraph' + , castPtr `Ptr Vector' + , castPtr `Ptr Matrix' + , castPtr `Ptr Vector' + , `Int' + , castPtr `Ptr ArpackOpt' + , id `Ptr CDouble' + , `Bool' + , castPtr `Ptr Vector' + , castPtr `Ptr VectorPtr' + , castPtr `Ptr Vector' + , id `T' + , id `Ptr ()' + } -> `CInt' void- #} + +type T = FunPtr ( Ptr () + -> CLong + -> CDouble + -> Ptr () + -> FunPtr (Ptr CDouble -> Ptr CDouble -> CInt -> Ptr () -> IO CInt) + -> Ptr () + -> Ptr () + -> IO CInt) diff --git a/src/IGraph/Algorithms/Generators.chs b/src/IGraph/Algorithms/Generators.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Generators.chs @@ -0,0 +1,127 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module IGraph.Algorithms.Generators + ( full + , star + , ring + , ErdosRenyiModel(..) + , erdosRenyiGame + , degreeSequenceGame + , rewire + ) where + +import Data.Serialize (Serialize) +import Data.Singletons (SingI, Sing, sing, fromSing) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Map.Strict as M + +import qualified Foreign.Ptr as C2HSImp +import Foreign + +import IGraph +import IGraph.Mutable (MGraph(..)) +{#import IGraph.Internal #} +{#import IGraph.Internal.Constants #} +{# import IGraph.Internal.Initialization #} + +#include "haskell_igraph.h" + +full :: forall d. SingI d + => Int -- ^ The number of vertices in the graph. + -> Bool -- ^ Whether to include self-edges (loops) + -> Graph d () () +full n hasLoop = unsafePerformIO $ do + igraphInit + gr <- igraphFull n directed hasLoop + initializeNullAttribute gr + return $ Graph gr M.empty + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False +{#fun igraph_full as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Int', `Bool', `Bool' + } -> `CInt' void- #} + +-- | Return the Star graph. The center node is always associated with id 0. +star :: Int -- ^ The number of nodes + -> Graph 'U () () +star n = unsafePerformIO $ do + igraphInit + gr <- igraphStar n IgraphStarUndirected 0 + initializeNullAttribute gr + return $ Graph gr M.empty +{#fun igraph_star as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Int' + , `StarMode' + , `Int' + } -> `CInt' void- #} + +-- | Creates a ring graph, a one dimensional lattice. +ring :: Int -> Graph 'U () () +ring n = unsafePerformIO $ do + igraphInit + gr <- igraphRing n False False True + initializeNullAttribute gr + return $ Graph gr M.empty +{#fun igraph_ring as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Int' + , `Bool' + , `Bool' + , `Bool' + } -> `CInt' void- #} + +data ErdosRenyiModel = GNP Int Double + | GNM Int Int + +erdosRenyiGame :: forall d. SingI d + => ErdosRenyiModel + -> Bool -- ^ self-loop + -> IO (Graph d () ()) +erdosRenyiGame model self = do + igraphInit + gr <- case model of + GNP n p -> igraphErdosRenyiGame IgraphErdosRenyiGnp n p directed self + GNM n m -> igraphErdosRenyiGame IgraphErdosRenyiGnm n (fromIntegral m) + directed self + initializeNullAttribute gr + return $ Graph gr M.empty + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False +{#fun igraph_erdos_renyi_game as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `ErdosRenyi', `Int', `Double', `Bool', `Bool' + } -> `CInt' void- #} + +-- | Generates a random graph with a given degree sequence. +degreeSequenceGame :: [Int] -- ^ Out degree + -> [Int] -- ^ In degree + -> IO (Graph 'D () ()) +degreeSequenceGame out_deg in_deg = do + igraphInit + withList out_deg $ \out_deg' -> + withList in_deg $ \in_deg' -> do + gr <- igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple + initializeNullAttribute gr + return $ Graph gr M.empty +{#fun igraph_degree_sequence_game as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , castPtr `Ptr Vector', castPtr `Ptr Vector', `Degseq' + } -> `CInt' void- #} + +-- | Randomly rewires a graph while preserving the degree distribution. +rewire :: (Serialize v, Ord v, Serialize e) + => Int -- ^ Number of rewiring trials to perform. + -> Graph d v e + -> IO (Graph d v e) +rewire n gr = do + gr' <- thaw gr + igraphRewire (_mgraph gr') n IgraphRewiringSimple + unsafeFreeze gr' +{#fun igraph_rewire as ^ { `IGraph', `Int', `Rewiring' } -> `CInt' void-#} diff --git a/src/IGraph/Algorithms/Isomorphism.chs b/src/IGraph/Algorithms/Isomorphism.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Isomorphism.chs @@ -0,0 +1,87 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +module IGraph.Algorithms.Isomorphism + ( getSubisomorphisms + , isomorphic + , isoclassCreate + , isoclass3 + , isoclass4 + ) where + +import System.IO.Unsafe (unsafePerformIO) +import Data.Singletons (SingI, Sing, sing, fromSing) + +import Foreign +import Foreign.C.Types + +import IGraph +import IGraph.Internal.Initialization (igraphInit) +{#import IGraph.Internal #} + +#include "haskell_igraph.h" + +getSubisomorphisms :: Graph d v1 e1 -- ^ graph to be searched in + -> Graph d v2 e2 -- ^ smaller graph + -> [[Int]] +getSubisomorphisms g1 g2 = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do + igraphGetSubisomorphismsVf2 gptr1 gptr2 nullPtr nullPtr nullPtr nullPtr vpptr + nullFunPtr nullFunPtr nullPtr + (map.map) truncate <$> toLists vpptr + where + gptr1 = _graph g1 + gptr2 = _graph g2 +{-# INLINE getSubisomorphisms #-} +{#fun igraph_get_subisomorphisms_vf2 as ^ + { `IGraph' + , `IGraph' + , id `Ptr ()' + , id `Ptr ()' + , id `Ptr ()' + , id `Ptr ()' + , castPtr `Ptr VectorPtr' + , id `FunPtr (Ptr IGraph -> Ptr IGraph -> CInt -> CInt -> Ptr () -> IO CInt)' + , id `FunPtr (Ptr IGraph -> Ptr IGraph -> CInt -> CInt -> Ptr () -> IO CInt)' + , id `Ptr ()' + } -> `CInt' void- #} + +-- | Determine whether two graphs are isomorphic. +isomorphic :: Graph d v1 e1 + -> Graph d v2 e2 + -> Bool +isomorphic g1 g2 = unsafePerformIO $ alloca $ \ptr -> do + _ <- igraphIsomorphic (_graph g1) (_graph g2) ptr + x <- peek ptr + return (x /= 0) +{#fun igraph_isomorphic as ^ { `IGraph', `IGraph', id `Ptr CInt' } -> `CInt' void- #} + +-- | Creates a graph from the given isomorphism class. +-- This function is implemented only for graphs with three or four vertices. +isoclassCreate :: forall d. SingI d + => Int -- ^ The number of vertices to add to the graph. + -> Int -- ^ The isomorphism class + -> Graph d () () +isoclassCreate size idx = unsafePerformIO $ do + gp <- igraphInit >> igraphIsoclassCreate size idx directed + return $ Graph gp $ mkLabelToId gp + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False +{#fun igraph_isoclass_create as ^ + { allocaIGraph- `IGraph' addIGraphFinalizer* + , `Int', `Int', `Bool' + } -> `CInt' void- #} + +isoclass3 :: forall d. SingI d => [Graph d () ()] +isoclass3 = map (isoclassCreate 3) (if directed then [0..15] else [0..3]) + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False + +isoclass4 :: forall d. SingI d => [Graph d () ()] +isoclass4 = map (isoclassCreate 4) (if directed then [0..217] else [0..10]) + where + directed = case fromSing (sing :: Sing d) of + D -> True + U -> False diff --git a/src/IGraph/Algorithms/Layout.chs b/src/IGraph/Algorithms/Layout.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Layout.chs @@ -0,0 +1,113 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module IGraph.Algorithms.Layout + ( getLayout + , LayoutMethod(..) + , defaultKamadaKawai + , defaultLGL + ) where + +import Data.Maybe (isJust) +import Foreign (nullPtr) + +import Foreign + +import IGraph +{#import IGraph.Internal #} + +#include "igraph/igraph.h" + +data LayoutMethod = + KamadaKawai { kk_seed :: !(Maybe [(Double, Double)]) + , kk_nIter :: !Int + , kk_sigma :: (Int -> Double) -- ^ The base standard deviation of + -- position change proposals + , kk_startTemp :: !Double -- ^ The initial temperature for the annealing + , kk_coolFact :: !Double -- ^ The cooling factor for the simulated annealing + , kk_const :: (Int -> Double) -- ^ The Kamada-Kawai vertex attraction constant + } + | LGL { lgl_nIter :: !Int + , lgl_maxdelta :: (Int -> Double) -- ^ The maximum length of the move allowed + -- for a vertex in a single iteration. A reasonable default is the number of vertices. + , lgl_area :: (Int -> Double) -- ^ This parameter gives the area + -- of the square on which the vertices will be placed. A reasonable + -- default value is the number of vertices squared. + , lgl_coolexp :: !Double -- ^ The cooling exponent. A reasonable default value is 1.5. + , lgl_repulserad :: (Int -> Double) -- ^ Determines the radius at which + -- vertex-vertex repulsion cancels out attraction of adjacent vertices. + -- A reasonable default value is area times the number of vertices. + , lgl_cellsize :: (Int -> Double) + } + +defaultKamadaKawai :: LayoutMethod +defaultKamadaKawai = KamadaKawai + { kk_seed = Nothing + , kk_nIter = 10 + , kk_sigma = \x -> fromIntegral x / 4 + , kk_startTemp = 10 + , kk_coolFact = 0.99 + , kk_const = \x -> fromIntegral $ x^2 + } + +defaultLGL :: LayoutMethod +defaultLGL = LGL + { lgl_nIter = 100 + , lgl_maxdelta = \x -> fromIntegral x + , lgl_area = area + , lgl_coolexp = 1.5 + , lgl_repulserad = \x -> fromIntegral x * area x + , lgl_cellsize = \x -> area x ** 0.25 + } + where + area x = fromIntegral $ x^2 + +getLayout :: Graph d v e -> LayoutMethod -> IO [(Double, Double)] +getLayout gr method = case method of + KamadaKawai seed niter sigma initemp coolexp kkconst -> case seed of + Nothing -> allocaMatrix $ \mat -> do + igraphLayoutKamadaKawai gptr mat niter (sigma n) initemp coolexp + (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr + [x, y] <- toColumnLists mat + return $ zip x y + Just xs -> if length xs /= nNodes gr + then error "Seed error: incorrect size" + else withRowLists ((\(x,y) -> [x,y]) (unzip xs)) $ \mat -> do + igraphLayoutKamadaKawai gptr mat niter (sigma n) initemp coolexp + (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr + [x, y] <- toColumnLists mat + return $ zip x y + + LGL niter delta area coolexp repulserad cellsize -> allocaMatrix $ \mat -> do + igraphLayoutLgl gptr mat niter (delta n) (area n) coolexp + (repulserad n) (cellsize n) (-1) + [x, y] <- toColumnLists mat + return $ zip x y + where + n = nNodes gr + gptr = _graph gr + +{#fun igraph_layout_kamada_kawai as ^ + { `IGraph' + , castPtr `Ptr Matrix' + , `Int' + , `Double' + , `Double' + , `Double' + , `Double' + , `Bool' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + } -> `CInt' void- #} + +{# fun igraph_layout_lgl as ^ + { `IGraph' + , castPtr `Ptr Matrix' + , `Int' + , `Double' + , `Double' + , `Double' + , `Double' + , `Double' + , `Int' + } -> `CInt' void- #} diff --git a/src/IGraph/Algorithms/Motif.chs b/src/IGraph/Algorithms/Motif.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Motif.chs @@ -0,0 +1,69 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DataKinds #-} +module IGraph.Algorithms.Motif + ( triad + , triadCensus + ) where + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign + +import IGraph +{#import IGraph.Internal #} + +#include "haskell_igraph.h" + +-- | Every triple of vertices in a directed graph +-- 003: A, B, C, the empty graph. +-- 012: A->B, C, a graph with a single directed edge. +-- 102: A<->B, C, a graph with a mutual connection between two vertices. +-- 021D: A<-B->C, the binary out-tree. +-- 021U: A->B<-C, the binary in-tree. +-- 021C: A->B->C, the directed line. +-- 111D: A<->B<-C. +-- 111U: A<->B->C. +-- 030T: A->B<-C, A->C. Feed forward loop. +-- 030C: A<-B<-C, A->C. +-- 201: A<->B<->C. +-- 120D: A<-B->C, A<->C. +-- 120U: A->B<-C, A<->C. +-- 120C: A->B->C, A<->C. +-- 210: A->B<->C, A<->C. +-- 300: A<->B<->C, A<->C, the complete graph. +triad :: [Graph 'D () ()] +triad = map make edgeList + where + edgeList = + [ [] + , [(0,1)] + , [(0,1), (1,0)] + , [(1,0), (1,2)] + , [(0,1), (2,1)] + , [(0,1), (1,2)] + , [(0,1), (1,0), (2,1)] + , [(0,1), (1,0), (1,2)] + , [(0,1), (2,1), (0,2)] + , [(1,0), (2,1), (0,2)] + , [(0,1), (1,0), (0,2), (2,0)] + , [(1,0), (1,2), (0,2), (2,0)] + , [(0,1), (2,1), (0,2), (2,0)] + , [(0,1), (1,2), (0,2), (2,0)] + , [(0,1), (1,2), (2,1), (0,2), (2,0)] + , [(0,1), (1,0), (1,2), (2,1), (0,2), (2,0)] + ] + make :: [(Int, Int)] -> Graph 'D () () + make xs = mkGraph (replicate 3 ()) $ zip xs $ repeat () + +triadCensus :: (Ord v, Read v) => Graph d v e -> [Int] +triadCensus gr = unsafePerformIO $ allocaVector $ \result -> do + igraphTriadCensus (_graph gr) result + map truncate <$> toList result + +-- motifsRandesu + +{#fun igraph_triad_census as ^ { `IGraph' + , castPtr `Ptr Vector' } -> `CInt' void- #} + +{#fun igraph_motifs_randesu as ^ { `IGraph', castPtr `Ptr Vector', `Int' + , castPtr `Ptr Vector' } -> `CInt' void- #} diff --git a/src/IGraph/Algorithms/Structure.chs b/src/IGraph/Algorithms/Structure.chs new file mode 100644 --- /dev/null +++ b/src/IGraph/Algorithms/Structure.chs @@ -0,0 +1,130 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DataKinds #-} +module IGraph.Algorithms.Structure + ( -- * Shortest Path Related Functions + getShortestPath + , inducedSubgraph + , isConnected + , isStronglyConnected + , decompose + , isDag + , topSort + , topSortUnsafe + ) where + +import Control.Monad +import Data.Serialize (Serialize) +import Data.List (foldl') +import System.IO.Unsafe (unsafePerformIO) +import Data.Maybe +import Data.Singletons (SingI) + +import Foreign +import Foreign.C.Types + +import IGraph +import IGraph.Internal.C2HS +{#import IGraph.Internal #} +{#import IGraph.Internal.Constants #} + +#include "haskell_igraph.h" + +{#fun igraph_shortest_paths as ^ + { `IGraph' + , castPtr `Ptr Matrix' + , castPtr %`Ptr VertexSelector' + , castPtr %`Ptr VertexSelector' + , `Neimode' + } -> `CInt' void- #} + +-- Calculates and returns a single unweighted shortest path from a given vertex +-- to another one. If there are more than one shortest paths between the two +-- vertices, then an arbitrary one is returned. +getShortestPath :: Graph d v e + -> Node -- ^ The id of the source vertex. + -> Node -- ^ The id of the target vertex. + -> [Node] +getShortestPath gr s t = unsafePerformIO $ allocaVector $ \path -> do + igraphGetShortestPath (_graph gr) path nullPtr s t IgraphOut + map truncate <$> toList path +{#fun igraph_get_shortest_path as ^ + { `IGraph' + , castPtr `Ptr Vector' + , castPtr `Ptr Vector' + , `Int' + , `Int' + , `Neimode' + } -> `CInt' void- #} + +inducedSubgraph :: (Ord v, Serialize v) + => Graph d v e + -> [Int] + -> Graph d v e +inducedSubgraph gr nds = unsafePerformIO $ withVerticesList nds $ \vs -> + igraphInducedSubgraph (_graph gr) vs IgraphSubgraphCreateFromScratch >>= + (\g -> return $ Graph g $ mkLabelToId g) +{#fun igraph_induced_subgraph as ^ + { `IGraph' + , allocaIGraph- `IGraph' addIGraphFinalizer* + , castPtr %`Ptr VertexSelector' + , `SubgraphImplementation' + } -> `CInt' void- #} + +-- | Decides whether the graph is weakly connected. +isConnected :: Graph d v e -> Bool +isConnected gr = igraphIsConnected (_graph gr) IgraphWeak + +isStronglyConnected :: Graph 'D v e -> Bool +isStronglyConnected gr = igraphIsConnected (_graph gr) IgraphStrong + +{#fun pure igraph_is_connected as ^ + { `IGraph' + , alloca- `Bool' peekBool* + , `Connectedness' + } -> `CInt' void- #} + +-- | Decompose a graph into connected components. +decompose :: (Ord v, Serialize v) + => Graph d v e -> [Graph d v e] +decompose gr = unsafePerformIO $ allocaVectorPtr $ \ptr -> do + igraphDecompose (_graph gr) ptr IgraphWeak (-1) 1 + n <- igraphVectorPtrSize ptr + forM [0..n-1] $ \i -> do + p <- igraphVectorPtrE ptr i + addIGraphFinalizer (castPtr p) >>= (\g -> return $ Graph g $ mkLabelToId g) +{-# INLINE decompose #-} +{#fun igraph_decompose as ^ + { `IGraph' + , castPtr `Ptr VectorPtr' + , `Connectedness' + , `Int' + , `Int' + } -> `CInt' void- #} + + +-- | Checks whether a graph is a directed acyclic graph (DAG) or not. +isDag :: Graph d v e -> Bool +isDag = igraphIsDag . _graph +{#fun pure igraph_is_dag as ^ + { `IGraph' + , alloca- `Bool' peekBool* + } -> `CInt' void- #} + +-- | Calculate a possible topological sorting of the graph. +topSort :: Graph d v e -> [Node] +topSort gr | isDag gr = topSortUnsafe gr + | otherwise = error "the graph is not acyclic" + +-- | Calculate a possible topological sorting of the graph. If the graph is not +-- acyclic (it has at least one cycle), a partial topological sort is returned. +topSortUnsafe :: Graph d v e -> [Node] +topSortUnsafe gr = unsafePerformIO $ allocaVectorN n $ \res -> do + igraphTopologicalSorting (_graph gr) res IgraphOut + map truncate <$> toList res + where + n = nNodes gr +{#fun igraph_topological_sorting as ^ + { `IGraph' + , castPtr `Ptr Vector' + , `Neimode' + } -> `CInt' void- #} diff --git a/src/IGraph/Clique.chs b/src/IGraph/Clique.chs deleted file mode 100644 --- a/src/IGraph/Clique.chs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Clique - ( cliques - , largestCliques - , maximalCliques - , cliqueNumber - ) where - -import Control.Applicative ((<$>)) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Foreign.Ptr as C2HSImp -import Foreign - -import IGraph -import IGraph.Internal.C2HS -{#import IGraph.Internal #} - -#include "haskell_igraph.h" - -cliques :: Graph d v e - -> (Int, Int) -- ^ Minimum and maximum size of the cliques to be returned. - -- No bound will be used if negative or zero - -> [[Int]] -- ^ cliques represented by node ids -cliques gr (lo, hi) = unsafePerformIO $ allocaVectorPtr $ \vptr -> do - igraphCliques (_graph gr) vptr lo hi - (map.map) truncate <$> toLists vptr -{#fun igraph_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #} - -largestCliques :: Graph d v e -> [[Int]] -largestCliques gr = unsafePerformIO $ allocaVectorPtr $ \vptr -> do - igraphLargestCliques (_graph gr) vptr - (map.map) truncate <$> toLists vptr -{#fun igraph_largest_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr' } -> `CInt' void- #} - -maximalCliques :: Graph d v e - -> (Int, Int) -- ^ Minimum and maximum size of the cliques to be returned. - -- No bound will be used if negative or zero - -> [[Int]] -- ^ cliques represented by node ids -maximalCliques gr (lo, hi) = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do - igraphMaximalCliques (_graph gr) vpptr lo hi - (map.map) truncate <$> toLists vpptr -{#fun igraph_maximal_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #} - -cliqueNumber :: Graph d v e -> Int -cliqueNumber gr = unsafePerformIO $ igraphCliqueNumber $ _graph gr -{#fun igraph_clique_number as ^ - { `IGraph' - , alloca- `Int' peekIntConv* - } -> `CInt' void- #} diff --git a/src/IGraph/Community.chs b/src/IGraph/Community.chs deleted file mode 100644 --- a/src/IGraph/Community.chs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} -module IGraph.Community - ( modularity - , findCommunity - , CommunityMethod(..) - , defaultLeadingEigenvector - , defaultSpinglass - ) where - -import Data.Function (on) -import Data.List (sortBy, groupBy) -import Data.List.Ordered (nubSortBy) -import Data.Ord (comparing) -import System.IO.Unsafe (unsafePerformIO) - -import Foreign -import Foreign.C.Types - -import IGraph -import IGraph.Internal.C2HS -{#import IGraph.Internal #} -{#import IGraph.Internal.Constants #} - -#include "haskell_igraph.h" - -modularity :: Graph d v e - -> [[Int]] -- ^ Communities. - -> Maybe [Double] -- ^ Weights - -> Double -modularity gr clusters ws - | length nds /= length (concat clusters) = error "Duplicated nodes" - | nds /= nodes gr = error "Some nodes were not given community assignments" - | otherwise = unsafePerformIO $ withList membership $ \membership' -> - withListMaybe ws (igraphModularity (_graph gr) membership') - where - (membership, nds) = unzip $ nubSortBy (comparing snd) $ concat $ - zipWith f [0 :: Int ..] clusters - where - f i xs = zip (repeat i) xs -{#fun igraph_modularity as ^ - { `IGraph' - , castPtr `Ptr Vector' - , alloca- `Double' peekFloatConv* - , castPtr `Ptr Vector' - } -> `CInt' void- #} - -data CommunityMethod = - LeadingEigenvector - { _nIter :: Int -- ^ number of iterations, default is 10000 - } - | Spinglass - { _nSpins :: Int -- ^ number of spins, default is 25 - , _startTemp :: Double -- ^ the temperature at the start - , _stopTemp :: Double -- ^ the algorithm stops at this temperature - , _coolFact :: Double -- ^ the cooling factor for the simulated annealing - , _gamma :: Double -- ^ the gamma parameter of the algorithm. - } - -defaultLeadingEigenvector :: CommunityMethod -defaultLeadingEigenvector = LeadingEigenvector 10000 - -defaultSpinglass :: CommunityMethod -defaultSpinglass = Spinglass - { _nSpins = 25 - , _startTemp = 1.0 - , _stopTemp = 0.01 - , _coolFact = 0.99 - , _gamma = 1.0 } - -findCommunity :: Graph 'U v e - -> Maybe [Double] -- ^ node weights - -> CommunityMethod -- ^ Community finding algorithms - -> [[Int]] -findCommunity gr ws method = unsafePerformIO $ allocaVector $ \result -> - withListMaybe ws $ \ws' -> do - case method of - LeadingEigenvector n -> allocaArpackOpt $ \arpack -> - igraphCommunityLeadingEigenvector (_graph gr) ws' nullPtr result - n arpack nullPtr False - nullPtr nullPtr nullPtr - nullFunPtr nullPtr - Spinglass{..} -> igraphCommunitySpinglass (_graph gr) ws' nullPtr nullPtr result - nullPtr _nSpins False _startTemp - _stopTemp _coolFact - IgraphSpincommUpdateConfig _gamma - IgraphSpincommImpOrig 1.0 - - fmap ( map (fst . unzip) . groupBy ((==) `on` snd) - . sortBy (comparing snd) . zip [0..] ) $ toList result - -{#fun igraph_community_spinglass as ^ - { `IGraph' - , castPtr `Ptr Vector' - , id `Ptr CDouble' - , id `Ptr CDouble' - , castPtr `Ptr Vector' - , castPtr `Ptr Vector' - , `Int' - , `Bool' - , `Double' - , `Double' - , `Double' - , `SpincommUpdate' - , `Double' - , `SpinglassImplementation' - , `Double' - } -> `CInt' void- #} - -{#fun igraph_community_leading_eigenvector as ^ - { `IGraph' - , castPtr `Ptr Vector' - , castPtr `Ptr Matrix' - , castPtr `Ptr Vector' - , `Int' - , castPtr `Ptr ArpackOpt' - , id `Ptr CDouble' - , `Bool' - , castPtr `Ptr Vector' - , castPtr `Ptr VectorPtr' - , castPtr `Ptr Vector' - , id `T' - , id `Ptr ()' - } -> `CInt' void- #} - -type T = FunPtr ( Ptr () - -> CLong - -> CDouble - -> Ptr () - -> FunPtr (Ptr CDouble -> Ptr CDouble -> CInt -> Ptr () -> IO CInt) - -> Ptr () - -> Ptr () - -> IO CInt) diff --git a/src/IGraph/Exporter/GEXF.hs b/src/IGraph/Exporter/GEXF.hs --- a/src/IGraph/Exporter/GEXF.hs +++ b/src/IGraph/Exporter/GEXF.hs @@ -13,8 +13,8 @@ over) import Data.Colour.SRGB (channelBlue, channelGreen, channelRed, toSRGB24) -import Data.Hashable import Data.Serialize +import Data.Function (on) import Data.Singletons (SingI) import GHC.Generics import IGraph @@ -35,11 +35,10 @@ , _nodeZindex :: Int } deriving (Show, Read, Eq, Generic) +instance Ord NodeAttr where + compare = compare `on` _nodeLabel instance Serialize NodeAttr -instance Hashable NodeAttr where - hashWithSalt salt at = hashWithSalt salt $ _nodeLabel at - defaultNodeAttributes :: NodeAttr defaultNodeAttributes = NodeAttr { _size = 0.15 @@ -58,10 +57,9 @@ , _edgeZindex :: Int } deriving (Show, Read, Eq, Generic) +instance Ord EdgeAttr where + compare = compare `on` _edgeLabel instance Serialize EdgeAttr - -instance Hashable EdgeAttr where - hashWithSalt salt at = hashWithSalt salt $ _edgeLabel at defaultEdgeAttributes :: EdgeAttr defaultEdgeAttributes = EdgeAttr diff --git a/src/IGraph/Generators.chs b/src/IGraph/Generators.chs deleted file mode 100644 --- a/src/IGraph/Generators.chs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -module IGraph.Generators - ( full - , star - , ErdosRenyiModel(..) - , erdosRenyiGame - , degreeSequenceGame - , rewire - ) where - -import Control.Monad (when, forM_) -import Data.Hashable (Hashable) -import Data.Serialize (Serialize) -import Data.Singletons (SingI, Sing, sing, fromSing) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Foreign.Ptr as C2HSImp -import Foreign - -import IGraph -import IGraph.Mutable (MGraph(..)) -import qualified IGraph.Mutable as M -{#import IGraph.Internal #} -{#import IGraph.Internal.Constants #} -{# import IGraph.Internal.Initialization #} - -#include "haskell_igraph.h" - -full :: forall d. SingI d - => Int -- ^ The number of vertices in the graph. - -> Bool -- ^ Whether to include self-edges (loops) - -> Graph d () () -full n hasLoop = unsafePerformIO $ do - gr <- MGraph <$> igraphFull n directed hasLoop - M.initializeNullAttribute gr - unsafeFreeze gr - where - directed = case fromSing (sing :: Sing d) of - D -> True - U -> False -{#fun igraph_full as ^ - { allocaIGraph- `IGraph' addIGraphFinalizer* - , `Int', `Bool', `Bool' - } -> `CInt' void- #} - --- | Return the Star graph. The center node is always associated with id 0. -star :: Int -- ^ The number of nodes - -> Graph 'U () () -star n = unsafePerformIO $ do - gr <- MGraph <$> igraphStar n IgraphStarUndirected 0 - M.initializeNullAttribute gr - unsafeFreeze gr -{# fun igraph_star as ^ - { allocaIGraph- `IGraph' addIGraphFinalizer* - , `Int' - , `StarMode' - , `Int' - } -> `CInt' void- #} - -data ErdosRenyiModel = GNP Int Double - | GNM Int Int - -erdosRenyiGame :: forall d. SingI d - => ErdosRenyiModel - -> Bool -- ^ self-loop - -> IO (Graph d () ()) -erdosRenyiGame model self = do - igraphInit - gr <- fmap MGraph $ case model of - GNP n p -> igraphErdosRenyiGame IgraphErdosRenyiGnp n p directed self - GNM n m -> igraphErdosRenyiGame IgraphErdosRenyiGnm n (fromIntegral m) - directed self - M.initializeNullAttribute gr - unsafeFreeze gr - where - directed = case fromSing (sing :: Sing d) of - D -> True - U -> False -{#fun igraph_erdos_renyi_game as ^ - { allocaIGraph- `IGraph' addIGraphFinalizer* - , `ErdosRenyi', `Int', `Double', `Bool', `Bool' - } -> `CInt' void- #} - --- | Generates a random graph with a given degree sequence. -degreeSequenceGame :: [Int] -- ^ Out degree - -> [Int] -- ^ In degree - -> IO (Graph 'D () ()) -degreeSequenceGame out_deg in_deg = withList out_deg $ \out_deg' -> - withList in_deg $ \in_deg' -> do - gr <- MGraph <$> igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple - M.initializeNullAttribute gr - unsafeFreeze gr -{#fun igraph_degree_sequence_game as ^ - { allocaIGraph- `IGraph' addIGraphFinalizer* - , castPtr `Ptr Vector', castPtr `Ptr Vector', `Degseq' - } -> `CInt' void- #} - --- | Randomly rewires a graph while preserving the degree distribution. -rewire :: (Hashable v, Serialize v, Eq v, Serialize e) - => Int -- ^ Number of rewiring trials to perform. - -> Graph d v e - -> IO (Graph d v e) -rewire n gr = do - (MGraph gptr) <- thaw gr - igraphRewire gptr n IgraphRewiringSimple - unsafeFreeze $ MGraph gptr -{#fun igraph_rewire as ^ { `IGraph', `Int', `Rewiring' } -> `CInt' void-#} diff --git a/src/IGraph/Internal.chs b/src/IGraph/Internal.chs --- a/src/IGraph/Internal.chs +++ b/src/IGraph/Internal.chs @@ -22,6 +22,9 @@ , allocaVectorPtrN , withPtrs , toLists + , igraphVectorPtrSize + , igraphVectorPtrE + , igraphVectorPtrSet -- ** Customized bytestring for storing attributes , BSLen @@ -54,8 +57,12 @@ , withIGraph , allocaIGraph , addIGraphFinalizer + , mkLabelToId + , initializeNullAttribute , igraphNew , igraphCreate + , igraphIsSimple + , igraphHasMultiple -- * Selector and iterator for edge and vertex -- ** Igraph vertex selector @@ -115,8 +122,12 @@ import Data.ByteString (packCStringLen) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.List (transpose) +import qualified Data.Map.Strict as M +import System.IO.Unsafe (unsafePerformIO) +import Data.Either (fromRight) import Data.List.Split (chunksOf) -import Data.Serialize (Serialize, encode) +import Data.Serialize (Serialize, decode, encode) +import Control.Monad.Primitive import Control.Exception (bracket_) import Conduit (ConduitT, yield, liftIO) @@ -127,6 +138,7 @@ {#import IGraph.Internal.Initialization #} {#import IGraph.Internal.Constants #} +import IGraph.Types #include "haskell_attributes.h" #include "haskell_igraph.h" @@ -172,7 +184,7 @@ n <- igraphVectorSize vec allocaArray n $ \ptr -> do igraphVectorCopyTo vec ptr - liftM (map realToFrac) $ peekArray n ptr + map realToFrac <$> peekArray n ptr {-# INLINE toList #-} {#fun igraph_vector_copy_to as ^ { castPtr `Ptr Vector', id `Ptr CDouble' } -> `()' #} @@ -355,6 +367,27 @@ allocaIGraph f = mallocBytes {# sizeof igraph_t #} >>= f {-# INLINE allocaIGraph #-} +mkLabelToId :: (Ord v, Serialize v) => IGraph -> M.Map v [Int] +mkLabelToId gr = unsafePerformIO $ do + n <- igraphVcount gr + fmap (M.fromListWith (++)) $ forM [0..n-1] $ \i -> do + l <- igraphHaskellAttributeVAS gr vertexAttr i >>= toByteString >>= + return . fromRight (error "decode failed") . decode + return (l, [i]) +{-# INLINE mkLabelToId #-} + +initializeNullAttribute :: PrimMonad m + => IGraph + -> m () +initializeNullAttribute gr = unsafePrimToPrim $ do + nn <- igraphVcount gr + unsafePrimToPrim $ withByteStrings (map encode $ replicate nn ()) $ + igraphHaskellAttributeVASSetv gr vertexAttr + ne <- igraphEcount gr + unsafePrimToPrim $ withByteStrings (map encode $ replicate ne ()) $ + igraphHaskellAttributeEASSetv gr edgeAttr +{-# INLINE initializeNullAttribute #-} + addIGraphFinalizer :: Ptr IGraph -> IO IGraph addIGraphFinalizer ptr = do vec <- newForeignPtr igraph_destroy ptr @@ -384,6 +417,17 @@ , `Bool' -- ^ Whether to create a directed graph or not. If yes, -- then the first edge points from the first vertex id in edges -- to the second, etc. + } -> `CInt' void- #} + +-- | A graph is a simple graph if it does not contain loop edges and multiple edges. +{#fun igraph_is_simple as ^ + { `IGraph' + , alloca- `Bool' peekBool* + } -> `CInt' void- #} + +{#fun igraph_has_multiple as ^ + { `IGraph' + , alloca- `Bool' peekBool* } -> `CInt' void- #} {#fun igraph_to_directed as ^ diff --git a/src/IGraph/Internal/C2HS.hs b/src/IGraph/Internal/C2HS.hs --- a/src/IGraph/Internal/C2HS.hs +++ b/src/IGraph/Internal/C2HS.hs @@ -4,7 +4,7 @@ cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum, -- * Composite marshalling functions - peekIntConv, peekFloatConv, + peekIntConv, peekFloatConv, peekBool ) where @@ -64,10 +64,14 @@ -- | Marshalling of numerals -- -{-# INLINE peekIntConv #-} peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b peekIntConv = liftM cIntConv . peek +{-# INLINE peekIntConv #-} -{-# INLINE peekFloatConv #-} +peekBool :: (Storable a, Eq a, Num a) => Ptr a -> IO Bool +peekBool = liftM cToBool . peek +{-# INLINE peekBool #-} + peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b peekFloatConv = liftM cFloatConv . peek +{-# INLINE peekFloatConv #-} diff --git a/src/IGraph/Internal/Constants.chs b/src/IGraph/Internal/Constants.chs --- a/src/IGraph/Internal/Constants.chs +++ b/src/IGraph/Internal/Constants.chs @@ -24,6 +24,9 @@ {#enum igraph_subgraph_implementation_t as SubgraphImplementation {underscoreToCase} deriving (Show, Read, Eq) #} +{#enum igraph_connectedness_t as Connectedness {underscoreToCase} + deriving (Eq) #} + {#enum igraph_pagerank_algo_t as PagerankAlgo {underscoreToCase} deriving (Show, Read, Eq) #} diff --git a/src/IGraph/Isomorphism.chs b/src/IGraph/Isomorphism.chs deleted file mode 100644 --- a/src/IGraph/Isomorphism.chs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE ScopedTypeVariables #-} -module IGraph.Isomorphism - ( getSubisomorphisms - , isomorphic - , isoclassCreate - , isoclass3 - , isoclass4 - ) where - -import System.IO.Unsafe (unsafePerformIO) -import Data.Singletons (SingI, Sing, sing, fromSing) - -import Foreign -import Foreign.C.Types - -import IGraph -import IGraph.Internal.Initialization (igraphInit) -import IGraph.Mutable -{#import IGraph.Internal #} - -#include "haskell_igraph.h" - -getSubisomorphisms :: Graph d v1 e1 -- ^ graph to be searched in - -> Graph d v2 e2 -- ^ smaller graph - -> [[Int]] -getSubisomorphisms g1 g2 = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do - igraphGetSubisomorphismsVf2 gptr1 gptr2 nullPtr nullPtr nullPtr nullPtr vpptr - nullFunPtr nullFunPtr nullPtr - (map.map) truncate <$> toLists vpptr - where - gptr1 = _graph g1 - gptr2 = _graph g2 -{-# INLINE getSubisomorphisms #-} -{#fun igraph_get_subisomorphisms_vf2 as ^ - { `IGraph' - , `IGraph' - , id `Ptr ()' - , id `Ptr ()' - , id `Ptr ()' - , id `Ptr ()' - , castPtr `Ptr VectorPtr' - , id `FunPtr (Ptr IGraph -> Ptr IGraph -> CInt -> CInt -> Ptr () -> IO CInt)' - , id `FunPtr (Ptr IGraph -> Ptr IGraph -> CInt -> CInt -> Ptr () -> IO CInt)' - , id `Ptr ()' - } -> `CInt' void- #} - --- | Determine whether two graphs are isomorphic. -isomorphic :: Graph d v1 e1 - -> Graph d v2 e2 - -> Bool -isomorphic g1 g2 = unsafePerformIO $ alloca $ \ptr -> do - _ <- igraphIsomorphic (_graph g1) (_graph g2) ptr - x <- peek ptr - return (x /= 0) -{#fun igraph_isomorphic as ^ { `IGraph', `IGraph', id `Ptr CInt' } -> `CInt' void- #} - --- | Creates a graph from the given isomorphism class. --- This function is implemented only for graphs with three or four vertices. -isoclassCreate :: forall d. SingI d - => Int -- ^ The number of vertices to add to the graph. - -> Int -- ^ The isomorphism class - -> Graph d () () -isoclassCreate size idx = unsafePerformIO $ do - gp <- igraphInit >> igraphIsoclassCreate size idx directed - unsafeFreeze $ MGraph gp - where - directed = case fromSing (sing :: Sing d) of - D -> True - U -> False -{#fun igraph_isoclass_create as ^ - { allocaIGraph- `IGraph' addIGraphFinalizer* - , `Int', `Int', `Bool' - } -> `CInt' void- #} - -isoclass3 :: forall d. SingI d => [Graph d () ()] -isoclass3 = map (isoclassCreate 3) (if directed then [0..15] else [0..3]) - where - directed = case fromSing (sing :: Sing d) of - D -> True - U -> False - -isoclass4 :: forall d. SingI d => [Graph d () ()] -isoclass4 = map (isoclassCreate 4) (if directed then [0..217] else [0..10]) - where - directed = case fromSing (sing :: Sing d) of - D -> True - U -> False diff --git a/src/IGraph/Layout.chs b/src/IGraph/Layout.chs deleted file mode 100644 --- a/src/IGraph/Layout.chs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Layout - ( getLayout - , LayoutMethod(..) - , defaultKamadaKawai - , defaultLGL - ) where - -import Data.Maybe (isJust) -import Foreign (nullPtr) - -import qualified Foreign.Ptr as C2HSImp -import Foreign - -import IGraph -{#import IGraph.Internal #} - -#include "igraph/igraph.h" - -data LayoutMethod = - KamadaKawai { kk_seed :: !(Maybe [(Double, Double)]) - , kk_nIter :: !Int - , kk_sigma :: (Int -> Double) -- ^ The base standard deviation of - -- position change proposals - , kk_startTemp :: !Double -- ^ The initial temperature for the annealing - , kk_coolFact :: !Double -- ^ The cooling factor for the simulated annealing - , kk_const :: (Int -> Double) -- ^ The Kamada-Kawai vertex attraction constant - } - | LGL { lgl_nIter :: !Int - , lgl_maxdelta :: (Int -> Double) -- ^ The maximum length of the move allowed - -- for a vertex in a single iteration. A reasonable default is the number of vertices. - , lgl_area :: (Int -> Double) -- ^ This parameter gives the area - -- of the square on which the vertices will be placed. A reasonable - -- default value is the number of vertices squared. - , lgl_coolexp :: !Double -- ^ The cooling exponent. A reasonable default value is 1.5. - , lgl_repulserad :: (Int -> Double) -- ^ Determines the radius at which - -- vertex-vertex repulsion cancels out attraction of adjacent vertices. - -- A reasonable default value is area times the number of vertices. - , lgl_cellsize :: (Int -> Double) - } - -defaultKamadaKawai :: LayoutMethod -defaultKamadaKawai = KamadaKawai - { kk_seed = Nothing - , kk_nIter = 10 - , kk_sigma = \x -> fromIntegral x / 4 - , kk_startTemp = 10 - , kk_coolFact = 0.99 - , kk_const = \x -> fromIntegral $ x^2 - } - -defaultLGL :: LayoutMethod -defaultLGL = LGL - { lgl_nIter = 100 - , lgl_maxdelta = \x -> fromIntegral x - , lgl_area = area - , lgl_coolexp = 1.5 - , lgl_repulserad = \x -> fromIntegral x * area x - , lgl_cellsize = \x -> area x ** 0.25 - } - where - area x = fromIntegral $ x^2 - -getLayout :: Graph d v e -> LayoutMethod -> IO [(Double, Double)] -getLayout gr method = case method of - KamadaKawai seed niter sigma initemp coolexp kkconst -> case seed of - Nothing -> allocaMatrix $ \mat -> do - igraphLayoutKamadaKawai gptr mat niter (sigma n) initemp coolexp - (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr - [x, y] <- toColumnLists mat - return $ zip x y - Just xs -> if length xs /= nNodes gr - then error "Seed error: incorrect size" - else withRowLists ((\(x,y) -> [x,y]) (unzip xs)) $ \mat -> do - igraphLayoutKamadaKawai gptr mat niter (sigma n) initemp coolexp - (kkconst n) (isJust seed) nullPtr nullPtr nullPtr nullPtr - [x, y] <- toColumnLists mat - return $ zip x y - - LGL niter delta area coolexp repulserad cellsize -> allocaMatrix $ \mat -> do - igraphLayoutLgl gptr mat niter (delta n) (area n) coolexp - (repulserad n) (cellsize n) (-1) - [x, y] <- toColumnLists mat - return $ zip x y - where - n = nNodes gr - gptr = _graph gr - -{#fun igraph_layout_kamada_kawai as ^ - { `IGraph' - , castPtr `Ptr Matrix' - , `Int' - , `Double' - , `Double' - , `Double' - , `Double' - , `Bool' - , castPtr `Ptr Vector' - , castPtr `Ptr Vector' - , castPtr `Ptr Vector' - , castPtr `Ptr Vector' - } -> `CInt' void- #} - -{# fun igraph_layout_lgl as ^ - { `IGraph' - , castPtr `Ptr Matrix' - , `Int' - , `Double' - , `Double' - , `Double' - , `Double' - , `Double' - , `Int' - } -> `CInt' void- #} diff --git a/src/IGraph/Motif.chs b/src/IGraph/Motif.chs deleted file mode 100644 --- a/src/IGraph/Motif.chs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE DataKinds #-} -module IGraph.Motif - ( triad - , triadCensus - ) where - -import Data.Hashable (Hashable) -import System.IO.Unsafe (unsafePerformIO) - -import Foreign - -import IGraph -{#import IGraph.Internal #} - -#include "haskell_igraph.h" - --- | Every triple of vertices in a directed graph --- 003: A, B, C, the empty graph. --- 012: A->B, C, a graph with a single directed edge. --- 102: A<->B, C, a graph with a mutual connection between two vertices. --- 021D: A<-B->C, the binary out-tree. --- 021U: A->B<-C, the binary in-tree. --- 021C: A->B->C, the directed line. --- 111D: A<->B<-C. --- 111U: A<->B->C. --- 030T: A->B<-C, A->C. Feed forward loop. --- 030C: A<-B<-C, A->C. --- 201: A<->B<->C. --- 120D: A<-B->C, A<->C. --- 120U: A->B<-C, A<->C. --- 120C: A->B->C, A<->C. --- 210: A->B<->C, A<->C. --- 300: A<->B<->C, A<->C, the complete graph. -triad :: [Graph 'D () ()] -triad = map make edgeList - where - edgeList = - [ [] - , [(0,1)] - , [(0,1), (1,0)] - , [(1,0), (1,2)] - , [(0,1), (2,1)] - , [(0,1), (1,2)] - , [(0,1), (1,0), (2,1)] - , [(0,1), (1,0), (1,2)] - , [(0,1), (2,1), (0,2)] - , [(1,0), (2,1), (0,2)] - , [(0,1), (1,0), (0,2), (2,0)] - , [(1,0), (1,2), (0,2), (2,0)] - , [(0,1), (2,1), (0,2), (2,0)] - , [(0,1), (1,2), (0,2), (2,0)] - , [(0,1), (1,2), (2,1), (0,2), (2,0)] - , [(0,1), (1,0), (1,2), (2,1), (0,2), (2,0)] - ] - make :: [(Int, Int)] -> Graph 'D () () - make xs = mkGraph (replicate 3 ()) $ zip xs $ repeat () - -triadCensus :: (Hashable v, Eq v, Read v) => Graph d v e -> [Int] -triadCensus gr = unsafePerformIO $ allocaVector $ \result -> do - igraphTriadCensus (_graph gr) result - map truncate <$> toList result - --- motifsRandesu - -{#fun igraph_triad_census as ^ { `IGraph' - , castPtr `Ptr Vector' } -> `CInt' void- #} - -{#fun igraph_motifs_randesu as ^ { `IGraph', castPtr `Ptr Vector', `Int' - , castPtr `Ptr Vector' } -> `CInt' void- #} diff --git a/src/IGraph/Mutable.hs b/src/IGraph/Mutable.hs --- a/src/IGraph/Mutable.hs +++ b/src/IGraph/Mutable.hs @@ -8,18 +8,20 @@ , nNodes , nEdges , addNodes - , addLNodes , delNodes , addEdges - , addLEdges , delEdges , setEdgeAttr , setNodeAttr - , initializeNullAttribute )where import Control.Monad (forM) import Control.Monad.Primitive +import Data.Either (fromRight) +import Data.Serialize (decode) +import qualified Data.Map.Strict as M +import Data.List (foldl', delete) +import Data.Primitive.MutVar import Data.Serialize (Serialize, encode) import Data.Singletons.Prelude (Sing, SingI, fromSing, sing) import Foreign hiding (new) @@ -29,83 +31,102 @@ import IGraph.Types -- | Mutable labeled graph. -newtype MGraph m (d :: EdgeType) v e = MGraph IGraph +data MGraph m (d :: EdgeType) v e = MGraph + { _mgraph :: IGraph + , _mlabelToNode :: MutVar m (M.Map v [Node]) + } -- | Create a new graph. -new :: forall m d v e. (SingI d, PrimMonad m) - => Int -> m (MGraph (PrimState m) d v e) -new n = unsafePrimToPrim $ igraphInit >>= igraphNew n directed >>= return . MGraph +new :: forall m d v e. (SingI d, Ord v, Serialize v, PrimMonad m) + => [v] -> m (MGraph (PrimState m) d v e) +new nds = do + gr <- unsafePrimToPrim $ do + gr <- igraphInit >>= igraphNew n directed + withAttr vertexAttr nds $ \attr -> + withPtrs [attr] (igraphAddVertices gr n . castPtr) + return gr + m <- newMutVar $ M.fromListWith (++) $ zip nds $ map return [0 .. n - 1] + return $ MGraph gr m where + n = length nds directed = case fromSing (sing :: Sing d) of D -> True U -> False -- | Return the number of nodes in a graph. nNodes :: PrimMonad m => MGraph (PrimState m) d v e -> m Int -nNodes (MGraph gr) = unsafePrimToPrim $ igraphVcount gr +nNodes gr = unsafePrimToPrim $ igraphVcount $ _mgraph gr {-# INLINE nNodes #-} -- | Return the number of edges in a graph. nEdges :: PrimMonad m => MGraph (PrimState m) d v e -> m Int -nEdges (MGraph gr) = unsafePrimToPrim $ igraphEcount gr +nEdges gr = unsafePrimToPrim $ igraphEcount $ _mgraph gr {-# INLINE nEdges #-} --- | Add nodes to the graph. -addNodes :: PrimMonad m - => Int -- ^ The number of new nodes. - -> MGraph(PrimState m) d v e -> m () -addNodes n (MGraph g) = unsafePrimToPrim $ igraphAddVertices g n nullPtr - -- | Add nodes with labels to the graph. -addLNodes :: (Serialize v, PrimMonad m) - => [v] -- ^ vertices' labels - -> MGraph (PrimState m) d v e -> m () -addLNodes labels (MGraph g) = unsafePrimToPrim $ - withAttr vertexAttr labels $ \attr -> - withPtrs [attr] (igraphAddVertices g n . castPtr) +addNodes :: (Ord v, Serialize v, PrimMonad m) + => [v] -- ^ vertices' labels + -> MGraph (PrimState m) d v e -> m () +addNodes labels gr = do + m <- nNodes gr + unsafePrimToPrim $ withAttr vertexAttr labels $ \attr -> + withPtrs [attr] (igraphAddVertices (_mgraph gr) n . castPtr) + modifyMutVar' (_mlabelToNode gr) $ \x -> + foldl' (\acc (k,v) -> M.insertWith (++) k v acc) x $ + zip labels $ map return [m .. m + n - 1] where n = length labels +{-# INLINE addNodes #-} --- | Delete nodes from the graph. -delNodes :: PrimMonad m => [Int] -> MGraph (PrimState m) d v e -> m () -delNodes ns (MGraph g) = unsafePrimToPrim $ withVerticesList ns $ \vs -> - igraphDeleteVertices g vs +-- | Return the label of given node. +nodeLab :: (PrimMonad m, Serialize v) => MGraph (PrimState m) d v e -> Node -> m v +nodeLab gr i = unsafePrimToPrim $ + igraphHaskellAttributeVAS (_mgraph gr) vertexAttr i >>= toByteString >>= + return . fromRight (error "decode failed") . decode +{-# INLINE nodeLab #-} --- | Add edges to the graph. -addEdges :: PrimMonad m => [(Int, Int)] -> MGraph (PrimState m) d v e -> m () -addEdges es (MGraph g) = unsafePrimToPrim $ withList xs $ \vec -> - igraphAddEdges g vec nullPtr - where - xs = concatMap ( \(a,b) -> [a, b] ) es +-- | Delete nodes from the graph. +delNodes :: (PrimMonad m, Ord v, Serialize v) + => [Node] -> MGraph (PrimState m) d v e -> m () +delNodes ns gr = do + unsafePrimToPrim $ withVerticesList ns $ igraphDeleteVertices (_mgraph gr) + writeMutVar (_mlabelToNode gr) $ mkLabelToId $ _mgraph gr +{-# INLINE delNodes #-} -- | Add edges with labels to the graph. -addLEdges :: (PrimMonad m, Serialize e) - => [LEdge e] -> MGraph (PrimState m) d v e -> m () -addLEdges es (MGraph g) = unsafePrimToPrim $ +-- If you also want to add new vertices, call addNodes first. +addEdges :: (PrimMonad m, Serialize e) + => [LEdge e] -> MGraph (PrimState m) d v e -> m () +addEdges es gr = unsafePrimToPrim $ withAttr edgeAttr vs $ \attr -> withList (concat xs) $ \vec -> - withPtrs [attr] (igraphAddEdges g vec . castPtr) + withPtrs [attr] (igraphAddEdges (_mgraph gr) vec . castPtr) where (xs, vs) = unzip $ map ( \((a,b),v) -> ([a, b], v) ) es +{-# INLINE addEdges #-} -- | Delete edges from the graph. delEdges :: forall m d v e. (SingI d, PrimMonad m) - => [(Int, Int)] -> MGraph (PrimState m) d v e -> m () -delEdges es (MGraph g) = unsafePrimToPrim $ do - eids <- forM es $ \(fr, to) -> igraphGetEid g fr to directed True - withEdgeIdsList eids (igraphDeleteEdges g) + => [Edge] -> MGraph (PrimState m) d v e -> m () +delEdges es gr = unsafePrimToPrim $ do + eids <- forM es $ \(fr, to) -> igraphGetEid (_mgraph gr) fr to directed True + withEdgeIdsList eids (igraphDeleteEdges (_mgraph gr)) where directed = case fromSing (sing :: Sing d) of D -> True U -> False -- | Set node attribute. -setNodeAttr :: (PrimMonad m, Serialize v) +setNodeAttr :: (PrimMonad m, Serialize v, Ord v) => Int -- ^ Node id -> v -> MGraph (PrimState m) d v e -> m () -setNodeAttr nodeId x (MGraph gr) = unsafePrimToPrim $ - withByteString (encode x) $ igraphHaskellAttributeVASSet gr vertexAttr nodeId +setNodeAttr nodeId x gr = do + x' <- nodeLab gr nodeId + unsafePrimToPrim $ withByteString (encode x) $ + igraphHaskellAttributeVASSet (_mgraph gr) vertexAttr nodeId + modifyMutVar' (_mlabelToNode gr) $ + M.insertWith (++) x [nodeId] . M.adjust (delete nodeId) x' -- | Set edge attribute. setEdgeAttr :: (PrimMonad m, Serialize e) @@ -113,17 +134,14 @@ -> e -> MGraph (PrimState m) d v e -> m () -setEdgeAttr edgeId x (MGraph gr) = unsafePrimToPrim $ - withByteString (encode x) $ igraphHaskellAttributeEASSet gr edgeAttr edgeId +setEdgeAttr edgeId x gr = unsafePrimToPrim $ + withByteString (encode x) $ igraphHaskellAttributeEASSet (_mgraph gr) edgeAttr edgeId -initializeNullAttribute :: PrimMonad m - => MGraph (PrimState m) d () () - -> m () -initializeNullAttribute gr@(MGraph g) = do - nn <- nNodes gr - unsafePrimToPrim $ withByteStrings (map encode $ replicate nn ()) $ - igraphHaskellAttributeVASSetv g vertexAttr - ne <- nEdges gr - unsafePrimToPrim $ withByteStrings (map encode $ replicate ne ()) $ - igraphHaskellAttributeEASSetv g edgeAttr -{-# INLINE initializeNullAttribute #-} +{- +-- | Removes loop and/or multiple edges from the graph. +simplify :: Bool -- ^ If true, multiple edges will be removed. + -> Bool -- ^ If true, loops (self edges) will be removed. + -> ([e] -> e) -- ^ Edge c + -> Graph d v e -> Graph d v e +simplify delMul delLoop fun gr = do +-} diff --git a/src/IGraph/Read.hs b/src/IGraph/Read.hs deleted file mode 100644 --- a/src/IGraph/Read.hs +++ /dev/null @@ -1,47 +0,0 @@ -module IGraph.Read - ( readAdjMatrix - , fromAdjMatrix - , readAdjMatrixWeighted - ) where - -import qualified Data.ByteString.Char8 as B -import Data.ByteString.Lex.Fractional (readExponential, readSigned) -import Data.Maybe (fromJust) -import Data.Singletons (SingI) - -import IGraph - -readDouble :: B.ByteString -> Double -readDouble = fst . fromJust . readSigned readExponential -{-# INLINE readDouble #-} - -readAdjMatrix :: SingI d => FilePath -> IO (Graph d B.ByteString ()) -readAdjMatrix = fmap fromAdjMatrix . B.readFile - -fromAdjMatrix :: SingI d => B.ByteString -> Graph d B.ByteString () -fromAdjMatrix bs = - let (header:xs) = B.lines bs - mat = map (map readDouble . B.words) xs - es = fst $ unzip $ filter f $ zip [ (i,j) | i <- [0..nrow-1], j <- [0..nrow-1] ] $ concat mat - nrow = length mat - ncol = length $ head mat - in if nrow /= ncol - then error "fromAdjMatrix: nrow != ncol" - else mkGraph (B.words header) $ zip es $ repeat () - where - f ((i,j),v) = i < j && v /= 0 -{-# INLINE fromAdjMatrix #-} - -readAdjMatrixWeighted :: SingI d => FilePath -> IO (Graph d B.ByteString Double) -readAdjMatrixWeighted fl = do - c <- B.readFile fl - let (header:xs) = B.lines c - mat = map (map readDouble . B.words) xs - (es, ws) = unzip $ filter f $ zip [ (i,j) | i <- [0..nrow-1], j <- [0..nrow-1] ] $ concat mat - nrow = length mat - ncol = length $ head mat - if nrow /= ncol - then error "nrow != ncol" - else return $ mkGraph (B.words header) $ zip es ws - where - f ((i,j),v) = i < j && v /= 0 diff --git a/src/IGraph/Structure.chs b/src/IGraph/Structure.chs deleted file mode 100644 --- a/src/IGraph/Structure.chs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module IGraph.Structure - ( inducedSubgraph - , closeness - , betweenness - , eigenvectorCentrality - , pagerank - ) where - -import Control.Monad -import Data.Either (fromRight) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as M -import Data.Serialize (Serialize, decode) -import System.IO.Unsafe (unsafePerformIO) -import Data.Maybe -import Data.Singletons (SingI) - -import Foreign -import Foreign.C.Types - -import IGraph -import IGraph.Mutable (MGraph(..)) -{#import IGraph.Internal #} -{#import IGraph.Internal.Constants #} - -#include "igraph/igraph.h" - -inducedSubgraph :: (Hashable v, Eq v, Serialize v) - => Graph d v e - -> [Int] - -> Graph d v e -inducedSubgraph gr nds = unsafePerformIO $ withVerticesList nds $ \vs -> - igraphInducedSubgraph (_graph gr) vs IgraphSubgraphCreateFromScratch >>= - unsafeFreeze . MGraph -{#fun igraph_induced_subgraph as ^ - { `IGraph' - , allocaIGraph- `IGraph' addIGraphFinalizer* - , castPtr %`Ptr VertexSelector' - , `SubgraphImplementation' - } -> `CInt' void- #} - --- | Closeness centrality -closeness :: [Int] -- ^ vertices - -> Graph d v e - -> Maybe [Double] -- ^ optional edge weights - -> Neimode - -> Bool -- ^ whether to normalize - -> [Double] -closeness nds gr ws mode normal = unsafePerformIO $ allocaVector $ \result -> - withVerticesList nds $ \vs -> withListMaybe ws $ \ws' -> do - igraphCloseness (_graph gr) result vs mode ws' normal - toList result -{#fun igraph_closeness as ^ - { `IGraph' - , castPtr `Ptr Vector' - , castPtr %`Ptr VertexSelector' - , `Neimode' - , castPtr `Ptr Vector' - , `Bool' } -> `CInt' void- #} - - --- | Betweenness centrality -betweenness :: [Int] - -> Graph d v e - -> Maybe [Double] - -> [Double] -betweenness nds gr ws = unsafePerformIO $ allocaVector $ \result -> - withVerticesList nds $ \vs -> withListMaybe ws $ \ws' -> do - igraphBetweenness (_graph gr) result vs True ws' False - toList result -{#fun igraph_betweenness as ^ - { `IGraph' - , castPtr `Ptr Vector' - , castPtr %`Ptr VertexSelector' - , `Bool' - , castPtr `Ptr Vector' - , `Bool' } -> `CInt' void- #} - --- | Eigenvector centrality -eigenvectorCentrality :: Graph d v e - -> Maybe [Double] - -> [Double] -eigenvectorCentrality gr ws = unsafePerformIO $ allocaArpackOpt $ \arparck -> - allocaVector $ \result -> withListMaybe ws $ \ws' -> do - igraphEigenvectorCentrality (_graph gr) result nullPtr True True ws' arparck - toList result -{#fun igraph_eigenvector_centrality as ^ - { `IGraph' - , castPtr `Ptr Vector' - , id `Ptr CDouble' - , `Bool' - , `Bool' - , castPtr `Ptr Vector' - , castPtr `Ptr ArpackOpt' } -> `CInt' void- #} - --- | Google's PageRank algorithm, with option to -pagerank :: SingI d - => Graph d v e - -> Maybe [Double] -- ^ Node weights or reset probability. If provided, - -- the personalized PageRank will be used - -> Maybe [Double] -- ^ Edge weights - -> Double -- ^ damping factor, usually around 0.85 - -> [Double] -pagerank gr reset ws d - | n == 0 = [] - | isJust ws && length (fromJust ws) /= m = error "incorrect length of edge weight vector" - | otherwise = unsafePerformIO $ alloca $ \p -> allocaVector $ \result -> - withVerticesAll $ \vs -> withListMaybe ws $ \ws' -> do - case reset of - Nothing -> igraphPagerank (_graph gr) IgraphPagerankAlgoPrpack - result p vs (isDirected gr) d ws' nullPtr - Just reset' -> withList reset' $ \reset'' -> igraphPersonalizedPagerank - (_graph gr) IgraphPagerankAlgoPrpack result p vs - (isDirected gr) d reset'' ws' nullPtr - toList result - where - n = nNodes gr - m = nEdges gr - -{#fun igraph_pagerank as ^ - { `IGraph' - , `PagerankAlgo' - , castPtr `Ptr Vector' - , id `Ptr CDouble' - , castPtr %`Ptr VertexSelector' - , `Bool' - , `Double' - , castPtr `Ptr Vector' - , id `Ptr ()' - } -> `CInt' void- #} - -{#fun igraph_personalized_pagerank as ^ - { `IGraph' - , `PagerankAlgo' - , castPtr `Ptr Vector' - , id `Ptr CDouble' - , castPtr %`Ptr VertexSelector' - , `Bool' - , `Double' - , castPtr `Ptr Vector' - , castPtr `Ptr Vector' - , id `Ptr ()' - } -> `CInt' void- #} diff --git a/src/IGraph/Types.hs b/src/IGraph/Types.hs --- a/src/IGraph/Types.hs +++ b/src/IGraph/Types.hs @@ -24,7 +24,7 @@ $(singletons [d| data EdgeType = D | U - deriving (Show, Read, Eq, Generic) + deriving (Eq, Generic) |]) instance Serialize EdgeType diff --git a/tests/Test/Algorithms.hs b/tests/Test/Algorithms.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Algorithms.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +module Test.Algorithms + ( tests + ) where + +import Control.Arrow +import Control.Monad.ST +import Data.List +import qualified Data.Matrix.Unboxed as M +import Test.Tasty +import Test.Tasty.HUnit + +import IGraph +import IGraph.Algorithms +import qualified IGraph.Mutable as GM + +tests :: TestTree +tests = testGroup "Algorithms" + [ graphIsomorphism + , motifTest + , cliqueTest + , subGraphs + , decomposeTest + , pagerankTest + ] + +graphIsomorphism :: TestTree +graphIsomorphism = testCase "Graph isomorphism" $ assertBool "" $ + and (zipWith isomorphic triad triad) && + (not . or) (zipWith isomorphic triad $ reverse triad) + +motifTest :: TestTree +motifTest = testGroup "Network motif" + [ testCase "triad Census" $ M.toLists (M.ident 16 :: M.Matrix Int) @=? + map triadCensus triad ] + +cliqueTest :: TestTree +cliqueTest = testGroup "Clique" + [ testCase "case 1" $ sort (map sort $ cliques gr (4,-1)) @=? c4 + , testCase "case 2" $ sort (map sort $ cliques gr (2,2)) @=? c2 + , testCase "case 3" $ sort (map sort $ largestCliques gr) @=? c4 + , testCase "case 4" $ sort (map sort $ cliques gr (-1,-1)) @=? + sort (map sort $ c1 ++ c2 ++ c3 ++ c4) + ] + where + gr = runST $ do + g <- unsafeThaw (full 6 False :: Graph 'U () ()) + GM.delEdges [(0,1), (0,2), (3,5)] g + unsafeFreeze g + c1 = [[0], [1], [2], [3], [4], [5]] + c2 = [ [0,3], [0,4], [0,5], [1,2], [1,3], [1,4], [1,5], [2,3], [2,4] + , [2,5], [3,4], [4,5] ] + c3 = [ [0,3,4], [0,4,5], [1,2,3], [1,2,4], [1,2,5], [1,3,4], [1,4,5], + [2,3,4], [2,4,5] ] + c4 = [[1, 2, 3, 4], [1, 2, 4, 5]] + +subGraphs :: TestTree +subGraphs = testGroup "generate induced subgraphs" + [ testCase "" $ test case1 ] + where + case1 = ( [("a","b"), ("b","c"), ("c","a"), ("a","c")] + , ["a","c"], [("a","c"), ("c","a")] ) + test (ori,ns,expect) = sort expect @=? sort result + where + gr = fromLabeledEdges $ zip ori $ repeat () :: Graph 'D String () + ns' = map (head . getNodes gr) ns + gr' = inducedSubgraph gr ns' + result = map (nodeLab gr' *** nodeLab gr') $ edges gr' + +decomposeTest :: TestTree +decomposeTest = testGroup "Decompose" + [ testCase "ring" $ edges (head $ decompose $ ring 10) @?= + [(0,1), (1,2), (2,3), (3,4), (4,5), (5,6), (6,7), (7,8), (8,9), (0,9)] + , testCase "1 component" $ do + gr <- erdosRenyiGame (GNP 100 (40/100)) False :: IO (Graph 'U () ()) + 1 @?= length (decompose gr) + , testCase "toy example" $ map (sort . edges) (decompose gr) @?= + [ [(0,1), (0,2), (1,2)] + , [(0,1), (1,2), (2,3)] + , [] + , [(0,1), (1,2)] ] + ] + where + es = [ (0,1), (1,2), (2,0) + , (3,4), (4,5), (5,6) + , (8,9), (9,10) ] + gr = mkGraph (replicate 11 ()) $ zip es $ repeat () :: Graph 'U () () + +pagerankTest :: TestTree +pagerankTest = testGroup "PageRank" + [ testCase "case 1" $ ranks @=? ranks' ] + where + gr = star 11 + ranks = [0.47,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05] + ranks' = map ((/100) . fromIntegral . round. (*100)) $ + pagerank gr Nothing Nothing 0.85 diff --git a/tests/Test/Attributes.hs b/tests/Test/Attributes.hs --- a/tests/Test/Attributes.hs +++ b/tests/Test/Attributes.hs @@ -3,14 +3,8 @@ ( tests ) where -import Conduit -import Control.Monad -import Control.Monad.ST import Data.List -import Data.List.Ordered (nubSort) -import Data.Maybe import Data.Serialize -import Foreign import System.IO.Unsafe import Test.Tasty import Test.Tasty.HUnit @@ -20,7 +14,6 @@ import IGraph.Exporter.GEXF import IGraph.Internal import IGraph.Mutable -import IGraph.Structure tests :: TestTree tests = testGroup "Attribute tests" @@ -47,12 +40,12 @@ serializeTest = testCase "serialize test" $ do dat <- randEdges 1000 10000 let es = map ( \(a, b) -> ( - ( defaultNodeAttributes{_nodeZindex=a} - , defaultNodeAttributes{_nodeZindex=b}), defaultEdgeAttributes) ) dat + ( defaultNodeAttributes{_nodeLabel= show a} + , defaultNodeAttributes{_nodeLabel= show b}), defaultEdgeAttributes) ) dat gr = fromLabeledEdges es :: Graph 'D NodeAttr EdgeAttr gr' :: Graph 'D NodeAttr EdgeAttr gr' = case decode $ encode gr of Left msg -> error msg Right r -> r es' = map (\(a,b) -> ((nodeLab gr' a, nodeLab gr' b), edgeLab gr' (a,b))) $ edges gr' - assertBool "" $ sort (map show es) == sort (map show es') + sort (map show es) @=? sort (map show es') diff --git a/tests/Test/Basic.hs b/tests/Test/Basic.hs --- a/tests/Test/Basic.hs +++ b/tests/Test/Basic.hs @@ -3,25 +3,24 @@ ( tests ) where +import Conduit import Control.Monad.ST import Data.List import Data.List.Ordered (nubSort) -import Data.Maybe import System.IO.Unsafe import Test.Tasty import Test.Tasty.HUnit import Test.Utils -import Conduit import IGraph -import qualified IGraph.Mutable as GM -import IGraph.Structure +import qualified IGraph.Mutable as GM tests :: TestTree tests = testGroup "Basic tests" [ graphCreation , graphCreationLabeled , graphEdit + , nonSimpleGraphTest ] graphCreation :: TestTree @@ -55,10 +54,31 @@ graphEdit :: TestTree graphEdit = testGroup "Graph editing" - [ testCase "" $ [(1,2)] @=? (sort $ edges simple') ] + [ testCase "case 1" $ [((1,2), 'b')] @=? sort (getEdges simple') + , testCase "case 2" $ [((0,2), 'c')] @=? sort (getEdges $ delNodes [1] simple) + , testCase "case 3" $ 2 @=? + (let gr = delNodes [1] simple in nodeLab gr $ head $ getNodes gr 2) + , testCase "case 4" $ 4 @=? + (let gr = addNodes [3,4,5] simple in nodeLab gr $ head $ getNodes gr 4) + ] where - simple = mkGraph (replicate 3 ()) $ zip [(0,1),(1,2),(2,0)] $ repeat () :: Graph 'U () () + simple = mkGraph [0,1,2] $ + [ ((0,1), 'a'), ((1,2), 'b'), ((0,2), 'c') ] :: Graph 'U Int Char simple' = runST $ do g <- thaw simple GM.delEdges [(0,1),(0,2)] g freeze g + getEdges gr = map + (\(a,b) -> ((nodeLab gr a, nodeLab gr b), edgeLab gr (a,b))) $ edges gr + +nonSimpleGraphTest :: TestTree +nonSimpleGraphTest = testGroup "loops, multiple edges" + [ testCase "case 1" $ es @=? labEdges gr + ] + where + es = [ ((0,1), 'a') + , ((1,2), 'b') + , ((1,2), 'c') + , ((0,2), 'd') ] + gr :: Graph 'U Int Char + gr = mkGraph [0,1,2] es diff --git a/tests/Test/Clique.hs b/tests/Test/Clique.hs deleted file mode 100644 --- a/tests/Test/Clique.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Test.Clique - ( tests - ) where - -import Control.Monad.ST -import Data.List -import System.IO.Unsafe -import Test.Tasty -import Test.Tasty.HUnit -import Test.Utils - -import IGraph -import IGraph.Clique -import IGraph.Generators -import IGraph.Mutable - -tests :: TestTree -tests = testGroup "Clique" - [ testCase "case 1" $ sort (map sort $ cliques gr (4,-1)) @=? c4 - , testCase "case 2" $ sort (map sort $ cliques gr (2,2)) @=? c2 - , testCase "case 3" $ sort (map sort $ largestCliques gr) @=? c4 - , testCase "case 4" $ sort (map sort $ cliques gr (-1,-1)) @=? - sort (map sort $ c1 ++ c2 ++ c3 ++ c4) - ] - where - gr = runST $ do - g <- unsafeThaw (full 6 False :: Graph 'U () ()) - delEdges [(0,1), (0,2), (3,5)] g - unsafeFreeze g - c1 = [[0], [1], [2], [3], [4], [5]] - c2 = [ [0,3], [0,4], [0,5], [1,2], [1,3], [1,4], [1,5], [2,3], [2,4] - , [2,5], [3,4], [4,5] ] - c3 = [ [0,3,4], [0,4,5], [1,2,3], [1,2,4], [1,2,5], [1,3,4], [1,4,5], - [2,3,4], [2,4,5] ] - c4 = [[1, 2, 3, 4], [1, 2, 4, 5]] diff --git a/tests/Test/Isomorphism.hs b/tests/Test/Isomorphism.hs deleted file mode 100644 --- a/tests/Test/Isomorphism.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Test.Isomorphism - ( tests - ) where - -import Control.Arrow -import Control.Monad.ST -import Data.List -import qualified Data.Matrix.Unboxed as M -import System.IO.Unsafe -import Test.Tasty -import Test.Tasty.HUnit -import Test.Utils - -import IGraph -import IGraph -import IGraph.Motif -import IGraph.Isomorphism - -tests :: TestTree -tests = testGroup "Isomorphism" - [ graphIsomorphism ] - -graphIsomorphism :: TestTree -graphIsomorphism = testCase "Graph isomorphism" $ assertBool "" $ - and (zipWith isomorphic triad triad) && - (not . or) (zipWith isomorphic triad $ reverse triad) diff --git a/tests/Test/Motif.hs b/tests/Test/Motif.hs deleted file mode 100644 --- a/tests/Test/Motif.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Test.Motif - ( tests - ) where - -import Control.Arrow -import Control.Monad.ST -import Data.List -import qualified Data.Matrix.Unboxed as M -import System.IO.Unsafe -import Test.Tasty -import Test.Tasty.HUnit -import Test.Utils - -import IGraph -import IGraph -import IGraph.Motif - -tests :: TestTree -tests = testGroup "Network motif" - [ testCase "triad Census" $ M.toLists (M.ident 16 :: M.Matrix Int) @=? - map triadCensus triad ] diff --git a/tests/Test/Structure.hs b/tests/Test/Structure.hs deleted file mode 100644 --- a/tests/Test/Structure.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Test.Structure - ( tests - ) where - -import Control.Arrow -import Control.Monad.ST -import Test.Tasty -import Test.Tasty.HUnit -import Test.Utils -import System.IO.Unsafe -import Data.List - -import IGraph -import IGraph.Mutable -import IGraph.Structure -import IGraph.Generators - -tests :: TestTree -tests = testGroup "Structure property tests" - [ subGraphs - , pagerankTest - ] - -subGraphs :: TestTree -subGraphs = testGroup "generate induced subgraphs" - [ testCase "" $ test case1 ] - where - case1 = ( [("a","b"), ("b","c"), ("c","a"), ("a","c")] - , ["a","c"], [("a","c"), ("c","a")] ) - test (ori,ns,expect) = sort expect @=? sort result - where - gr = fromLabeledEdges $ zip ori $ repeat () :: Graph 'D String () - ns' = map (head . getNodes gr) ns - gr' = inducedSubgraph gr ns' - result = map (nodeLab gr' *** nodeLab gr') $ edges gr' - -pagerankTest :: TestTree -pagerankTest = testGroup "PageRank" - [ testCase "case 1" $ ranks @=? ranks' ] - where - gr = star 11 - ranks = [0.47,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05] - ranks' = map ((/100) . fromIntegral . round. (*100)) $ - pagerank gr Nothing Nothing 0.85 diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,17 +1,11 @@ -import qualified Test.Attributes as Attributes -import qualified Test.Basic as Basic -import qualified Test.Clique as Clique -import qualified Test.Isomorphism as Isomorphism -import qualified Test.Motif as Motif -import qualified Test.Structure as Structure +import qualified Test.Algorithms as Algorithms +import qualified Test.Attributes as Attributes +import qualified Test.Basic as Basic import Test.Tasty main :: IO () main = defaultMain $ testGroup "Haskell-igraph Tests" [ Basic.tests - , Structure.tests - , Motif.tests - , Isomorphism.tests + , Algorithms.tests , Attributes.tests - , Clique.tests ]