Commit 42221b5b authored by Kai Zhang's avatar Kai Zhang

refactoring

parent 055a3114
......@@ -27,7 +27,6 @@ library
exposed-modules:
IGraph.Internal.Initialization
IGraph.Internal.Constants
IGraph.Internal.Types
IGraph.Internal
IGraph
IGraph.Types
......@@ -59,12 +58,13 @@ library
, cereal-conduit
, colour
, conduit >= 1.3.0
, data-ordlist
, data-default-class
, primitive
, unordered-containers
, hashable
, hxt
, split
, data-default-class
extra-libraries: igraph
hs-source-dirs: src
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
module IGraph
( Graph(..)
, LGraph(..)
, U
, D
, decodeC
, empty
, mkGraph
, fromLabeledEdges
......@@ -32,7 +32,6 @@ import Control.Arrow ((&&&))
import Control.Monad (forM, forM_, liftM, replicateM)
import Control.Monad.Primitive
import Control.Monad.ST (runST)
import qualified Data.ByteString as B
import Data.Conduit.Cereal
import Data.Either (fromRight)
import Data.Hashable (Hashable)
......@@ -41,7 +40,7 @@ import qualified Data.HashSet as S
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Serialize
import Foreign (castPtr)
import Foreign (castPtr, Ptr)
import System.IO.Unsafe (unsafePerformIO)
import IGraph.Internal
......@@ -92,7 +91,7 @@ class MGraph d => Graph d where
-- | Return the label of given node.
nodeLab :: Serialize v => LGraph d v e -> Node -> v
nodeLab (LGraph g _) i = unsafePerformIO $
igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>=
igraphHaskellAttributeVAS g vertexAttr i >>= toByteString >>=
return . fromRight (error "decode failed") . decode
{-# INLINE nodeLab #-}
......@@ -105,7 +104,7 @@ class MGraph d => Graph d where
edgeLab :: Serialize e => LGraph d v e -> Edge -> e
edgeLab (LGraph g _) (fr,to) = unsafePerformIO $
igraphGetEid g fr to True True >>=
igraphHaskellAttributeEAS g edgeAttr >>= bsToByteString >>=
igraphHaskellAttributeEAS g edgeAttr >>= toByteString >>=
return . fromRight (error "decode failed") . decode
{-# INLINE edgeLab #-}
......@@ -117,7 +116,7 @@ class MGraph d => Graph d where
-- | Find the edge label by edge ID.
getEdgeLabByEid :: Serialize e => LGraph d v e -> Int -> e
getEdgeLabByEid (LGraph g _) i = unsafePerformIO $
igraphHaskellAttributeEAS g edgeAttr i >>= bsToByteString >>=
igraphHaskellAttributeEAS g edgeAttr i >>= toByteString >>=
return . fromRight (error "decode failed") . decode
{-# INLINE getEdgeLabByEid #-}
......@@ -152,17 +151,6 @@ instance (Graph d, Serialize v, Serialize e, Hashable v, Eq v)
es <- replicateM ne get
return $ mkGraph nds es
-- | Decode a graph from a stream of inputs. This may be more memory efficient
-- than standard @decode@ function.
decodeC :: ( PrimMonad m, MonadThrow m, Graph d
, Serialize v, Serialize e, Hashable v, Eq v )
=> ConduitT B.ByteString o m (LGraph d v e)
decodeC = do
nn <- sinkGet get
nds <- replicateM nn $ sinkGet get
ne <- sinkGet get
conduitGet2 get .| deserializeGraph nds ne
-- | Create a empty graph.
empty :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e)
=> LGraph d v e
......@@ -190,17 +178,18 @@ fromLabeledEdges es = mkGraph labels es'
labelToId = M.fromList $ zip labels [0..]
-- | Create a graph from a stream of labeled edges.
fromLabeledEdges' :: (PrimMonad m, Graph d, Hashable v, Serialize v, Eq v, Serialize e)
fromLabeledEdges' :: (Graph d, Hashable v, Serialize v, Eq v, Serialize e)
=> a -- ^ Input, usually a file
-> (a -> ConduitT () ((v, v), e) m ()) -- ^ deserialize the input into a stream of edges
-> m (LGraph d v e)
-> (a -> ConduitT () ((v, v), e) IO ()) -- ^ deserialize the input into a stream of edges
-> IO (LGraph d v e)
fromLabeledEdges' input mkConduit = do
(labelToId, _, ne) <- runConduit $ mkConduit input .|
foldlC f (M.empty, 0::Int, 0::Int)
let getId x = M.lookupDefault undefined x labelToId
runConduit $ mkConduit input .|
mapC (\((v1, v2), e) -> ((getId v1, getId v2), e)) .|
deserializeGraph (fst $ unzip $ sortBy (comparing snd) $ M.toList labelToId) ne
allocaVectorN (2*ne) $ \evec -> allocaBSVectorN ne $ \bsvec -> do
let getId x = M.lookupDefault 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
where
f (vs, nn, ne) ((v1, v2), _) =
let (vs', nn') = add v1 $ add v2 (vs, nn)
......@@ -210,26 +199,25 @@ fromLabeledEdges' input mkConduit = do
then (m, i)
else (M.insert v i m, i + 1)
deserializeGraph :: ( PrimMonad m, Graph d, Hashable v, Serialize v
deserializeGraph :: ( Graph d, Hashable v, Serialize v
, Eq v, Serialize e )
=> [v]
-> Int -- ^ The number of edges
-> ConduitT (LEdge e) o m (LGraph d v e)
deserializeGraph nds ne = do
evec <- unsafePrimToPrim $ igraphVectorNew $ 2 * ne
bsvec <- unsafePrimToPrim $ bsvectorNew ne
let f i ((fr, to), attr) = unsafePrimToPrim $ do
-> Ptr Vector -- ^ a vector that is sufficient to hold all edges
-> Ptr BSVector
-> ConduitT (LEdge e) o IO (LGraph d v e)
deserializeGraph nds evec bsvec = do
let f i ((fr, to), attr) = liftIO $ do
igraphVectorSet evec (i*2) $ fromIntegral fr
igraphVectorSet evec (i*2+1) $ fromIntegral to
bsvectorSet bsvec i $ encode attr
return $ i + 1
_ <- foldMC f 0
gr@(MLGraph g) <- new 0
addLNodes nds gr
unsafePrimToPrim $ withAttr edgeAttr bsvec $ \ptr -> do
vptr <- fromPtrs [castPtr ptr]
withVectorPtr vptr (igraphAddEdges g evec . castPtr)
unsafeFreeze gr
liftIO $ do
addLNodes nds gr
withBSAttr edgeAttr bsvec $ \ptr ->
withPtrs [ptr] (igraphAddEdges g evec . castPtr)
unsafeFreeze gr
{-# INLINE deserializeGraph #-}
-- | Convert a mutable graph to immutable graph.
......@@ -246,7 +234,7 @@ unsafeFreeze :: (Hashable v, Eq v, Serialize v, PrimMonad m)
unsafeFreeze (MLGraph g) = unsafePrimToPrim $ do
nV <- igraphVcount g
labels <- forM [0 .. nV - 1] $ \i ->
igraphHaskellAttributeVAS g vertexAttr i >>= bsToByteString >>=
igraphHaskellAttributeVAS g vertexAttr i >>= toByteString >>=
return . fromRight (error "decode failed") . decode
return $ LGraph g $ M.fromListWith (++) $ zip labels $ map return [0..nV-1]
where
......@@ -261,24 +249,18 @@ unsafeThaw (LGraph g _) = return $ MLGraph g
-- | Find all neighbors of the given node.
neighbors :: LGraph d v e -> Node -> [Node]
neighbors gr i = unsafePerformIO $ do
vs <- igraphVsAdj i IgraphAll
vit <- igraphVitNew (_graph gr) vs
vitToList vit
neighbors gr i = unsafePerformIO $ withVerticesAdj i IgraphAll $ \vs ->
iterateVerticesC (_graph gr) vs $ \source -> runConduit $ source .| sinkList
-- | Find all nodes that have a link from the given node.
suc :: LGraph D v e -> Node -> [Node]
suc gr i = unsafePerformIO $ do
vs <- igraphVsAdj i IgraphOut
vit <- igraphVitNew (_graph gr) vs
vitToList vit
suc gr i = unsafePerformIO $ withVerticesAdj i IgraphOut $ \vs ->
iterateVerticesC (_graph gr) vs $ \source -> runConduit $ source .| sinkList
-- | Find all nodes that link to to the given node.
pre :: LGraph D v e -> Node -> [Node]
pre gr i = unsafePerformIO $ do
vs <- igraphVsAdj i IgraphIn
vit <- igraphVitNew (_graph gr) vs
vitToList vit
pre gr i = unsafePerformIO $ withVerticesAdj i IgraphIn $ \vs ->
iterateVerticesC (_graph gr) vs $ \source -> runConduit $ source .| sinkList
-- | Apply a function to change nodes' labels.
nmap :: (Graph d, Serialize v1, Serialize v2, Hashable v2, Eq v2)
......
......@@ -8,6 +8,7 @@ import Control.Applicative ((<$>))
import System.IO.Unsafe (unsafePerformIO)
import qualified Foreign.Ptr as C2HSImp
import Foreign
import IGraph
{#import IGraph.Internal #}
......@@ -18,18 +19,16 @@ cliques :: LGraph 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 $ do
vpptr <- igraphVectorPtrNew 0
_ <- igraphCliques (_graph gr) vpptr lo hi
cliques gr (lo, hi) = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do
igraphCliques (_graph gr) vpptr lo hi
(map.map) truncate <$> toLists vpptr
{#fun igraph_cliques as ^ { `IGraph', `VectorPtr', `Int', `Int' } -> `Int' #}
{#fun igraph_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #}
maximalCliques :: LGraph 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 $ do
vpptr <- igraphVectorPtrNew 0
_ <- igraphMaximalCliques (_graph gr) vpptr lo hi
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', `VectorPtr', `Int', `Int' } -> `Int' #}
{#fun igraph_maximal_cliques as ^ { `IGraph', castPtr `Ptr VectorPtr', `Int', `Int' } -> `CInt' void- #}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
module IGraph.Community
( CommunityOpt(..)
, CommunityMethod(..)
( modularity
, findCommunity
, CommunityMethod(..)
, defaultLeadingEigenvector
, defaultSpinglass
) where
import Data.Default.Class
import Data.Function (on)
import Data.List (sortBy, groupBy)
import Data.List.Ordered (nubSortBy)
import Data.Ord (comparing)
import System.IO.Unsafe (unsafePerformIO)
......@@ -15,99 +19,116 @@ import Foreign
import Foreign.C.Types
import IGraph
import IGraph.Internal.C2HS
{#import IGraph.Internal #}
{#import IGraph.Internal.Constants #}
#include "haskell_igraph.h"
data CommunityOpt = CommunityOpt
{ _method :: CommunityMethod
, _weights :: Maybe [Double]
, _nIter :: Int -- ^ [LeadingEigenvector] number of iterations, default is 10000
, _nSpins :: Int -- ^ [Spinglass] number of spins, default is 25
, _startTemp :: Double -- ^ [Spinglass] the temperature at the start
, _stopTemp :: Double -- ^ [Spinglass] the algorithm stops at this temperature
, _coolFact :: Double -- ^ [Spinglass] the cooling factor for the simulated annealing
, _gamma :: Double -- ^ [Spinglass] the gamma parameter of the algorithm.
}
data CommunityMethod = LeadingEigenvector
| Spinglass
modularity :: Graph d
=> LGraph 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- #}
instance Default CommunityOpt where
def = CommunityOpt
{ _method = LeadingEigenvector
, _weights = Nothing
, _nIter = 10000
, _nSpins = 25
, _startTemp = 1.0
, _stopTemp = 0.01
, _coolFact = 0.99
, _gamma = 1.0
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
findCommunity :: LGraph U v e -> CommunityOpt -> [[Int]]
findCommunity gr opt = unsafePerformIO $ do
result <- igraphVectorNew 0
ws <- case _weights opt of
Just w -> fromList w
_ -> fmap Vector $ newForeignPtr_ $ castPtr nullPtr
defaultSpinglass :: CommunityMethod
defaultSpinglass = Spinglass
{ _nSpins = 25
, _startTemp = 1.0
, _stopTemp = 0.01
, _coolFact = 0.99
, _gamma = 1.0 }
_ <- case _method opt of
LeadingEigenvector -> do
ap <- igraphArpackNew
igraphCommunityLeadingEigenvector (_graph gr) ws nullPtr result
(_nIter opt) ap nullPtr False
nullPtr nullPtr nullPtr
nullFunPtr nullPtr
Spinglass ->
igraphCommunitySpinglass (_graph gr) ws nullPtr nullPtr result
nullPtr (_nSpins opt) False (_startTemp opt)
(_stopTemp opt) (_coolFact opt)
IgraphSpincommUpdateConfig (_gamma opt)
findCommunity :: LGraph 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
fmap ( map (fst . unzip) . groupBy ((==) `on` snd)
. sortBy (comparing snd) . zip [0..] ) $ toList result
{#fun igraph_community_spinglass as ^
{ `IGraph'
, `Vector'
, id `Ptr CDouble'
, id `Ptr CDouble'
, `Vector'
, id `Ptr Vector'
, `Int'
, `Bool'
, `Double'
, `Double'
, `Double'
, `SpincommUpdate'
, `Double'
, `SpinglassImplementation'
, `Double'
} -> `Int' #}
{ `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'
, `Vector'
, id `Ptr Matrix'
, `Vector'
, `Int'
, `ArpackOpt'
, id `Ptr CDouble'
, `Bool'
, id `Ptr Vector'
, id `Ptr VectorPtr'
, id `Ptr Vector'
, id `T'
, id `Ptr ()'
} -> `Int' #}
{ `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 Vector
type T = FunPtr ( Ptr ()
-> CLong
-> CDouble
-> Ptr Vector
-> Ptr ()
-> FunPtr (Ptr CDouble -> Ptr CDouble -> CInt -> Ptr () -> IO CInt)
-> Ptr ()
-> Ptr ()
......
......@@ -12,6 +12,7 @@ import Data.Hashable (Hashable)
import Data.Serialize (Serialize)
import qualified Foreign.Ptr as C2HSImp
import Foreign
import IGraph
import IGraph.Mutable
......@@ -50,14 +51,13 @@ erdosRenyiGame (GNM n m) d self = do
degreeSequenceGame :: [Int] -- ^ Out degree
-> [Int] -- ^ In degree
-> IO (LGraph D () ())
degreeSequenceGame out_deg in_deg = do
out_deg' <- fromList $ map fromIntegral out_deg
in_deg' <- fromList $ map fromIntegral in_deg
gp <- igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple
unsafeFreeze $ MLGraph gp
degreeSequenceGame out_deg in_deg = withList out_deg $ \out_deg' ->
withList in_deg $ \in_deg' -> do
gp <- igraphDegreeSequenceGame out_deg' in_deg' IgraphDegseqSimple
unsafeFreeze $ MLGraph gp
{#fun igraph_degree_sequence_game as ^
{ allocaIGraph- `IGraph' addIGraphFinalizer*
, `Vector', `Vector', `Degseq'
, castPtr `Ptr Vector', castPtr `Ptr Vector', `Degseq'
} -> `CInt' void- #}
-- | Randomly rewires a graph while preserving the degree distribution.
......
This diff is collapsed.
{-# LANGUAGE ForeignFunctionInterface #-}
module IGraph.Internal.Types
( -- * Vector type and basic operations
Vector(..)
, withVector
, allocaVector
, addVectorFinalizer
-- * Pointer vector
, VectorPtr(..)
, withVectorPtr
, allocaVectorPtr
, addVectorPtrFinalizer
-- * String vector
, StrVector(..)
, withStrVector
, allocaStrVector
, addStrVectorFinalizer
-- * Bytestring
, BSLen(..)
, withBSLen
-- * Bytestring vector
, BSVector(..)
, withBSVector
, allocaBSVector
, addBSVectorFinalizer
-- * Igraph matrix type
, Matrix(..)
, withMatrix
, allocaMatrix
, addMatrixFinalizer
-- * Igraph vertex selector
, IGraphVs(..)
, withIGraphVs
, allocaVs
, addVsFinalizer
-- * Igraph vertex iterator
, IGraphVit(..)
, withIGraphVit
, allocaVit
, addVitFinalizer
-- * Igraph edge Selector
, IGraphEs
, withIGraphEs
, allocaEs
, addEsFinalizer
-- * Igraph edge iterator
, IGraphEit(..)
, withIGraphEit
, allocaEit
, addEitFinalizer
-- * IGraph type and basic operations
, IGraph(..)
, withIGraph
, allocaIGraph
, addIGraphFinalizer
-- * Igraph attribute record
, AttributeRecord(..)
, withAttributeRecord
-- * Igraph arpack options type
, ArpackOpt(..)
, withArpackOpt
, igraphArpackNew
) where
import Foreign
#include "haskell_attributes.h"
#include "haskell_igraph.h"
--------------------------------------------------------------------------------
-- Igraph vector
--------------------------------------------------------------------------------
{#pointer *igraph_vector_t as Vector foreign finalizer
igraph_vector_destroy newtype#}
-- Construtors and destructors
allocaVector :: (Ptr Vector -> IO a) -> IO a
allocaVector f = mallocBytes {# sizeof igraph_vector_t #} >>= f
{-# INLINE allocaVector #-}
addVectorFinalizer :: Ptr Vector -> IO Vector
addVectorFinalizer ptr = do
vec <- newForeignPtr igraph_vector_destroy ptr
return $ Vector vec
{-# INLINE addVectorFinalizer #-}
{#pointer *igraph_vector_ptr_t as VectorPtr foreign finalizer
igraph_vector_ptr_destroy newtype#}
allocaVectorPtr :: (Ptr VectorPtr -> IO a) -> IO a
allocaVectorPtr f = mallocBytes {# sizeof igraph_vector_ptr_t #} >>= f
{-# INLINE allocaVectorPtr #-}
addVectorPtrFinalizer :: Ptr VectorPtr -> IO VectorPtr
addVectorPtrFinalizer ptr = do
vec <- newForeignPtr igraph_vector_ptr_destroy ptr
return $ VectorPtr vec
{-# INLINE addVectorPtrFinalizer #-}
--------------------------------------------------------------------------------
-- Igraph string vector
--------------------------------------------------------------------------------
{#pointer *igraph_strvector_t as StrVector foreign finalizer igraph_strvector_destroy newtype#}
allocaStrVector :: (Ptr StrVector -> IO a) -> IO a
allocaStrVector f = mallocBytes {# sizeof igraph_strvector_t #} >>= f
{-# INLINE allocaStrVector #-}
addStrVectorFinalizer :: Ptr StrVector -> IO StrVector
addStrVectorFinalizer ptr = do
vec <- newForeignPtr igraph_strvector_destroy ptr
return $ StrVector vec
{-# INLINE addStrVectorFinalizer #-}
--------------------------------------------------------------------------------
-- Customized string vector
--------------------------------------------------------------------------------
{#pointer *bytestring_t as BSLen foreign newtype#}
{#pointer *bsvector_t as BSVector foreign finalizer bsvector_destroy newtype#}
allocaBSVector :: (Ptr BSVector -> IO a) -> IO a
allocaBSVector f = mallocBytes {# sizeof bsvector_t #} >>= f
{-# INLINE allocaBSVector #-}
addBSVectorFinalizer :: Ptr BSVector -> IO BSVector
addBSVectorFinalizer ptr = do
vec <- newForeignPtr bsvector_destroy ptr
return $ BSVector vec
{-# INLINE addBSVectorFinalizer #-}
{#pointer *igraph_matrix_t as Matrix foreign finalizer igraph_matrix_destroy newtype#}
allocaMatrix :: (Ptr Matrix -> IO a) -> IO a
allocaMatrix f = mallocBytes {# sizeof igraph_matrix_t #} >>= f
{-# INLINE allocaMatrix #-}
addMatrixFinalizer :: Ptr Matrix -> IO Matrix
addMatrixFinalizer ptr = do
vec <- newForeignPtr igraph_matrix_destroy ptr
return $ Matrix vec
{-# INLINE addMatrixFinalizer #-}
{#pointer *igraph_vs_t as IGraphVs foreign finalizer igraph_vs_destroy newtype #}
allocaVs :: (Ptr IGraphVs -> IO a) -> IO a
allocaVs f = mallocBytes {# sizeof igraph_vs_t #} >>= f
{-# INLINE allocaVs #-}
addVsFinalizer :: Ptr IGraphVs -> IO IGraphVs
addVsFinalizer ptr = newForeignPtr igraph_vs_destroy ptr >>= return . IGraphVs
{-# INLINE addVsFinalizer #-}
-- Vertex iterator
{#pointer *igraph_vit_t as IGraphVit foreign finalizer igraph_vit_destroy newtype #}
allocaVit :: (Ptr IGraphVit -> IO a) -> IO a
allocaVit f = mallocBytes {# sizeof igraph_vit_t #} >>= f
{-# INLINE allocaVit #-}
addVitFinalizer :: Ptr IGraphVit -> IO IGraphVit
addVitFinalizer ptr = newForeignPtr igraph_vit_destroy ptr >>= return . IGraphVit
{-# INLINE addVitFinalizer #-}
-- Edge Selector
{#pointer *igraph_es_t as IGraphEs foreign finalizer igraph_es_destroy newtype #}
allocaEs :: (Ptr IGraphEs -> IO a) -> IO a
allocaEs f = mallocBytes {# sizeof igraph_es_t #} >>= f
{-# INLINE allocaEs #-}
addEsFinalizer :: Ptr IGraphEs -> IO IGraphEs
addEsFinalizer ptr = newForeignPtr igraph_es_destroy ptr >>= return . IGraphEs
{-# INLINE addEsFinalizer #-}
-- Edge iterator
{#pointer *igraph_eit_t as IGraphEit foreign finalizer igraph_eit_destroy newtype #}
allocaEit :: (Ptr IGraphEit -> IO a) -> IO a
allocaEit f = mallocBytes {# sizeof igraph_eit_t #} >>= f
{-# INLINE allocaEit #-}
addEitFinalizer :: Ptr IGraphEit -> IO IGraphEit
addEitFinalizer ptr = newForeignPtr igraph_eit_destroy ptr >>= return . IGraphEit
{-# INLINE addEitFinalizer #-}
--------------------------------------------------------------------------------
-- Graph Constructors and Destructors
--------------------------------------------------------------------------------
{#pointer *igraph_t as IGraph foreign finalizer igraph_destroy newtype#}
allocaIGraph :: (Ptr IGraph -> IO a) -> IO a
allocaIGraph f = mallocBytes {# sizeof igraph_t #} >>= f
{-# INLINE allocaIGraph #-}
addIGraphFinalizer :: Ptr IGraph -> IO IGraph
addIGraphFinalizer ptr = do
vec <- newForeignPtr igraph_destroy ptr
return $ IGraph vec
{-# INLINE addIGraphFinalizer #-}
{#pointer *igraph_attribute_record_t as AttributeRecord foreign newtype#}
{#pointer *igraph_arpack_options_t as ArpackOpt foreign newtype#}
{#fun igraph_arpack_options_init as igraphArpackNew
{ + } -> `ArpackOpt' #}
......@@ -23,8 +23,7 @@ getSubisomorphisms :: Graph d
=> LGraph d v1 e1 -- ^ graph to be searched in
-> LGraph d v2 e2 -- ^ smaller graph
-> [[Int]]
getSubisomorphisms g1 g2 = unsafePerformIO $ do
vpptr <- igraphVectorPtrNew 0
getSubisomorphisms g1 g2 = unsafePerformIO $ allocaVectorPtr $ \vpptr -> do
igraphGetSubisomorphismsVf2 gptr1 gptr2 nullPtr nullPtr nullPtr nullPtr vpptr
nullFunPtr nullFunPtr nullPtr
(map.map) truncate <$> toLists vpptr
......@@ -39,7 +38,7 @@ getSubisomorphisms g1 g2 = unsafePerformIO $ do
, id `Ptr ()'
, id `Ptr ()'
, id `Ptr ()'
, `VectorPtr'
, 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 ()'
......
......@@ -62,48 +62,48 @@ defaultLGL = LGL
area x = fromIntegral $ x^2
getLayout :: Graph d => LGraph d v e -> LayoutMethod -> IO [(Double, Double)]
getLayout gr method = do
case method of
KamadaKawai seed niter sigma initemp coolexp kkconst -> do
mptr <- case seed of
Nothing -> igraphMatrixNew 0 0
Just xs -> if length xs /= nNodes gr
then error "Seed error: incorrect size"
else fromRowLists $ (\(x,y) -> [x,y]) $ unzip xs
igraphLayoutKamadaKawai gptr mptr niter (sigma n) initemp coolexp
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 mptr
[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 -> do
mptr <- igraphMatrixNew 0 0
igraphLayoutLgl gptr mptr niter (delta n) (area n) coolexp
(repulserad n) (cellsize n) (-1)
[x, y] <- toColumnLists mptr
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'
, `Matrix'
, castPtr `Ptr Matrix'
, `Int'
, `Double'
, `Double'
, `Double'
, `Double'
, `Bool'
, id `Ptr Vector'
, id `Ptr Vector'
, id `Ptr Vector'
, id `Ptr Vector'
, castPtr `Ptr Vector'
, castPtr `Ptr Vector'
, castPtr `Ptr Vector'
, castPtr `Ptr Vector'
} -> `CInt' void- #}
{# fun igraph_layout_lgl as ^
{ `IGraph'
, `Matrix'
, castPtr `Ptr Matrix'
, `Int'
, `Double'
, `Double'
......
......@@ -7,6 +7,7 @@ module IGraph.Motif
import Data.Hashable (Hashable)
import System.IO.Unsafe (unsafePerformIO)
import Foreign
import qualified Foreign.Ptr as C2HSImp
import IGraph
......@@ -56,15 +57,14 @@ triad = map make edgeList
make xs = mkGraph (replicate 3 ()) $ zip xs $ repeat ()
triadCensus :: (Hashable v, Eq v, Read v) => LGraph d v e -> [Int]
triadCensus gr = unsafePerformIO $ do
vptr <- igraphVectorNew 0
igraphTriadCensus (_graph gr) vptr
map truncate <$> toList vptr
triadCensus gr = unsafePerformIO $ allocaVector $ \result -> do
igraphTriadCensus (_graph gr) result
map truncate <$> toList result
-- motifsRandesu
{#fun igraph_triad_census as ^ { `IGraph'
, `Vector' } -> `CInt' void- #}
, castPtr `Ptr Vector' } -> `CInt' void- #}
{#fun igraph_motifs_randesu as ^ { `IGraph', `Vector', `Int'
, `Vector' } -> `CInt' void- #}
{#fun igraph_motifs_randesu as ^ { `IGraph', castPtr `Ptr Vector', `Int'
, castPtr `Ptr Vector' } -> `CInt' void- #}
......@@ -32,40 +32,31 @@ class MGraph d where
addLNodes :: (Serialize v, PrimMonad m)
=> [v] -- ^ vertices' labels
-> MLGraph (PrimState m) d v e -> m ()
addLNodes labels (MLGraph g) = unsafePrimToPrim $ do
bsvec <- toBSVector $ map encode labels
withAttr vertexAttr bsvec $ \attr -> do
vptr <- fromPtrs [castPtr attr]
withVectorPtr vptr (igraphAddVertices g n . castPtr)
addLNodes labels (MLGraph g) = unsafePrimToPrim $
withAttr vertexAttr labels $ \attr ->
withPtrs [attr] (igraphAddVertices g n . castPtr)
where
n = length labels
-- | Delete nodes from the graph.
delNodes :: PrimMonad m => [Int] -> MLGraph (PrimState m) d v e -> m ()
delNodes ns (MLGraph g) = unsafePrimToPrim $ do
vptr <- fromList $ map fromIntegral ns
vsptr <- igraphVsVector vptr
_ <- igraphDeleteVertices g vsptr
return ()
delNodes ns (MLGraph g) = unsafePrimToPrim $ withVerticesList ns $ \vs ->
igraphDeleteVertices g vs
-- | Add edges to the graph.
addEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m ()
addEdges es (MLGraph g) = unsafePrimToPrim $ do
vec <- fromList xs
addEdges es (MLGraph g) = unsafePrimToPrim $ withList xs $ \vec ->
igraphAddEdges g vec nullPtr
where
xs = concatMap ( \(a,b) -> [fromIntegral a, fromIntegral b] ) es
xs = concatMap ( \(a,b) -> [a, b] ) es
-- | Add edges with labels to the graph.
addLEdges :: (PrimMonad m, Serialize e) => [LEdge e] -> MLGraph (PrimState m) d v e -> m ()
addLEdges es (MLGraph g) = unsafePrimToPrim $ do
bsvec <- toBSVector $ map encode vs
withAttr edgeAttr bsvec $ \attr -> do
vec <- fromList $ concat xs
vptr <- fromPtrs [castPtr attr]
withVectorPtr vptr (igraphAddEdges g vec . castPtr)
addLEdges es (MLGraph g) = unsafePrimToPrim $
withAttr edgeAttr vs $ \attr -> withList (concat xs) $ \vec ->
withPtrs [attr] (igraphAddEdges g vec . castPtr)
where
(xs, vs) = unzip $ map ( \((a,b),v) -> ([fromIntegral a, fromIntegral b], v) ) es
(xs, vs) = unzip $ map ( \((a,b),v) -> ([a, b], v) ) es
-- | Delete edges from the graph.
delEdges :: PrimMonad m => [(Int, Int)] -> MLGraph (PrimState m) d v e -> m ()
......@@ -75,20 +66,14 @@ instance MGraph U where
delEdges es (MLGraph g) = unsafePrimToPrim $ do
eids <- forM es $ \(fr, to) -> igraphGetEid g fr to False True
vptr <- fromList $ map fromIntegral eids
esptr <- igraphEsVector vptr
_ <- igraphDeleteEdges g esptr
return ()
withEdgesList eids (igraphDeleteEdges g)
instance MGraph D where
new n = unsafePrimToPrim $ igraphInit >>= igraphNew n True >>= return . MLGraph
delEdges es (MLGraph g) = unsafePrimToPrim $ do
eids <- forM es $ \(fr, to) -> igraphGetEid g fr to True True
vptr <- fromList $ map fromIntegral eids
esptr <- igraphEsVector vptr
igraphDeleteEdges g esptr
return ()
withEdgesList eids (igraphDeleteEdges g)
-- | Set node attribute.
setNodeAttr :: (PrimMonad m, Serialize v)
......@@ -96,9 +81,10 @@ setNodeAttr :: (PrimMonad m, Serialize v)
-> v
-> MLGraph (PrimState m) d v e
-> m ()
setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $ asBS (encode x) $ \bs -> do
err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId bs
when (err /= 0) $ error "Fail to set node attribute!"
setNodeAttr nodeId x (MLGraph gr) = unsafePrimToPrim $
withByteString (encode x) $ \bs -> do
err <- igraphHaskellAttributeVASSet gr vertexAttr nodeId bs
when (err /= 0) $ error "Fail to set node attribute!"
-- | Set edge attribute.
setEdgeAttr :: (PrimMonad m, Serialize e)
......@@ -106,6 +92,7 @@ setEdgeAttr :: (PrimMonad m, Serialize e)
-> e
-> MLGraph (PrimState m) d v e
-> m ()
setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $ asBS (encode x) $ \bs -> do
err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId bs
when (err /= 0) $ error "Fail to set edge attribute!"
setEdgeAttr edgeId x (MLGraph gr) = unsafePrimToPrim $
withByteString (encode x) $ \bs -> do
err <- igraphHaskellAttributeEASSet gr edgeAttr edgeId bs
when (err /= 0) $ error "Fail to set edge attribute!"
......@@ -14,6 +14,7 @@ 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 Foreign
import Foreign.C.Types
......@@ -26,10 +27,8 @@ import IGraph.Mutable
#include "igraph/igraph.h"
inducedSubgraph :: (Hashable v, Eq v, Serialize v) => LGraph d v e -> [Int] -> LGraph d v e
inducedSubgraph gr vs = unsafePerformIO $ do
vs' <- fromList $ map fromIntegral vs
vsptr <- igraphVsVector vs'
igraphInducedSubgraph (_graph gr) vsptr IgraphSubgraphCreateFromScratch >>=
inducedSubgraph gr nds = unsafePerformIO $ withVerticesList nds $ \vs ->
igraphInducedSubgraph (_graph gr) vs IgraphSubgraphCreateFromScratch >>=
unsafeFreeze . MLGraph
-- | Closeness centrality
......@@ -39,43 +38,29 @@ closeness :: [Int] -- ^ vertices
-> Neimode
-> Bool -- ^ whether to normalize
-> [Double]
closeness vs gr ws mode normal = unsafePerformIO $ do
vs' <- fromList $ map fromIntegral vs
vsptr <- igraphVsVector vs'
vptr <- igraphVectorNew 0
ws' <- case ws of
Just w -> fromList w
_ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr
igraphCloseness (_graph gr) vptr vsptr mode ws' normal
toList vptr
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
-- | Betweenness centrality
betweenness :: [Int]
-> LGraph d v e
-> Maybe [Double]
-> [Double]
betweenness vs gr ws = unsafePerformIO $ do
vs' <- fromList $ map fromIntegral vs
vsptr <- igraphVsVector vs'
vptr <- igraphVectorNew 0
ws' <- case ws of
Just w -> fromList w
_ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr
igraphBetweenness (_graph gr) vptr vsptr True ws' False
toList vptr
betweenness nds gr ws = unsafePerformIO $ allocaVector $ \result ->
withVerticesList nds $ \vs -> withListMaybe ws $ \ws' -> do
igraphBetweenness (_graph gr) result vs True ws' False
toList result
-- | Eigenvector centrality
eigenvectorCentrality :: LGraph d v e
-> Maybe [Double]
-> [Double]
eigenvectorCentrality gr ws = unsafePerformIO $ do
vptr <- igraphVectorNew 0
ws' <- case ws of
Just w -> fromList w
_ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr
arparck <- igraphArpackNew
igraphEigenvectorCentrality (_graph gr) vptr nullPtr True True ws' arparck
toList vptr
eigenvectorCentrality gr ws = unsafePerformIO $ allocaArpackOpt $ \arparck ->
allocaVector $ \result -> withListMaybe ws $ \ws' -> do
igraphEigenvectorCentrality (_graph gr) result nullPtr True True ws' arparck
toList result
-- | Google's PageRank
pagerank :: Graph d
......@@ -85,17 +70,12 @@ pagerank :: Graph d
-> [Double]
pagerank gr ws d
| n == 0 = []
| otherwise = unsafePerformIO $ alloca $ \p -> do
vptr <- igraphVectorNew 0
vsptr <- igraphVsAll
ws' <- case ws of
Just w -> if length w /= m
then error "pagerank: incorrect length of edge weight vector"
else fromList w
_ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr
igraphPagerank (_graph gr) IgraphPagerankAlgoPrpack vptr p vsptr
(isDirected gr) d ws' nullPtr
toList vptr
| 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
igraphPagerank (_graph gr) IgraphPagerankAlgoPrpack result p vs
(isDirected gr) d ws' nullPtr
toList result
where
n = nNodes gr
m = nEdges gr
......@@ -109,19 +89,13 @@ personalizedPagerank :: Graph d
-> [Double]
personalizedPagerank gr reset ws d
| n == 0 = []
| length reset /= n = error "personalizedPagerank: incorrect length of reset vector"
| otherwise = unsafePerformIO $ alloca $ \p -> do
vptr <- igraphVectorNew 0
vsptr <- igraphVsAll
ws' <- case ws of
Just w -> if length w /= m
then error "pagerank: incorrect length of edge weight vector"
else fromList w
_ -> liftM Vector $ newForeignPtr_ $ castPtr nullPtr
reset' <- fromList reset
igraphPersonalizedPagerank (_graph gr) IgraphPagerankAlgoPrpack vptr p vsptr
(isDirected gr) d reset' ws' nullPtr
toList vptr
| length reset /= n = error "incorrect length of reset vector"
| isJust ws && length (fromJust ws) /= m = error "incorrect length of edge weight vector"
| otherwise = unsafePerformIO $ alloca $ \p -> allocaVector $ \result ->
withList reset $ \reset' -> withVerticesAll $ \vs -> withListMaybe ws $ \ws' -> do
igraphPersonalizedPagerank (_graph gr) IgraphPagerankAlgoPrpack result p vs
(isDirected gr) d reset' ws' nullPtr
toList result
where
n = nNodes gr
m = nEdges gr
......@@ -129,53 +103,56 @@ personalizedPagerank gr reset ws d
{#fun igraph_induced_subgraph as ^
{ `IGraph'
, allocaIGraph- `IGraph' addIGraphFinalizer*
, %`IGraphVs'
, castPtr %`Ptr VertexSelector'
, `SubgraphImplementation'
} -> `CInt' void- #}
{#fun igraph_closeness as ^ { `IGraph'
, `Vector'
, %`IGraphVs'
, `Neimode'
, `Vector'
, `Bool' } -> `CInt' void- #}
{#fun igraph_betweenness as ^ { `IGraph'
, `Vector'
, %`IGraphVs'
, `Bool'
, `Vector'
, `Bool' } -> `CInt' void- #}
{#fun igraph_eigenvector_centrality as ^ { `IGraph'
, `Vector'
, id `Ptr CDouble'
, `Bool'
, `Bool'
, `Vector'
, `ArpackOpt' } -> `CInt' void- #}
{#fun igraph_closeness as ^
{ `IGraph'
, castPtr `Ptr Vector'
, castPtr %`Ptr VertexSelector'
, `Neimode'
, castPtr `Ptr Vector'
, `Bool' } -> `CInt' void- #}
{#fun igraph_betweenness as ^
{ `IGraph'
, castPtr `Ptr Vector'
, castPtr %`Ptr VertexSelector'
, `Bool'
, castPtr `Ptr Vector'
, `Bool' } -> `CInt' void- #}
{#fun igraph_eigenvector_centrality as ^
{ `IGraph'
, castPtr `Ptr Vector'
, id `Ptr CDouble'
, `Bool'
, `Bool'
, castPtr `Ptr Vector'
, castPtr `Ptr ArpackOpt' } -> `CInt' void- #}
{#fun igraph_pagerank as ^
{ `IGraph'
, `PagerankAlgo'
, `Vector'
, castPtr `Ptr Vector'
, id `Ptr CDouble'
, %`IGraphVs'
, castPtr %`Ptr VertexSelector'
, `Bool'
, `Double'
, `Vector'
, castPtr `Ptr Vector'
, id `Ptr ()'
} -> `CInt' void- #}
{#fun igraph_personalized_pagerank as ^
{ `IGraph'
, `PagerankAlgo'
, `Vector'
, castPtr `Ptr Vector'
, id `Ptr CDouble'
, %`IGraphVs'
, castPtr %`Ptr VertexSelector'
, `Bool'
, `Double'
, `Vector'
, `Vector'
, castPtr `Ptr Vector'
, castPtr `Ptr Vector'
, id `Ptr ()'
} -> `CInt' void- #}
......@@ -54,7 +54,4 @@ serializeTest = testCase "serialize test" $ do
Left msg -> error msg
Right r -> r
es' = map (\(a,b) -> ((nodeLab gr' a, nodeLab gr' b), edgeLab gr' (a,b))) $ edges gr'
gr'' <- runConduit $ (yield $ encode gr) .| decodeC :: IO (LGraph D NodeAttr EdgeAttr)
let 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'')
assertBool "" $ sort (map show es) == sort (map show es')
......@@ -50,7 +50,7 @@ graphCreationLabeled = testGroup "Graph creation -- with labels"
n = length $ nubSort $ concatMap (\((a,b),_) -> [a,b]) edgeList
m = length edgeList
gr = fromLabeledEdges edgeList :: LGraph D String Int
gr' = runST $ fromLabeledEdges' edgeList yieldMany :: LGraph D String Int
gr' = unsafePerformIO $ fromLabeledEdges' edgeList yieldMany :: LGraph D String Int
graphEdit :: TestTree
graphEdit = testGroup "Graph editing"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment